(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)

(FILECREATED "26-Jun-90 19:28:14" |{DSK}<usr>local>lde>lispcore>internal>library>TAR.;2|
 3663   

      |changes| |to:|  (VARS TARCOMS)

      |previous| |date:| "31-Dec-00 17:55:22" |{DSK}<usr>local>lde>lispcore>internal>library>TAR.;1|
)


; Copyright (c) 1987, 1900, 1990 by Venue & Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT TARCOMS)

(RPAQQ TARCOMS
 ((RECORDS TARHEADER)
                    (FNS GATHER-NAME READ-TAR-FILE)))
(DECLARE\: EVAL@COMPILE

(BLOCKRECORD TARHEADER
 ((FILENAME BYTE 100)
                            (MODE BYTE 8)
                            (UID BYTE 8)
                            (GID BYTE 8)
                            (SIZE BYTE 12)
                            (MTIME BYTE 12)
                            (CHKSUM BYTE 8)
                            (LINKFLAG BYTE)
                            (LINKNAME BYTE 100)))
)
(DEFINEQ

(GATHER-NAME

  (LAMBDA (BASE OFFSET)
                                      (* \; "Edited 19-Oct-87 00:41 by jds")


    (APPLY 'CONCAT (|bind|
 CH |for|
 I |from|
 OFFSET |to|
 100 |until|
 (ZEROP CH)
                      |when|
 (NOT (ZEROP (SETQ CH (\\GETBASEBYTE BASE I))))
                      |collect|
 (COND
                                   ((IEQP CH (CHARCODE /))
                                    ">")
                                   ((IEQP CH (CHARCODE _))
                                    "-")
                                   (T (CHARACTER CH)))))))

(READ-TAR-FILE

  (LAMBDA (FILENAME START LIST-ONLY SKIP-EXISTING-FILES)
     (* \; "Edited 31-Dec-00 17:55 by jds")


    (CL:WITH-OPEN-STREAM
     (INSTREAM (OPENSTREAM FILENAME 'INPUT 'OLD '((SEQUENTIAL T)
                                                  (BUFFERS 40))))
     (LET* ((BUFFER (NCREATE 'VMEMPAGEP))
            (SIZE-STRING (CL:MAKE-ARRAY 12 :ELEMENT-TYPE 'CL:STRING-CHAR :DISPLACED-TO-BASE
                                (\\ADDBASE BUFFER 62)))
            SIZE FILENAME OLDFPTR)
          
          (* |;;| "Read the file header:")


           (SETFILEPTR INSTREAM (OR START 0))
           (|while|
 (NOT (EOFP INSTREAM))
              |do|
 (\\BINS INSTREAM BUFFER 0 512)
                   (SETQ FILENAME (GATHER-NAME
 BUFFER 2))
                   (SETQ SIZE (CL:WITH-INPUT-FROM-STRING (IN
 SIZE-STRING)
                                     (LET ((*READTABLE* (FIND-READTABLE "XCL"))
                                           (*READ-BASE* 8))
                                          (CL:READ IN))))
                   (PRINTOUT T "FILE:  " FILENAME ",  SIZE = " SIZE T)
                   (COND
                      ((AND (NOT LIST-ONLY)
                            (> SIZE 0))
                       (SETQ OLDFPTR (GETFILEPTR INSTREAM))
                       (COND
                          ((OR (NOT SKIP-EXISTING-FILES)
                               (NOT (CL:PROBE-FILE FILENAME)))
                           (CL:WITH-OPEN-STREAM (OUT (OPENSTREAM FILENAME 'OUTPUT 'NEW
                                                            `((SEQUENTIAL T)
                                                              (BUFFERS 40)
                                                              (LENGTH ,SIZE))))
                                  (COPYBYTES INSTREAM OUT SIZE))))
                       (SETFILEPTR INSTREAM (+ OLDFPTR (ITIMES 512 (IQUOTIENT (+ SIZE 511)
                                                                          512)))))))))))
)
(PUTPROPS TAR COPYRIGHT ("Venue & Xerox Corporation" 1987 1900 1990))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (944 3570 (GATHER-NAME 954 . 1560) (READ-TAR-FILE 1562 . 3568)))))
STOP