Commit c6c9731c authored by Erick Gallesio's avatar Erick Gallesio

Added TAR file support

parent a992381f
;;;;
;;;; 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: 8-Jan-2007 13:19 (eg)
;;;;
;;;;
;;;; Based on Chicken's tar implementation (Felix L. Winkelmann).
;(define-module TAR-MODULE
(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")
\ No newline at end of file
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment