Commit 40eadca1 authored by Eric Timmons's avatar Eric Timmons
Browse files

Get rid of tar.lisp

Now that this library is focused exclusively on tar files, no need to
distinguish between archives and tar archives
parent 547bbf0b
......@@ -15,17 +15,18 @@
(uiop:symbol-call :parachute :test :tar-test)))
(error "Tests failed")))
:components ((:file "package")
(:file "conditions" :depends-on ("package"))
(:file "conditions" :depends-on ("package" "constants"))
(:file "constants" :depends-on ("package"))
(:file "buffer-ops" :depends-on ("package" "constants"))
(:file "utils" :depends-on ("package"))
(:file "generics" :depends-on ("package"))
(:file "blocked-stream" :depends-on ("package"))
(:file "macros" :depends-on ("generics"))
(:file "external-macros" :depends-on ("generics"))
(:file "ustar" :depends-on ("macros"))
(:file "ustar" :depends-on ("package" "macros" "archive"))
(:file "entry" :depends-on ("package"))
(:file "bounded-stream" :depends-on ("package"))
(:file "archive" :depends-on ("generics" "bounded-stream" "macros" "external-macros" "entry" "constants"))
(:file "tar" :depends-on ("conditions" "generics" "archive" "entry" "constants"))))
(:file "archive" :depends-on ("generics" "bounded-stream" "macros" "external-macros" "entry" "constants"))))
(defmethod asdf:perform :around ((o asdf:compile-op)
(c (eql (asdf:find-system "cl-tar"))))
......
;;;; archive.lisp -- common handling for archive files
;;;; archive.lisp
(in-package #:tar)
(defparameter *default-header-encoding* :latin-1)
(defun bytevec-to-string (bytevec &optional encoding)
(babel:octets-to-string bytevec :encoding (or encoding *default-header-encoding*)))
(defun string-to-bytevec (string &optional encoding)
(babel:string-to-octets string :encoding (or encoding *default-header-encoding*)))
(defclass archive ()
((entry-buffer :initarg :entry-buffer :reader entry-buffer
:type (simple-array (unsigned-byte 8) (*)))
(direction :initarg :direction :reader %archive-direction)
(open-archive-p :initform t :accessor open-archive-p)
(stream :reader archive-stream :type stream)
(next-entry-start :accessor next-entry-start :type integer :initform 0)))
((entry-buffer
:initarg :entry-buffer
:initform (make-array +tar-n-block-bytes+ :element-type '(unsigned-byte 8))
:reader entry-buffer
:type (simple-array (unsigned-byte 8) (#.+tar-n-block-bytes+)))
(direction
:initarg :direction
:reader %archive-direction)
(open-archive-p
:initform t
:accessor open-archive-p)
(stream
:reader archive-stream
:type stream)
(next-entry-start
:accessor next-entry-start
:type integer
:initform 0))
(:documentation
"Representation of a tar archive."))
(defgeneric archive-header-type (archive))
(defmethod initialize-instance :after ((instance archive)
&key stream direction
(blocking-factor 20))
(initialize-entry-buffer instance (header-length (archive-header-type instance)))
(setf (slot-value instance 'stream)
(make-instance (ecase direction
(:input 'blocked-input-stream)
......@@ -30,11 +36,6 @@
:stream stream
:block-size (* +tar-n-block-bytes+ blocking-factor))))
(defun initialize-entry-buffer (archive buffer-length)
"Initialize the ENTRY-BUFFER of ARCHIVE."
(setf (slot-value archive 'entry-buffer)
(make-array buffer-length :element-type '(unsigned-byte 8))))
(defun open-archive (archive-type stream &key (direction :input))
"Return an archive. STREAM is the underlying Lisp stream for the archive.
STREAM should not be read from or written to anymore."
......@@ -109,13 +110,66 @@ requirements about alignment."
(defun make-stream-for-entry (archive entry)
(make-bounded-stream (archive-stream archive) (size entry)))
(defmethod read-entry-from-archive :around (archive)
(defmethod read-entry-from-archive :before ((archive archive))
(unless (file-position (archive-stream archive) (next-entry-start archive))
(error 'simple-archive-error :format-control "Unable to set FILE-POSITION.")))
(defmethod read-entry-from-archive ((archive archive))
(let ((start-position (file-position (archive-stream archive)))
(entry-block (read-entry-block archive)))
(if (null-block-p entry-block 0)
nil
(let ((header (read-header-from-buffer (archive-header-type archive) entry-block :start 0)))
(make-instance (cond
((entry-regular-file-p header)
'file-entry)
(t
'entry))
:archive archive
:header header
:start-position start-position)))))
(defmethod read-entry-from-archive :around ((archive archive))
(let ((entry (call-next-method)))
;; (when entry
;; (setf (slot-value entry 'stream)
;; (make-stream-for-entry archive entry)))
(unless (null entry)
(setf (next-entry-start archive)
(+ (start-position entry)
+tar-n-block-bytes+
(if (or (entry-directory-p entry)
(entry-hard-link-p entry)
(entry-symbolic-link-p entry)
(entry-character-device-p entry)
(entry-block-device-p entry)
(entry-fifo-p entry))
+tar-n-block-bytes+
(round-up-to-tar-block (size entry))))))
entry))
(defun entry-stream (entry)
"Return a stream connected to the data of ENTRY."
(slot-value entry 'stream))
(defun transfer-stream-to-archive (archive stream)
(let* ((bytes-copied (alexandria:copy-stream stream (archive-stream archive)))
(rounded-bytes (round-up-to-tar-block bytes-copied))
(bytes-remaining (- rounded-bytes bytes-copied)))
(write-sequence (make-array bytes-remaining :element-type '(unsigned-byte 8)
:initial-element 0)
(archive-stream archive))))
(defmethod write-entry-to-archive :before ((archive archive)
(entry entry)
&key stream)
(declare (ignore stream))
(unless (member (typeflag entry) (list +tar-regular-file+
+tar-hard-link+
+tar-symbolic-link+
+tar-directory-file+
+gnutar-long-name+)
:test #'=)
(error 'unhandled-write-entry-error :typeflag (typeflag entry))))
(defmethod finalize-archive ((archive archive))
(let ((null-block (make-array +tar-n-block-bytes+
:element-type '(unsigned-byte 8)
:initial-element 0)))
(declare (dynamic-extent null-block))
(dotimes (i 2)
(write-sequence null-block (archive-stream archive)))
(values)))
;;;; buffer-ops.lisp
(in-package #:tar)
(defun read-number-from-buffer (buffer &key (start 0) end (radix 10))
(declare (type (simple-array (unsigned-byte 8) (*)) buffer))
(declare (type (integer 2 36) radix))
(let ((end (or (position-if #'(lambda (b)
;; For BSD tar, a number can end with
;; a space or a null byte.
(or (= b +ascii-space+) (zerop b)))
buffer :start start :end end)
end
(length buffer))))
;; GNU tar permits storing numbers as binary; a binary number is
;; indicated by starting the field with #x80.
(if (= (aref buffer start) #x80)
(loop for i from (1- end) downto (1+ start)
for base = 1 then (* base 256)
sum (* (aref buffer i) base))
(loop for i from (1- end) downto start
for base = 1 then (* base radix)
sum (let ((byte (aref buffer i)))
(cond
((<= +ascii-zero+ byte +ascii-nine+)
(* base (- byte +ascii-zero+)))
((<= +ascii-a+ byte +ascii-z+)
(* base (+ 10 (- byte +ascii-a+))))
(t (error "Invalid byte: ~A in ~A"
byte (subseq buffer start end)))))))))
(defun write-number-to-buffer (number buffer
&key (start 0) end (radix 10) nullp)
(declare (type (simple-array (unsigned-byte 8) (*)) buffer))
(declare (type (integer 2 36) radix))
(let ((end (let ((dend (or end (length buffer))))
(if nullp
(1- dend)
dend))))
(loop for i from (1- end) downto start
do (multiple-value-bind (quo rem) (truncate number radix)
(setf number quo)
(setf (aref buffer i)
(cond
((<= 0 rem 9) (+ rem +ascii-zero+))
((<= 10 rem 36) (+ (- rem 10) +ascii-a+))
(t (error "Don't know how to encode ~A" rem))))))
(values)))
(defun read-bytevec-from-buffer (buffer &key (start 0) end nullp)
(let ((end (if nullp
(position 0 buffer :start start :end end)
end)))
(subseq buffer start end)))
(in-package #:tar)
(defparameter *default-header-encoding* :latin-1)
(defun bytevec-to-string (bytevec &optional encoding)
(babel:octets-to-string bytevec :encoding (or encoding *default-header-encoding*)))
(defun string-to-bytevec (string &optional encoding)
(babel:string-to-octets string :encoding (or encoding *default-header-encoding*)))
......@@ -2,6 +2,41 @@
(in-package #:tar)
(define-condition archive-error (simple-error)
(define-condition archive-error (error)
()
(:documentation "All errors signaled by ARCHIVE are of this type."))
(:documentation "All errors signaled are of this type."))
(define-condition simple-archive-error (archive-error simple-error)
())
(define-condition invalid-checksum-error (archive-error)
((provided :initarg :provided :reader provided)
(computed :initarg :computed :reader computed))
(:report (lambda (condition stream)
(format stream "Invalid tar header checksum ~D (wanted ~D)"
(provided condition) (computed condition))))
(:documentation "Signaled when the checksum in a tar header is invalid."))
(define-condition unhandled-error (archive-error)
((typeflag :initarg :typeflag :reader typeflag))
(:documentation "Signaled when a tar entry that ARCHIVE doesn't understand is encountered."))
(define-condition unhandled-read-header-error (archive-error)
()
(:report (lambda (condition stream)
(let ((flag (typeflag condition)))
(cond
((= flag +posix-global-header+)
(format stream "Don't understand POSIX extended header entry"))
((= flag +gnutar-sparse+)
(format stream "Don't understand GNU tar sparse entry"))
(t
(format stream "Can't understand typeflag: ~A" flag))))))
(:documentation "Signaled when attempting to parse an unsupported tar entry."))
(define-condition unhandled-write-entry-error (archive-error)
()
(:report (lambda (condition stream)
(format stream "Don't know how to write a type ~A tar entry yet"
(typeflag condition))))
(:documentation "Signaled when attempting to write an unsupported tar entry."))
......@@ -46,3 +46,28 @@
(make-header-forwarder devmajor)
(make-header-forwarder devminor)
(make-header-forwarder prefix)
(defmethod print-object ((entry entry) stream)
(print-unreadable-object (entry stream)
(format stream "Entry ~A" (name entry))))
(defmethod entry-regular-file-p (entry)
(eql (typeflag entry) +tar-regular-file+))
(defmethod entry-directory-p (entry)
(eql (typeflag entry) +tar-directory-file+))
(defmethod entry-hard-link-p (entry)
(eql (typeflag entry) +tar-hard-link+))
(defmethod entry-symbolic-link-p (entry)
(eql (typeflag entry) +tar-symbolic-link+))
(defmethod entry-character-device-p (entry)
(eql (typeflag entry) +tar-character-device+))
(defmethod entry-block-device-p (entry)
(eql (typeflag entry) +tar-block-device+))
(defmethod entry-fifo-p (entry)
(eql (typeflag entry) +tar-fifo-device+))
......@@ -122,7 +122,7 @@
(multiple-value-bind (validp computed)
(tar-block-checksum-matches-p header buffer checksum start)
(unless validp
(error 'invalid-tar-checksum-error
(error 'invalid-checksum-error
:provided checksum :computed computed))
(make-instance header
,@(loop
......
......@@ -8,8 +8,8 @@
;; conditions
#:archive-error
#:tar-error
#:invalid-tar-checksum-error #:unhandled-error
#:archive-error
#:invalid-checksum-error #:unhandled-error
#:unhandled-read-header-error
#:unhandled-write-entry-error
......
;;;; tar.lisp -- reading and writing tar files from Common Lisp
;;; Yes, perfectly good implementations of tar already exist. However,
;;; there are none for Common Lisp. :) Actually, the main motivation
;;; behind writing this was to eventually provide a TAR-OP or something
;;; similar for ASDF. This would make packaging up systems very easy.
;;; Furthermore, something like asdf-install could use this package as
;;; part of its installation routines.
;;;
;;; Implementation notes:
;;;
;;; Tar archives make ugly conflations between characters and bytes, as is
;;; typical of C programs. This implementation uses the Babel system to
;;; convert back and forth between bytes and characters only in the header
;;; entries (e.g. user and group names). The variable *DEFAULT-HEADER-ENCODING*
;;; specifies the default encoding. The contents of files stored in the tar
;;; archive are provided to the user via binary streams.
;;;
;;; Bugs almost certainly remain. Regular files are the only archivable
;;; entities at the moment; attempting to back up your /dev directory
;;; with the tools contained herein will be a futile exercise.
;;;
;;; The implementation only handles ustar archives (POSIX circa 1988 or
;;; so) and does not handle pax archives (POSIX circa 2001 or so). This
;;; is a shortcoming that I would like to see fixed, but have not yet
;;; examined what would be necessary to do so. Archive buffer handling
;;; would likely need to be altered somewhat, as the current version is
;;; biased towards handling tar files (fixed records of 512 bytes).
(in-package #:tar)
(defparameter *tar-magic-vector*
(coerce `(,@(map 'list #'char-code "ustar") 0)
'(vector (unsigned-byte 8))))
(defparameter *tar-version-vector*
(coerce (map 'list #'char-code "00") '(vector (unsigned-byte 8))))
(defclass ustar-archive (archive) ())
(defmethod archive-header-type ((archive ustar-archive))
'ustar-header)
;;; Conditions
(define-condition tar-error (archive-error)
()
(:documentation "All errors specific to tar archives are of this type."))
(define-condition simple-tar-error (tar-error simple-error)
())
(define-condition invalid-tar-checksum-error (tar-error)
((provided :initarg :provided :reader provided)
(computed :initarg :computed :reader computed))
(:report (lambda (condition stream)
(format stream "Invalid tar header checksum ~D (wanted ~D)"
(provided condition) (computed condition))))
(:documentation "Signaled when the checksum in a tar header is invalid."))
(define-condition unhandled-error (tar-error)
((typeflag :initarg :typeflag :reader typeflag))
(:documentation "Signaled when a tar entry that ARCHIVE doesn't understand is encountered."))
(define-condition unhandled-read-header-error (tar-error)
()
(:report (lambda (condition stream)
(let ((flag (typeflag condition)))
(cond
((= flag +posix-global-header+)
(format stream "Don't understand POSIX extended header entry"))
((= flag +gnutar-sparse+)
(format stream "Don't understand GNU tar sparse entry"))
(t
(format stream "Can't understand typeflag: ~A" flag))))))
(:documentation "Signaled when attempting to parse an unsupported tar entry."))
(define-condition unhandled-write-entry-error (tar-error)
()
(:report (lambda (condition stream)
(format stream "Don't know how to write a type ~A tar entry yet"
(typeflag condition))))
(:documentation "Signaled when attempting to write an unsupported tar entry."))
;;; Groveling through tar headers
(defun read-number-from-buffer (buffer &key (start 0) end (radix 10))
(declare (type (simple-array (unsigned-byte 8) (*)) buffer))
(declare (type (integer 2 36) radix))
(let ((end (or (position-if #'(lambda (b)
;; For BSD tar, a number can end with
;; a space or a null byte.
(or (= b +ascii-space+) (zerop b)))
buffer :start start :end end)
end
(length buffer))))
;; GNU tar permits storing numbers as binary; a binary number is
;; indicated by starting the field with #x80.
(if (= (aref buffer start) #x80)
(loop for i from (1- end) downto (1+ start)
for base = 1 then (* base 256)
sum (* (aref buffer i) base))
(loop for i from (1- end) downto start
for base = 1 then (* base radix)
sum (let ((byte (aref buffer i)))
(cond
((<= +ascii-zero+ byte +ascii-nine+)
(* base (- byte +ascii-zero+)))
((<= +ascii-a+ byte +ascii-z+)
(* base (+ 10 (- byte +ascii-a+))))
(t (error "Invalid byte: ~A in ~A"
byte (subseq buffer start end)))))))))
(defun write-number-to-buffer (number buffer
&key (start 0) end (radix 10) nullp)
(declare (type (simple-array (unsigned-byte 8) (*)) buffer))
(declare (type (integer 2 36) radix))
(let ((end (let ((dend (or end (length buffer))))
(if nullp
(1- dend)
dend))))
(loop for i from (1- end) downto start
do (multiple-value-bind (quo rem) (truncate number radix)
(setf number quo)
(setf (aref buffer i)
(cond
((<= 0 rem 9) (+ rem +ascii-zero+))
((<= 10 rem 36) (+ (- rem 10) +ascii-a+))
(t (error "Don't know how to encode ~A" rem))))))
(values)))
(defun read-bytevec-from-buffer (buffer &key (start 0) end nullp)
(let ((end (if nullp
(position 0 buffer :start start :end end)
end)))
(subseq buffer start end)))
(defmethod print-object ((entry entry) stream)
(print-unreadable-object (entry stream)
(format stream "Entry ~A" (name entry))))
(defmethod entry-regular-file-p (entry)
(eql (typeflag entry) +tar-regular-file+))
(defmethod entry-directory-p (entry)
(eql (typeflag entry) +tar-directory-file+))
(defmethod entry-hard-link-p (entry)
(eql (typeflag entry) +tar-hard-link+))
(defmethod entry-symbolic-link-p (entry)
(eql (typeflag entry) +tar-symbolic-link+))
(defmethod entry-character-device-p (entry)
(eql (typeflag entry) +tar-character-device+))
(defmethod entry-block-device-p (entry)
(eql (typeflag entry) +tar-block-device+))
(defmethod entry-fifo-p (entry)
(eql (typeflag entry) +tar-fifo-device+))
;;; archives
;;; internal functions of all kinds
(defun round-up-to-tar-block (num)
(* (ceiling num +tar-n-block-bytes+) +tar-n-block-bytes+))
(defun tar-checksum-guts (header-type block start transform-fun)
(declare (type (simple-array (unsigned-byte 8) (*)) block))
(let* ((end (+ start +tar-n-block-bytes+))
(checksum-offset (field-offset header-type 'checksum))
(checksum-start (+ start checksum-offset))
(checksum-end (+ start checksum-offset
(field-length header-type 'checksum))))
(loop for i from start below end
sum (if (or (< i checksum-start) (<= checksum-end i))
(funcall transform-fun (aref block i))
+ascii-space+))))
(defun compute-checksum-for-tar-header (header-type block start)
(tar-checksum-guts header-type block start #'identity))
(defun compute-old-checksum-for-tar-header (header-type block start)
(tar-checksum-guts header-type block start #'(lambda (b) (if (< b 128) b (- b 256)))))
(defun tar-block-checksum-matches-p (header-type block checksum start)
(let ((sum (compute-checksum-for-tar-header header-type block start)))
(if (= sum checksum)
t
;; try the older, signed arithmetic way
(let ((signed-sum (compute-old-checksum-for-tar-header header-type block start)))
(values (= signed-sum checksum) sum)))))
(defun null-block-p (block start)
(declare (type (simple-array (unsigned-byte 8) (*)) block))
(null (position-if-not #'zerop block
:start start :end (+ start +tar-n-block-bytes+))))
;; (defmethod write-entry-data ((archive tar-archive)
;; (entry tar-longname-entry) stream)
;; (declare (ignore stream))
;; ;; This way is slow and inefficient, but obviously correct. It is
;; ;; also easy to guarantee that we're writing in 512-byte blocks.
;; (let* ((namestring (namestring (entry-pathname entry)))
;; (bytename (string-to-bytevec namestring))
;; (entry-length (round-up-to-tar-block (1+ (length bytename))))
;; (entry-buffer (make-array entry-length
;; :element-type '(unsigned-byte 8)
;; :initial-element 0)))
;; (replace entry-buffer bytename)
;; (write-sequence entry-buffer (archive-stream archive))
;; (values)))
;;; buffering data from the archive's stream
;;;
;;; we want to do a couple of different things with buffered data:
;;;
;;; * read entries from the buffered data--requires a specific amount
;;; of data at read time. the data required for this operation is
;;; discarded immediately after use.
;;; * read variable-sized data from the buffered data or stream--
;;; requires a specific amount of data at read time. this data must
;;; persist after reading it from the buffer--displaced arrays could
;;; not be used for this purpose.
;;; * transfer data from the archive's stream/data to another stream
;;; (i.e. processing entry data).
(defmethod read-entry-from-archive :before ((archive ustar-archive))
(unless (file-position (archive-stream archive) (next-entry-start archive))
(error 'simple-tar-error :format-control "Unable to set FILE-POSITION.")))
(defmethod read-entry-from-archive ((archive ustar-archive))
(let ((start-position (file-position (archive-stream archive)))
(entry-block (read-entry-block archive)))
(if (null-block-p entry-block 0)
nil
(let ((header (read-header-from-buffer (archive-header-type archive) entry-block :start 0)))
(make-instance (cond
((entry-regular-file-p header)
'file-entry)
(t
'entry))
:archive archive
:header header
:start-position start-position)))))
(defmethod read-entry-from-archive :around ((archive ustar-archive))
(let ((entry (call-next-method)))
(unless (null entry)
(setf (next-entry-start archive)
(+ (start-position entry)
+tar-n-block-bytes+
(if (or (entry-directory-p entry)
(entry-hard-link-p entry)
(entry-symbolic-link-p entry)
(entry-character-device-p entry)
(entry-block-device-p entry)
(entry-fifo-p entry))
+tar-n-block-bytes+
(round-up-to-tar-block (size entry))))))
entry))
(defun transfer-stream-to-archive (archive stream)
(let* ((bytes-copied (alexandria:copy-stream stream (archive-stream archive)))
(rounded-bytes (round-up-to-tar-block bytes-copied))
(bytes-remaining (- rounded-bytes bytes-copied)))
(write-sequence (make-array bytes-remaining :element-type '(unsigned-byte 8)
:initial-element 0)
(archive-stream archive))))
;;; writing entries in various guises
(defmethod write-entry-to-archive :before ((archive ustar-archive)
(entry entry)
&key stream)
(declare (ignore stream))
(unless (member (typeflag entry) (list +tar-regular-file+
+tar-hard-link+
+tar-symbolic-link+
+tar-directory-file+
+gnutar-long-name+)
:test #'=)
(error 'unhandled-write-entry-error :typeflag (typeflag entry))))
(defmethod finalize-archive ((archive ustar-archive))