Commit a0430bd5 authored by Eric Timmons's avatar Eric Timmons
Browse files

Replace most instances of archive with tar-file and reindent

parent 375a9ec6
......@@ -4,10 +4,10 @@
(defvar *type-detectors* nil
"A list of functions, that when called with a header buffer must return a
symbol naming the type of archive that the header belongs to, or NIL.")
symbol naming the type of tar-file that the header belongs to, or NIL.")
(defparameter *default-type* 'v7-archive
"The default archive type if no detectors register a hit.")
(defparameter *default-type* 'v7-tar-file
"The default tar-file type if no detectors register a hit.")
(defun register-type-detector (f)
(pushnew f *type-detectors*))
......@@ -16,36 +16,36 @@
(or (some (lambda (f) (funcall f buffer)) *type-detectors*)
*default-type*))
(defclass archive ()
(defclass tar-file ()
((direction
:initarg :direction
:reader %archive-direction
:reader %tar-file-direction
:type (member :input :output))
(open-archive-p
(open-tar-file-p
:initform t
:accessor open-archive-p)
:accessor open-tar-file-p)
(stream
:initarg :stream
:reader archive-stream
:reader tar-file-stream
:type stream)
(next-entry-start
:accessor next-entry-start
:type integer
:initform 0))
(:documentation
"Base class of a tar archive."))
"Base class of a tar tar-file."))
(defgeneric header-type (archive)
(defgeneric header-type (tar-file)
(:documentation
"Given a tar-file, return a symbol naming the header class."))
(defgeneric entry-type (archive header)
(defgeneric entry-type (tar-file header)
(:documentation
"Return a symbol naming the class to use to represent the entry for HEADER in ARCHIVE."))
"Return a symbol naming the class to use to represent the entry for HEADER in TAR-FILE."))
(defun open-tar-file (type stream &key (direction :input)
(blocking-factor 20))
"Return an archive. STREAM is the underlying Lisp stream for the archive.
(blocking-factor 20))
"Return an tar-file. STREAM is the underlying Lisp stream for the tar-file.
STREAM should not be read from or written to anymore."
(declare (type (member :input :output) direction))
(let ((blocked-stream (make-instance (ecase direction
......@@ -64,90 +64,90 @@ STREAM should not be read from or written to anymore."
:stream blocked-stream
:direction direction))))
(defun close-tar-file (archive)
"Closes the stream associated with ARCHIVE and the archive itself.
Further operations on the archive are undefined."
(when (open-archive-p archive)
(close (archive-stream archive))
(setf (open-archive-p archive) nil))
(defun close-tar-file (tar-file)
"Closes the stream associated with TAR-FILE and the tar-file itself.
Further operations on the tar-file are undefined."
(when (open-tar-file-p tar-file)
(close (tar-file-stream tar-file))
(setf (open-tar-file-p tar-file) nil))
t)
(defmethod read-entry :before ((archive archive))
(unless (eq (%archive-direction archive) :input)
(error "Attempting to read from a non-input archive"))
(unless (open-archive-p archive)
(error "Attempting to read from a closed archive")))
(defmethod read-entry :before ((tar-file tar-file))
(unless (eq (%tar-file-direction tar-file) :input)
(error "Attempting to read from a non-input tar-file"))
(unless (open-tar-file-p tar-file)
(error "Attempting to read from a closed tar-file")))
(defmethod write-entry-to-archive :before ((archive archive) entry
&key stream)
(defmethod write-entry-to-tar-file :before ((tar-file tar-file) entry
&key stream)
(declare (ignore stream))
(unless (eq (%archive-direction archive) :output)
(error "Attempting to write to a non-output archive"))
(unless (open-archive-p archive)
(error "Attempting to write to a closed archive")))
(unless (eq (%tar-file-direction tar-file) :output)
(error "Attempting to write to a non-output tar-file"))
(unless (open-tar-file-p tar-file)
(error "Attempting to write to a closed tar-file")))
(defmethod write-entry-data ((archive archive) entry stream)
(defmethod write-entry-data ((tar-file tar-file) entry stream)
(cond
((typep stream 'stream)
(if (and (subtypep (stream-element-type stream) '(unsigned-byte 8))
(subtypep '(unsigned-byte 8) (stream-element-type stream)))
(transfer-stream-to-archive archive stream)
(transfer-stream-to-tar-file tar-file stream)
(error "Stream has invalid STREAM-ELEMENT-TYPE ~A"
(stream-element-type stream))))
((typep stream 'pathname)
(with-open-file (stream stream :element-type '(unsigned-byte 8))
(transfer-stream-to-archive archive stream)))
(transfer-stream-to-tar-file tar-file stream)))
((typep stream 'string)
(transfer-octets-to-archive archive (string-to-bytevec stream :utf-8)))
(transfer-octets-to-tar-file tar-file (string-to-bytevec stream :utf-8)))
((typep stream 'vector)
(transfer-octets-to-archive archive stream))
(transfer-octets-to-tar-file tar-file stream))
((eq nil stream)
;; do nothing
)
(t
(error "Invalid argument for :STREAM: ~A" stream))))
(defmethod write-entry-to-archive ((archive archive) entry
&key stream)
(with-slots ((archive-stream stream)) archive
(defmethod write-entry-to-tar-file ((tar-file tar-file) entry
&key stream)
(with-slots ((tar-file-stream stream)) tar-file
(let ((buffer (make-array +tar-n-block-bytes+ :element-type '(unsigned-byte 8))))
(declare (dynamic-extent buffer))
;; write the entry
(write-header-to-buffer entry buffer 0)
(write-sequence buffer archive-stream))
(write-sequence buffer tar-file-stream))
;; write any associated data
(write-entry-data archive entry stream)
(write-entry-data tar-file entry stream)
(values)))
;;; providing streamy access for an entry
(defun make-stream-for-entry (archive entry)
(make-bounded-stream (archive-stream archive) (size entry)))
(defun make-stream-for-entry (tar-file entry)
(make-bounded-stream (tar-file-stream tar-file) (size entry)))
(defmethod read-entry :before ((archive archive))
(unless (file-position (archive-stream archive) (next-entry-start archive))
(defmethod read-entry :before ((tar-file tar-file))
(unless (file-position (tar-file-stream tar-file) (next-entry-start tar-file))
(error 'simple-tar-file-error :format-control "Unable to set FILE-POSITION.")))
(defmethod read-entry ((archive archive))
(let ((start-position (file-position (archive-stream archive)))
(defmethod read-entry ((tar-file tar-file))
(let ((start-position (file-position (tar-file-stream tar-file)))
(buffer (make-array +tar-n-block-bytes+ :element-type '(unsigned-byte 8))))
(declare (dynamic-extent buffer))
(with-slots (stream) archive
(with-slots (stream) tar-file
(let ((nbytes (read-sequence buffer stream)))
(unless (= nbytes +tar-n-block-bytes+)
(error "Corrupt archive"))))
(error "Corrupt tar-file"))))
(if (null-block-p buffer 0)
nil
(let ((header (read-header-from-buffer (header-type archive) buffer :start 0)))
(make-instance (entry-type archive header)
:archive archive
(let ((header (read-header-from-buffer (header-type tar-file) buffer :start 0)))
(make-instance (entry-type tar-file header)
:tar-file tar-file
:header header
:start-position start-position)))))
(defmethod read-entry :around ((archive archive))
(defmethod read-entry :around ((tar-file tar-file))
(let ((entry (call-next-method)))
(unless (null entry)
(setf (next-entry-start archive)
(setf (next-entry-start tar-file)
(+ (start-position entry)
+tar-n-block-bytes+
(if (entry-has-data-p entry)
......@@ -155,27 +155,27 @@ Further operations on the archive are undefined."
0))))
entry))
(defun transfer-stream-to-archive (archive stream)
(let* ((bytes-copied (alexandria:copy-stream stream (archive-stream archive)))
(defun transfer-stream-to-tar-file (tar-file stream)
(let* ((bytes-copied (alexandria:copy-stream stream (tar-file-stream tar-file)))
(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))))
(tar-file-stream tar-file))))
(defun transfer-octets-to-archive (archive octets)
(defun transfer-octets-to-tar-file (tar-file octets)
(let* ((rounded-bytes (round-up-to-tar-block (length octets)))
(bytes-remaining (- rounded-bytes (length octets))))
(write-sequence octets (archive-stream archive))
(write-sequence octets (tar-file-stream tar-file))
(write-sequence (make-array bytes-remaining :element-type '(unsigned-byte 8)
:initial-element 0)
(archive-stream archive))))
(tar-file-stream tar-file))))
(defmethod finalize-archive ((archive archive))
(defmethod finalize-tar-file ((tar-file tar-file))
(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)))
(write-sequence null-block (tar-file-stream tar-file)))
(values)))
......@@ -11,7 +11,7 @@
(defun make-bounded-stream (stream size &optional start-position)
(make-instance 'bounded-input-stream :stream stream :bytes size
:position (or start-position (file-position stream))))
:position (or start-position (file-position stream))))
#+nil
(defmethod trivial-gray-streams:stream-element-type ((stream bounded-input stream))
......
......@@ -16,18 +16,18 @@
;; 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))
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)))))))))
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)
......
......@@ -40,77 +40,77 @@
(push size args)
(push :size args))
(let ((header (apply #'make-instance (header-type archive)
(let ((header (apply #'make-instance (header-type tar-file)
:name name
:typeflag (if (typep archive 'v7-archive)
:typeflag (if (typep tar-file 'v7-tar-file)
+tar-regular-alternate-file+
+tar-regular-file+)
(uiop:remove-plist-key :data args)))
(start-position (file-position (archive-stream archive))))
(write-entry-to-archive archive header :stream data)
(make-instance 'file-entry :header header :archive archive :start-position start-position)))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry-to-tar-file tar-file header :stream data)
(make-instance 'file-entry :header header :tar-file tar-file :start-position start-position)))
(defclass hard-link-entry (entry)
()
(:documentation
"A hard link."))
(defun write-hard-link-entry (archive name &rest args &key uname gname mode mtime uid gid linkname)
(defun write-hard-link-entry (tar-file name &rest args &key uname gname mode mtime uid gid linkname)
(declare (ignore uname gname mode mtime uid gid linkname))
(let ((header (apply #'make-instance (header-type archive)
(let ((header (apply #'make-instance (header-type tar-file)
:name name
:typeflag +tar-hard-link+
args))
(start-position (file-position (archive-stream archive))))
(write-entry-to-archive archive header)
(make-instance 'hard-link-entry :header header :archive archive :start-position start-position)))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry-to-tar-file tar-file header)
(make-instance 'hard-link-entry :header header :tar-file tar-file :start-position start-position)))
(defclass symbolic-link-entry (entry)
()
(:documentation
"A symbolic link."))
(defun write-symbolic-link-entry (archive name &rest args &key uname gname mode mtime uid gid linkname)
(defun write-symbolic-link-entry (tar-file name &rest args &key uname gname mode mtime uid gid linkname)
(declare (ignore uname gname mode mtime uid gid linkname))
(let ((header (apply #'make-instance (header-type archive)
(let ((header (apply #'make-instance (header-type tar-file)
:name name
:typeflag +tar-symbolic-link+
args))
(start-position (file-position (archive-stream archive))))
(write-entry-to-archive archive header)
(make-instance 'symbolic-link-entry :header header :archive archive :start-position start-position)))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry-to-tar-file tar-file header)
(make-instance 'symbolic-link-entry :header header :tar-file tar-file :start-position start-position)))
(defclass character-device-entry (entry)
()
(:documentation
"A character device."))
(defun write-character-device-entry (archive name &rest args &key uname gname mode mtime uid gid
devmajor devminor)
(defun write-character-device-entry (tar-file name &rest args &key uname gname mode mtime uid gid
devmajor devminor)
(declare (ignore uname gname mode mtime uid gid devmajor devminor))
(let ((header (apply #'make-instance (header-type archive)
(let ((header (apply #'make-instance (header-type tar-file)
:name name
:typeflag +tar-character-device+
args))
(start-position (file-position (archive-stream archive))))
(write-entry-to-archive archive header)
(make-instance 'character-device-entry :header header :archive archive :start-position start-position)))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry-to-tar-file tar-file header)
(make-instance 'character-device-entry :header header :tar-file tar-file :start-position start-position)))
(defclass block-device-entry (entry)
()
(:documentation
"A block device."))
(defun write-block-device-entry (archive name &rest args &key uname gname mode mtime uid gid
devmajor devminor)
(defun write-block-device-entry (tar-file name &rest args &key uname gname mode mtime uid gid
devmajor devminor)
(declare (ignore uname gname mode mtime uid gid devmajor devminor))
(let ((header (apply #'make-instance (header-type archive)
(let ((header (apply #'make-instance (header-type tar-file)
:name name
:typeflag +tar-block-device+
args))
(start-position (file-position (archive-stream archive))))
(write-entry-to-archive archive header)
(make-instance 'block-device-entry :header header :archive archive :start-position start-position)))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry-to-tar-file tar-file header)
(make-instance 'block-device-entry :header header :tar-file tar-file :start-position start-position)))
(defclass directory-entry (entry)
()
......@@ -122,15 +122,15 @@
(:documentation
"A FIFO."))
(defun write-fifo-entry (archive name &rest args &key uname gname mode mtime uid gid)
(defun write-fifo-entry (tar-file name &rest args &key uname gname mode mtime uid gid)
(declare (ignore uname gname mode mtime uid gid))
(let ((header (apply #'make-instance (header-type archive)
(let ((header (apply #'make-instance (header-type tar-file)
:name name
:typeflag +tar-fifo-device+
args))
(start-position (file-position (archive-stream archive))))
(write-entry-to-archive archive header)
(make-instance 'fifo-entry :header header :archive archive :start-position start-position)))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry-to-tar-file tar-file header)
(make-instance 'fifo-entry :header header :tar-file tar-file :start-position start-position)))
(defclass pax-attributes-entry (entry has-data-mixin)
((attributes
......@@ -257,7 +257,7 @@
(defgeneric make-entry-stream (entry))
(defmethod make-entry-stream ((entry has-data-mixin))
(make-bounded-stream (archive-stream (entry-archive entry)) (size entry)
(make-bounded-stream (tar-file-stream (entry-tar-file entry)) (size entry)
(+ (start-position entry) +tar-n-block-bytes+)))
(defmacro make-header-forwarder (name)
......
......@@ -10,8 +10,8 @@
(type :auto)
(blocking-factor 20))
(when (or (eq direction :io) (eq direction :probe))
(error "Cannot open archives in direction ~A" direction))
(let (archive
(error "Cannot open tar-files in direction ~A" direction))
(let (tar-file
stream
(should-close t)
(abort t))
......@@ -29,20 +29,20 @@
(when if-does-not-exist
(list :if-does-not-exist if-does-not-exist))))
pathname))
(setf archive (open-tar-file type stream :direction direction
:blocking-factor blocking-factor))
(setf tar-file (open-tar-file type stream :direction direction
:blocking-factor blocking-factor))
(multiple-value-prog1
(funcall thunk archive)
(funcall thunk tar-file)
(setf abort nil)))
(when archive
(when tar-file
(when (eql direction :output)
(finalize-archive archive))
(close-tar-file archive)
(setf archive nil))
(finalize-tar-file tar-file))
(close-tar-file tar-file)
(setf tar-file nil))
(when should-close
(close stream :abort abort)))))
(defmacro with-open-tar-file ((archive-var pathname
(defmacro with-open-tar-file ((tar-file-var pathname
&key (direction :input)
(if-exists nil)
(if-does-not-exist nil)
......@@ -50,8 +50,8 @@
(blocking-factor 20))
&body body)
(when (or (eq direction :io) (eq direction :probe))
(error "Cannot open archives in direction ~A" direction))
`(call-with-open-tar-file (lambda (,archive-var) ,@body)
(error "Cannot open tar-files in direction ~A" direction))
`(call-with-open-tar-file (lambda (,tar-file-var) ,@body)
,pathname
:direction ,direction
:if-exists ,if-exists
......@@ -59,13 +59,13 @@
:type ,type
:blocking-factor ,blocking-factor))
(defmacro do-entries ((entry archive &optional result)
(defmacro do-entries ((entry tar-file &optional result)
&body body)
"Iterate over the entries in ARCHIVE. For each entry, ENTRY is bound to an
"Iterate over the entries in TAR-FILE. For each entry, ENTRY is bound to an
ENTRY representing the entry. RESULT is used as in DOTIMES."
(let ((archive-var (gensym)))
`(let ((,archive-var ,archive))
(do ((,entry (read-entry ,archive-var)
(read-entry ,archive-var)))
((null ,entry) ,result)
,@body))))
(let ((tar-file-var (gensym)))
`(let ((,tar-file-var ,tar-file))
(do ((,entry (read-entry ,tar-file-var)
(read-entry ,tar-file-var)))
((null ,entry) ,result)
,@body))))
......@@ -27,31 +27,31 @@
;;; reading
(defgeneric read-entry (archive)
(:documentation "Return the next entry in ARCHIVE or NIL if there is no
(defgeneric read-entry (tar-file)
(:documentation "Return the next entry in TAR-FILE or NIL if there is no
next entry"))
;;; writing
(defgeneric write-entry-to-archive (archive entry
&key stream)
(:documentation "Write ENTRY to ARCHIVE. gData associated with ENTRY
is written to ARCHIVE according to the :STREAM argument. If :STREAM is
(defgeneric write-entry-to-tar-file (tar-file entry
&key stream)
(:documentation "Write ENTRY to TAR-FILE. gData associated with ENTRY
is written to TAR-FILE according to the :STREAM argument. If :STREAM is
T, the expression (NAME ENTRY) is expected to refer to an existing file
from which data may be read. If :STREAM is a stream, then data is read
from that stream and written to ARCHIVE. If :STREAM is NIL, then no
from that stream and written to TAR-FILE. If :STREAM is NIL, then no
entry data is written."))
(defgeneric write-header-to-buffer (header buffer &optional start)
(:documentation "Write the information associated with HEADER into BUFFER,
beginning at position START."))
(defgeneric write-entry-data (archive entry stream)
(defgeneric write-entry-data (tar-file entry stream)
(:documentation "Write any data associated with ENTRY, possibly found
in STREAM to ARCHIVE; called after WRITE-HEADER-TO-BUFFER. STREAM is
interpreted as in WRITE-ENTRY-TO-ARCHIVE."))
in STREAM to TAR-FILE; called after WRITE-HEADER-TO-BUFFER. STREAM is
interpreted as in WRITE-ENTRY-TO-TAR-FILE."))
(defgeneric finalize-archive (archive)
(:documentation "Perform any necessary processing for finalizing ARCHIVE.
(defgeneric finalize-tar-file (tar-file)
(:documentation "Perform any necessary processing for finalizing TAR-FILE.
This function must be called prior to calling CLOSE-TAR-FILE."))
;;;; gnu.lisp -- header format for GNU archives
;;;; gnu.lisp -- header format for GNU tar-files
;;;;
;;;; This is part of tar-file. See README.org and LICENSE for more information.
......@@ -7,14 +7,14 @@
(defparameter *gnu-magic-vector*
(coerce `(,@(map 'list #'char-code "ustar "))
'(vector (unsigned-byte 8)))
"The contents of the magic field for gnu archives.")
"The contents of the magic field for gnu tar-files.")
(defparameter *gnu-version-vector*
(coerce `(,@(map 'list #'char-code " ") 0) '(vector (unsigned-byte 8)))
"The contents of the version field for gnu archives.")
"The contents of the version field for gnu tar-files.")
(define-octet-header gnu-header
(name 100 :string-null)
(name 100 :string-null)
(mode 8 :octnum)
(uid 8 :octnum)
(gid 8 :octnum)
......@@ -46,21 +46,21 @@
(realsize 12 :octnum)
(%%padding 17 :string))
(defclass gnu-archive (archive) ())
(defclass gnu-tar-file (tar-file) ())
(defmethod header-type ((archive gnu-archive))
(defmethod header-type ((tar-file gnu-tar-file))
'gnu-header)
(defun detect-gnu-archive (buffer)
(defun detect-gnu-tar-file (buffer)
(let ((offset (field-offset 'gnu-header 'magic))
(length (field-length 'gnu-header 'magic)))
(when (equalp *gnu-magic-vector*
(subseq buffer offset (+ offset length)))
'gnu-archive)))
'gnu-tar-file)))
(register-type-detector 'detect-gnu-archive)
(register-type-detector 'detect-gnu-tar-file)
(defmethod entry-type ((archive gnu-archive) header)
(defmethod entry-type ((tar-file gnu-tar-file) header)
(alexandria:switch ((typeflag header))
(+tar-regular-file+
'file-entry)
......
......@@ -13,8 +13,8 @@
&body body)
`(let ,(mapcar #'(lambda (field-name)
`(,field-name (,(extractor-function-name entry-class field-name) ,buffer ,offset)))
fields)
,@body))
fields)
,@body))
(defgeneric field-offset (header field-name))
......@@ -36,47 +36,47 @@
collect `(defmethod field-length ((header (eql ',class-name)) (field-name (eql ',name)))
,length) into length-defs
collect `(defun ,(extractor-function-name class-name name) (buffer entry-start)
(declare (type (simple-array (unsigned-byte 8) (*)) buffer))
,(ecase kind
(:string
`(bytevec-to-string
(read-bytevec-from-buffer buffer :start (+ entry-start ,offset)
:end (+ entry-start ,offset ,length) :nullp nil)))
(:string-null
`(bytevec-to-string
(read-bytevec-from-buffer buffer :start (+ entry-start ,offset)