#!/usr/bin/env scheme-script
;; -*- mode: scheme; coding: utf-8 -*- !#
;; tarinfo - Print information about tarballs
;; Copyright © 2010, 2011 Göran Weinholt <goran@weinholt.se>

;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the "Software"),
;; to deal in the Software without restriction, including without limitation
;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;; and/or sell copies of the Software, and to permit persons to whom the
;; Software is furnished to do so, subject to the following conditions:

;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.

;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.
#!r6rs

;; Prints assorted facts about tarballs.

(import (rnrs)
        (srfi :19 time)
        (weinholt archive tar)
        (weinholt compression gzip)
        (weinholt compression xz))

(define (print . x) (for-each display x) (newline))

(define (pad-left s len c)
  (let ((s (if (number? s) (number->string s) s)))
    (if (< (string-length s) len)
        (string-append s (make-string (- len (string-length s)) c))
        s)))

(define (pad-right s len c)
  (let ((s (if (number? s) (number->string s) s)))
    (if (< (string-length s) len)
        (string-append (make-string (- len (string-length s)) c) s)
        s)))

(define (format-mode mode)
  (number->string mode 8))

(define (open-tarball fn)
  (print "Listing information about `" fn "'")
  (let ((p (open-file-input-port fn)))
    (cond ((is-gzip-file? p)
           (print "Looks like a gzip'd tarball.")
           (let ((hdr (get-gzip-header p)))
             (when (gzip-mtime hdr)
               (print "GZIP created on " (date->string (gzip-mtime hdr)
                                                       "~1 ~2")))
             (when (gzip-text? hdr)
               (print "Compressor believed this tarball to be text."))
             (unless (equal? #vu8() (gzip-extra-data hdr))
               (print "Extra data: " (gzip-extra-data hdr)))
             (when (gzip-filename hdr)
               (print "Original filename: `" (gzip-filename hdr) "'"))
             (when (gzip-comment hdr) (print "File comment: " (gzip-comment hdr)))
             (print "GZIP compressor used the " (gzip-method hdr) " algorithm")
             (print "Created on operating system type #" (gzip-os hdr))

             (set-port-position! p 0))
           (newline)
           (make-gzip-input-port p "gzip input" 'close-underlying-port))
          ((is-xz-file? p)
           (print "Detected an xz compressed tarball.")
           (make-xz-input-port p "xz input" 'close-underlying-port))
          (else
           (print "Guessing that this is an uncompressed tarball.\n")
           p))))

(unless (= (length (command-line)) 2)
  (display "Usage: tarinfo <filename>\n" (current-error-port))
  (exit 1))

(call-with-port (open-tarball (cadr (command-line)))
  (lambda (p)
    (print (pad-right "Mode" 7 #\space) " "
           (pad-right "UID" 4 #\space) "/"
           (pad-left "GID" 4 #\space) " "
           (pad-right "File size" 10 #\space) " "
           (pad-left "Modified" 24 #\space) "  "
           "Filename")
    (let lp ()
      (let ((rec (get-header-record p)))
        (unless (eof-object? rec)
          (print (pad-right (format-mode (header-mode rec)) 7 #\space) " "
                 (pad-right (header-uid rec) 4 #\space) "/"
                 (pad-left (header-gid rec) 4 #\space) " "
                 (pad-right (header-size rec) 10 #\space) " "
                 (date->string (header-mtime rec) "~1 ~2") "  "
                 (header-name rec))
          (let ((uname (header-uname rec))
                (gname (header-gname rec)))
            (unless (and (string=? gname "") (string=? uname ""))
              (print (pad-right uname 12 #\space) "/" gname)))
          (let ((t (header-typeflag rec)))
            (case t
              ((regular) 'thats-fine...)
              ((directory) (print "\tDirectory"))
              ((symlink) (print "\tSymlink to " (header-linkname rec)))
              (else (print "\tType: " t))))

          (skip-file p rec)
          (lp))))))
