Commit 450d0f1b authored by Eric Timmons's avatar Eric Timmons
Browse files

Start working on documentation

parent a0430bd5
#+TITLE: Tar File
This project provides functionality to read and write a variety of tar archive
formats. Currently supported are the POSIX ustar, PAX (ustar with a few new
entry types), GNU, and v7 (very old) formats.
......@@ -16,26 +14,25 @@ owners, etc.) and properly separate concerns. Another system will be written
that does the non portable bits and other systems can use tar-file directly if
they have a need to perform low level operations on tar archives.
This project is a fork of [[https://github.com/froydnj/archive][Nathan Froyd's archive library]]. Much code remains,
but the non-portable bits have been stripped, better support for multiple
archive types (and autodetection) has been added, better blocking support added
(tar readers/writers are supposed to read/write in multiples of 512 bytes),
cpio support removed, and a test suite added, along with other miscellaneous
fixes and improvements.
This project is a fork
of [Nathan Froyd's archive library](https://github.com/froydnj/archive). Much
code remains, but the non-portable bits have been stripped, better support for
multiple archive types (and autodetection) has been added, better blocking
support added (tar readers/writers are supposed to read/write in multiples of
512 bytes), cpio support removed, and a test suite added, along with other
miscellaneous fixes and improvements.
One major user visible difference between this library and the original archive
is that there is no need to discard entries when you are finished with them and
support has been added for seeking within a stream (using =FILE-POSITION= under
support has been added for seeking within a stream (using `FILE-POSITION` under
the hood). This means you can do something like iterate over all entries in one
go and then get a stream containing the contents of an arbitrary entry.
However, care must be taken if you hop around in a tar file as it will only
work if the underlying stream containing the tar archive is
seekable. Typically, streams backed by files *are* seekable, but all other
input streams (including stdin) *are not*. Therefore if there is any chance
your code that uses =tar-file= will read files from non-seekable streams, you
seekable. Typically, streams backed by files **are** seekable, but all other
input streams (including stdin) **are not**. Therefore if there is any chance
your code that uses `tar-file` will read files from non-seekable streams, you
should process entries sequentially and completely before moving on to the next
one. Alternatively, you can set the blocking factor high enough that the entire
file is read into memory at once (yikes!).
* Opening a tar file
;;;; This is part of tar-file. See README.org and LICENSE for more information.
(in-package #:tar-file)
(defvar *type-detectors* nil
"A list of functions, that when called with a header buffer must return a
symbol naming the type of tar-file that the header belongs to, or NIL.")
(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*))
(defun detect-type (buffer)
(or (some (lambda (f) (funcall f buffer)) *type-detectors*)
*default-type*))
(defclass tar-file ()
((direction
:initarg :direction
:reader %tar-file-direction
:type (member :input :output))
(open-tar-file-p
:initform t
:accessor open-tar-file-p)
(stream
:initarg :stream
:reader tar-file-stream
:type stream)
(next-entry-start
:accessor next-entry-start
:type integer
:initform 0))
(:documentation
"Base class of a tar tar-file."))
(defgeneric header-type (tar-file)
(:documentation
"Given a tar-file, return a symbol naming the header class."))
(defgeneric entry-type (tar-file header)
(:documentation
"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 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
(:input 'blocked-input-stream)
(:output 'blocked-output-stream))
:stream stream
:block-size (* +tar-n-block-bytes+ blocking-factor))))
(flet ((read-buffer ()
(let ((buffer (make-array +tar-n-block-bytes+ :initial-element 0
:element-type '(unsigned-byte 8))))
(assert (= +tar-n-block-bytes+ (read-sequence buffer blocked-stream)))
buffer)))
(make-instance (if (eql type :auto)
(detect-type (read-buffer))
type)
:stream blocked-stream
:direction direction))))
(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 ((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-tar-file :before ((tar-file tar-file) entry
&key stream)
(declare (ignore stream))
(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 ((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-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-tar-file tar-file stream)))
((typep stream 'string)
(transfer-octets-to-tar-file tar-file (string-to-bytevec stream :utf-8)))
((typep stream 'vector)
(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-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 tar-file-stream))
;; write any associated data
(write-entry-data tar-file entry stream)
(values)))
;;; providing streamy access for an entry
(defun make-stream-for-entry (tar-file entry)
(make-bounded-stream (tar-file-stream tar-file) (size entry)))
(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 ((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) tar-file
(let ((nbytes (read-sequence buffer stream)))
(unless (= nbytes +tar-n-block-bytes+)
(error "Corrupt tar-file"))))
(if (null-block-p buffer 0)
nil
(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 ((tar-file tar-file))
(let ((entry (call-next-method)))
(unless (null entry)
(setf (next-entry-start tar-file)
(+ (start-position entry)
+tar-n-block-bytes+
(if (entry-has-data-p entry)
(round-up-to-tar-block (size entry))
0))))
entry))
(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)
(tar-file-stream tar-file))))
(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 (tar-file-stream tar-file))
(write-sequence (make-array bytes-remaining :element-type '(unsigned-byte 8)
:initial-element 0)
(tar-file-stream tar-file))))
(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 (tar-file-stream tar-file)))
(values)))
......@@ -25,7 +25,7 @@
(:documentation
"A regular file."))
(defun write-file-entry (tar-file name &rest args &key uname gname mode mtime uid gid size data)
(defmethod write-file-entry (tar-file name &rest args &key uname gname mode mtime uid gid size data)
(declare (ignore uname gname mode mtime uid gid))
;; Compute the size when necessary.
(when (null size)
......@@ -55,7 +55,7 @@
(:documentation
"A hard link."))
(defun write-hard-link-entry (tar-file name &rest args &key uname gname mode mtime uid gid linkname)
(defmethod 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 tar-file)
:name name
......@@ -70,7 +70,7 @@
(:documentation
"A symbolic link."))
(defun write-symbolic-link-entry (tar-file name &rest args &key uname gname mode mtime uid gid linkname)
(defmethod 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 tar-file)
:name name
......@@ -85,8 +85,8 @@
(:documentation
"A character device."))
(defun write-character-device-entry (tar-file name &rest args &key uname gname mode mtime uid gid
devmajor devminor)
(defmethod 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 tar-file)
:name name
......@@ -101,8 +101,8 @@
(:documentation
"A block device."))
(defun write-block-device-entry (tar-file name &rest args &key uname gname mode mtime uid gid
devmajor devminor)
(defmethod 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 tar-file)
:name name
......@@ -117,12 +117,22 @@
(:documentation
"A directory."))
(defmethod write-directory-entry (tar-file name &rest args &key uname gname mode mtime uid gid size)
(declare (ignore uname gname mode mtime uid gid size))
(let ((header (apply #'make-instance (header-type tar-file)
:name name
:typeflag +tar-directory-file+
args))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry-to-tar-file tar-file header)
(make-instance 'directory-entry :header header :tar-file tar-file :start-position start-position)))
(defclass fifo-entry (entry)
()
(:documentation
"A FIFO."))
(defun write-fifo-entry (tar-file name &rest args &key uname gname mode mtime uid gid)
(defmethod 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 tar-file)
:name name
......@@ -166,7 +176,8 @@
:collect byte)))
(if (eql bytes :eof)
:eof
(values (parse-integer (bytevec-to-string (coerce bytes '(vector (unsigned-byte 8)))))
(values (parse-integer (bytevec-to-string (coerce bytes '(vector (unsigned-byte 8)))
:utf-8))
bytes-read))))
(defun read-attribute (stream)
......@@ -181,7 +192,7 @@
(setf num-read (read-sequence buffer stream))
(unless (= num-read (- num-bytes bytes-read))
(error 'malformed-pax-attribute-entry))
(setf kv-string (bytevec-to-string buffer))
(setf kv-string (bytevec-to-string buffer :utf-8))
(unless (= (aref buffer (1- num-read)) +ascii-newline+)
(error 'malformed-pax-attribute-entry))
(setf =-position (position #\= kv-string))
......@@ -209,14 +220,43 @@
(:documentation
"Extended attributes for the subsequent record."))
(defmethod write-pax-extended-attributes-entry (tar-file name &rest args)
;; (let ((header (apply #'make-instance (header-type tar-file)
;; :name name
;; :typeflag +tar-directory-file+
;; args))
;; (start-position (file-position (tar-file-stream tar-file))))
;; (write-entry-to-tar-file tar-file header)
;; (make-instance 'directory-entry :header header :tar-file tar-file :start-position start-position))
)
(defmethod entry-pax-extended-attributes-p ((entry pax-extended-attributes-entry))
t)
(defclass pax-global-attributes-entry (pax-attributes-entry)
()
(:documentation
"Extended attributes for all subsequent records."))
(defmethod write-pax-global-attributes-entry (tar-file name &rest args)
;; (let ((header (apply #'make-instance (header-type tar-file)
;; :name name
;; :typeflag +tar-directory-file+
;; args))
;; (start-position (file-position (tar-file-stream tar-file))))
;; (write-entry-to-tar-file tar-file header)
;; (make-instance 'directory-entry :header header :tar-file tar-file :start-position start-position))
)
(defmethod entry-pax-global-attributes-p ((entry pax-global-attributes-entry))
t)
(defclass gnu-directory-dump-entry (entry has-data-mixin)
())
(defmethod entry-gnu-directory-dump-p ((entry gnu-directory-dump-entry))
t)
(defclass gnu-long-link-name-entry (entry has-data-mixin)
((long-link-name
:accessor long-link-name)))
......@@ -228,6 +268,19 @@
(read-sequence buffer stream)
(setf (long-link-name entry) (bytevec-to-string buffer :utf-8))))
(defmethod write-gnu-long-link-name-entry (tar-file name &rest args)
;; (let ((header (apply #'make-instance (header-type tar-file)
;; :name name
;; :typeflag +tar-directory-file+
;; args))
;; (start-position (file-position (tar-file-stream tar-file))))
;; (write-entry-to-tar-file tar-file header)
;; (make-instance 'directory-entry :header header :tar-file tar-file :start-position start-position))
)
(defmethod entry-gnu-long-link-name-p ((entry gnu-long-link-name-entry))
t)
(defclass gnu-long-name-entry (entry has-data-mixin)
((long-name
:accessor long-name)))
......@@ -239,17 +292,39 @@
(read-sequence buffer stream)
(setf (long-name entry) (bytevec-to-string buffer :utf-8))))
(defmethod write-gnu-long-name-entry (tar-file name &rest args)
;; (let ((header (apply #'make-instance (header-type tar-file)
;; :name name
;; :typeflag +tar-directory-file+
;; args))
;; (start-position (file-position (tar-file-stream tar-file))))
;; (write-entry-to-tar-file tar-file header)
;; (make-instance 'directory-entry :header header :tar-file tar-file :start-position start-position))
)
(defmethod entry-gnu-long-name-p ((entry gnu-long-name-entry))
t)
(defclass gnu-sparse-file-entry (entry has-data-mixin)
())
(defmethod entry-gnu-sparse-file-p ((entry gnu-sparse-file-entry))
t)
(defclass gnu-volume-header-name-entry (entry)
())
(defmethod entry-gnu-volume-header-name-p ((entry gnu-volume-header-name-entry))
t)
(defclass unknown-entry (entry has-data-mixin)
()
(:documentation
"An unknown entry."))
(defmethod entry-unknown-p ((entry unknown-entry))
t)
(defgeneric entry-has-data-p (entry)
(:method (entry) nil)
(:method ((entry has-data-mixin)) t))
......
......@@ -4,11 +4,13 @@
(in-package #:tar-file)
(defun call-with-open-tar-file (thunk pathname &key (direction :input)
(if-exists nil)
(if-does-not-exist nil)
(type :auto)
(blocking-factor 20))
(defun call-with-open-tar-file (thunk pathname-or-stream
&key (direction :input)
(if-exists nil)
(if-does-not-exist nil)
(type :auto)
(blocking-factor 20)
(header-encoding *default-header-encoding*))
(when (or (eq direction :io) (eq direction :probe))
(error "Cannot open tar-files in direction ~A" direction))
(let (tar-file
......@@ -17,10 +19,10 @@
(abort t))
(unwind-protect
(progn
(when (streamp pathname) (setf should-close nil))
(when (streamp pathname-or-stream) (setf should-close nil))
(setf stream (if should-close
(apply #'open
pathname
pathname-or-stream
:direction direction
:element-type '(unsigned-byte 8)
(append
......@@ -28,9 +30,11 @@
(list :if-exists if-exists))
(when if-does-not-exist
(list :if-does-not-exist if-does-not-exist))))
pathname))
(setf tar-file (open-tar-file type stream :direction direction
:blocking-factor blocking-factor))
pathname-or-stream))
(setf tar-file (open-tar-file stream :direction direction
:type type
:blocking-factor blocking-factor
:header-encoding header-encoding))
(multiple-value-prog1
(funcall thunk tar-file)
(setf abort nil)))
......@@ -42,22 +46,35 @@
(when should-close
(close stream :abort abort)))))
(defmacro with-open-tar-file ((tar-file-var pathname
(defmacro with-open-tar-file ((tar-file-var pathname-or-stream
&key (direction :input)
(if-exists nil)
(if-does-not-exist nil)
(type :auto)
(blocking-factor 20))
(blocking-factor 20)
(header-encoding '*default-header-encoding*))
&body body)
"Bind TAR-FILE-VAR to a newly opened TAR-FILE, backed by
PATHNAME-OR-STREAM. If PATHNAME-OR-STREAM evaluates to a stream, that stream is
used directly, otherwise, it is opened via OPEN. If PATHNAME-OR-STREAM is a
stream, that stream is not closed upon exiting the body of the macro.
DIRECTION must be either :INPUT or :OUTPUT.
IF-EXISTS and IF-DOES-NOT-EXIST are passed to OPEN if PATHNAME-OR-STREAM is not
a stream.
See OPEN-TAR-FILE for a description of TYPE, BLOCKING-FACTOR, and HEADER-ENCODING."
(when (or (eq direction :io) (eq direction :probe))
(error "Cannot open tar-files in direction ~A" direction))
`(call-with-open-tar-file (lambda (,tar-file-var) ,@body)
,pathname
,pathname-or-stream
:direction ,direction
:if-exists ,if-exists
:if-does-not-exist ,if-does-not-exist
:type ,type
:blocking-factor ,blocking-factor))
:blocking-factor ,blocking-factor
:header-encoding ,header-encoding))
(defmacro do-entries ((entry tar-file &optional result)
&body body)
......
......@@ -2,6 +2,13 @@
(in-package #:tar-file)
(defgeneric close-tar-file (tar-file)
(:documentation
"Closes the stream associated with TAR-FILE and the tar-file itself.
Further operations on the tar-file are undefined.
Does NOT close the underlying STREAM that backed the TAR-FILE."))
(defgeneric (setf name) (value entry)
(:documentation "Sets the name of ENTRY to VALUE."))
......@@ -43,7 +50,7 @@ from which data may be read. If :STREAM is a stream, then data is read
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)
(defgeneric write-header-to-buffer (header buffer encoding &optional start)
(:documentation "Write the information associated with HEADER into BUFFER,
beginning at position START."))
......
......@@ -9,13 +9,6 @@
(defun injector-function-name (entry-name field-name)
(intern (with-standard-io-syntax (format nil "~A-WRITE-~A-TO-BUFFER" entry-name field-name))))
(defmacro with-extracted-fields ((entry-class buffer offset &rest fields)
&body body)
`(let ,(mapcar #'(lambda (field-name)
`(,field-name (,(extractor-function-name entry-class field-name) ,buffer ,offset)))
fields)
,@body))
(defgeneric field-offset (header field-name))
(defgeneric field-length (header field-name))
......@@ -35,17 +28,20 @@
,length) into length-defs
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)
collect `(defun ,(extractor-function-name class-name name) (buffer entry-start encoding)
(declare (type (simple-array (unsigned-byte 8) (*)) buffer))
(declare (ignorable encoding))
,(ecase kind
(:string
`(bytevec-to-string
(read-bytevec-from-buffer buffer :start (+ entry-start ,offset)
:end (+ entry-start ,offset ,length) :nullp nil)))
:end (+ entry-start ,offset ,length) :nullp nil)
encoding))
(:string-null
`(bytevec-to-string
(read-bytevec-from-buffer buffer :start (+ entry-start ,offset)
:end (+ entry-start ,offset ,length) :nullp t)))
:end (+ entry-start ,offset ,length) :nullp t)
encoding))
(:byte
(unless (= length 1)
(error ":BYTE fields cannot be longer than 1"))
......@@ -56,11 +52,12 @@
:end (+ entry-start ,offset ,length) :radix 8))
(:hexnum `(read-number-from-buffer buffer :start (+ entry-start ,offset)
:end (+ entry-start ,offset ,length) :radix 16)))) into reader-defs
collect `(defun ,(injector-function-name class-name name) (buffer entry-start thing)
collect `(defun ,(injector-function-name class-name name) (buffer entry-start thing encoding)
(declare (type (simple-array (unsigned-byte 8) (*)) buffer))
(declare (ignorable encoding))
,(ecase kind
((:string :string-null)
`(let ((thing (string-to-bytevec thing)))
`(let ((thing (string-to-bytevec thing encoding)))
(dotimes (i (length thing) (values))
(setf (aref buffer (+ entry-start ,offset i)) (aref thing i)))))
(:byte
......@@ -99,7 +96,7 @@
,offset)
(defmethod header-length ((header (eql ',class-name)))
,offset)
(defmethod write-header-to-buffer ((header ,class-name) buffer &optional (start 0))
(defmethod write-header-to-buffer ((header ,class-name) buffer encoding &optional (start 0))
(declare (type (simple-array (unsigned-byte 8) (*)) buffer))
;; Ensure we can write the entire header to this
......@@ -111,7 +108,8 @@
,@(loop
:for (name length kind) :in field-defs
:unless (eql name 'checksum)
:collect `(,(injector-function-name class-name name) buffer start (,name header)))
:collect `(,(injector-function-name class-name name) buffer start (,name header)
encoding))
;; Write the checksum
(let* ((checksum (compute-checksum-for-tar-header header buffer start))
......@@ -125,8 +123,8 @@
;; terminated with a NULL and then a space (!?)
(setf (aref buffer (+ checksum-offset 6)) 0
(aref buffer (+ checksum-offset 7)) +ascii-space+)))
(defmethod read-header-from-buffer ((header (eql ',class-name)) buffer &key (start 0))
(let ((checksum (,(extractor-function-name class-name 'checksum) buffer start)))
(defmethod read-header-from-buffer ((header (eql ',class-name)) buffer encoding &key (start 0))
(let ((checksum (,(extractor-function-name class-name 'checksum) buffer start encoding)))
(multiple-value-bind (validp computed)
(tar-block-checksum-matches-p header buffer checksum start)
(unless validp
......@@ -138,4 +136,4 @@
:unless (eql name '%%padding)
:appending `(,(keywordify-name name)
(,(extractor-function-name class-name name)
buffer start)))))))))))))
buffer start encoding)))))))))))))
......@@ -44,6 +44,11 @@
#:write-fifo-entry
#:write-block-device-entry
#:write-character-device-entry