;;;;
;;;; tar.stk	-- Implementation of untar for STklos
;;;;
;;;; Copyright © 2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Manuel Serrano
;;;;    Creation date:  8-Jan-2007 11:33 (eg)
;;;; Last file update: 10-May-2007 17:03 (eg)
;;;;
;;;;
;;;;   Based on Chicken's tar implementation (Felix L. Winkelmann).

;(define-module TAR
  (export tar-header
	  tar-read-header
	  tar-read-block
	  tar-round-up-to-record-size)


(define-struct tar-header
  name mode uid gid size mtime checksum type linkname magic uname gname
  devmajor devminor)


(define-condition-type &tar-error &i/o-error
  &tar-error?)

;; ----------------------------------------------------------------------
;;    tar-error ...
;; ----------------------------------------------------------------------
(define (tar-error msg obj)
  (error msg obj))

;; ----------------------------------------------------------------------
;;    tar constants ...
;; ----------------------------------------------------------------------
(define (tar-record-size) 512)
(define (tar-name-size) 100)
(define (tar-tunmlen) 32)
(define (tar-tgnmlen) 32)
(define (tar-tmagic)   "ustar  ")
(define (tar-umagic)   "ustar")
(define (tar-gnumagic) "GNUtar ")

;; ----------------------------------------------------------------------
;;    tar-type-name ...
;; ----------------------------------------------------------------------
(define (tar-type-name c)
  (case c
    ((#\null) 'oldnormal)
    ((#\0) 'normal)
    ((#\1) 'link)
    ((#\2) 'symlink)
    ((#\3) 'chr)
    ((#\4) 'blk)
    ((#\5) 'dir)
    ((#\6) 'fifo)
    ((#\7) 'contig)
    (else  (tar-error "invalid file type" c))))

;; ----------------------------------------------------------------------
;;    str->octal ...
;; ----------------------------------------------------------------------
(define (str->octal str #!optional (err #t))
  (or (string->number str 8)
      (if err
	  (tar-error "invalid octal record item" str)
	  0)))

;; ----------------------------------------------------------------------
;;    checksum ...
;; ----------------------------------------------------------------------
(define (checksum buf)
  (let* ((p  (+ (tar-name-size) 48))
	 (b2 (string-append (substring buf 0 p)
			    "        "
			    (substring buf (+ p 8) (string-length buf)))))
    (do ((i 0 (+ 1 i))
	 (s 0 (+ s (char->integer (string-ref b2 i)))))
	((>= i (tar-record-size)) s))))

;; ----------------------------------------------------------------------
;;    tar-read-header ...
;; ----------------------------------------------------------------------
(define (tar-read-header #!optional (port (current-input-port)))
  (let* ((ptr  0)
	 (data (read-chars (tar-record-size) port))
	 (len  (string-length data)))

    (define (extract size)
      (let loop ((i 0))
	(cond
	  ((>= i size)
	   (tar-error
	    (format "no terminator for zero-terminated string found: ~a"
		    i)
	    size))
	  ((>= i len)
	   (tar-error "corrupted tar file" port))
	  (else
	   (let ((c (string-ref data (+ ptr i))))
	     (cond ((char=? #\null c)
		    (let* ((nptr (+ ptr i))
			   (sub (substring data ptr nptr)))
		      (set! ptr (+ ptr size))
		      sub))
		   (else
		    (loop (+ 1 i)))))))))

    (define (fetch)
      (let ((c (string-ref data ptr)))
	(set! ptr (+ 1 ptr))
	c))

    (let ((name (if (or (not (string? data)) (= (string-length data) 0))
		    ""
		    (extract (tar-name-size)))))
      (when (> (string-length name) 0)
	(let* ((mode     (str->octal (extract 8)))
	       (uid      (str->octal (extract 8)))
	       (gid      (str->octal (extract 8)))
	       (size     (string->number (extract 12) 8))
	       (mtime    (string->number (extract 12) 8))
	       (chksum   (str->octal (extract 8)))
	       (linkflag (fetch))
	       (linkname (extract (tar-name-size)))
	       (magic    (extract 8))
	       (uname    (extract (tar-tunmlen)))
	       (gname    (extract (tar-tgnmlen)))
	       (devmajor (str->octal (extract 8) #f))
	       (devminor (str->octal (extract 8) #f))
	       (csum2    (checksum data)))
	  (cond
	    ((not (or (string=? (tar-tmagic) magic)
		      (string=? (tar-umagic) magic)
		      (string=? (tar-gnumagic) magic)))
	     (tar-error "invalid magic number ~S"  magic))
	    ((not (= csum2 chksum))
	     (tar-error
	      (format "invalid checksum (expected: ~s)" chksum)
	      csum2))
	    (else
	     (make-struct tar-header
			  name
			  mode
			  uid
			  gid
			  size
			  (seconds->date mtime)
			  chksum
			  (tar-type-name linkflag)
			  linkname
			  magic
			  uname
			  gname
			  devmajor
			  devminor))))))))

;; ----------------------------------------------------------------------
;;    tar-round-up-to-record-size ...
;; ----------------------------------------------------------------------
(define (tar-round-up-to-record-size n)
  (* (tar-record-size)
     (/ (+ n (- (tar-record-size) 1)) (tar-record-size))))

;; ----------------------------------------------------------------------
;;    tar-read-block ...
;; ----------------------------------------------------------------------
(define (tar-read-block h #!optional (p (current-input-port)))
  (if (tar-header? h)
      (let ((n (tar-header-size h)))
	(if (= n 0)
	    #f
	    (let ((s (read-chars n p)))
	      (if (< (string-length s) n)
		  (error "illegal block ~S" (tar-header-name h))
		  (read-chars (- (tar-round-up-to-record-size n) n) p))
	      s)))
      (error "incorrect tar header ~S" h)))

(provide "tar")