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

Finish documentation

parent 450d0f1b
;;;; Documentation
;;;;
;;;; This is part of tar-file. See README.org and LICENSE for more information.
(in-package #:tar-file)
(40ants-doc:defsection @manual (:title "Tar File Manual"
:export nil)
#.(uiop:read-file-string (asdf:system-relative-pathname :tar-file "README.md"))
(@opening-tar-files 40ants-doc/locatives:section)
(@tar-archive-types 40ants-doc/locatives:section)
(@entries 40ants-doc/locatives:section)
(@conditions 40ants-doc/locatives:section))
(40ants-doc:defsection @opening-tar-files (:title "Opening and Closing Tar Files"
:export nil)
(*default-header-encoding* 40ants-doc/locatives:variable)
(with-open-tar-file 40ants-doc/locatives:macro)
(open-tar-file 40ants-doc/locatives:function)
(finalize-tar-file 40ants-doc/locatives:generic-function)
(close-tar-file 40ants-doc/locatives:generic-function))
(40ants-doc:defsection @tar-archive-types (:title "Tar Archive Types"
:export nil)
"There are three different types of tar archives that this system can handle,
with a common base class."
(tar-file 40ants-doc/locatives:class)
(ustar-tar-file 40ants-doc/locatives:class)
(gnu-tar-file 40ants-doc/locatives:class)
(v7-tar-file 40ants-doc/locatives:class))
(40ants-doc:defsection @entries (:title "Entries"
:export nil)
(do-entries 40ants-doc/locatives:macro)
(read-entry 40ants-doc/locatives:generic-function)
(entry 40ants-doc/locatives:class)
(entry-has-data-p 40ants-doc/locatives:generic-function)
(make-entry-stream 40ants-doc/locatives:generic-function)
(name 40ants-doc/locatives:generic-function)
(size 40ants-doc/locatives:generic-function)
(uname 40ants-doc/locatives:generic-function)
(gname 40ants-doc/locatives:generic-function)
(mode 40ants-doc/locatives:generic-function)
(mtime 40ants-doc/locatives:generic-function)
(uid 40ants-doc/locatives:generic-function)
(gid 40ants-doc/locatives:generic-function)
(linkname 40ants-doc/locatives:generic-function)
(devmajor 40ants-doc/locatives:generic-function)
(devminor 40ants-doc/locatives:generic-function)
(prefix 40ants-doc/locatives:generic-function)
(atime 40ants-doc/locatives:generic-function)
(ctime 40ants-doc/locatives:generic-function)
(offset 40ants-doc/locatives:generic-function)
(offset-sparse-0 40ants-doc/locatives:generic-function)
(numbytes-sparse-0 40ants-doc/locatives:generic-function)
(offset-sparse-1 40ants-doc/locatives:generic-function)
(numbytes-sparse-1 40ants-doc/locatives:generic-function)
(offset-sparse-2 40ants-doc/locatives:generic-function)
(numbytes-sparse-2 40ants-doc/locatives:generic-function)
(offset-sparse-3 40ants-doc/locatives:generic-function)
(numbytes-sparse-3 40ants-doc/locatives:generic-function)
(isextended 40ants-doc/locatives:generic-function)
(realsize 40ants-doc/locatives:generic-function)
(attribute 40ants-doc/locatives:generic-function)
(attribute-names 40ants-doc/locatives:generic-function)
(do-attributes 40ants-doc/locatives:macro)
(@file-entry 40ants-doc/locatives:section)
(@symbolic-link-entry 40ants-doc/locatives:section)
(@hard-link-entry 40ants-doc/locatives:section)
(@character-device-entry 40ants-doc/locatives:section)
(@block-device-entry 40ants-doc/locatives:section)
(@fifo-entry 40ants-doc/locatives:section)
(@directory-entry 40ants-doc/locatives:section)
(@pax-extended-attributes-entry 40ants-doc/locatives:section)
(@pax-global-attributes-entry 40ants-doc/locatives:section)
(@gnu-long-link-name-entry 40ants-doc/locatives:section)
(@gnu-long-name-entry 40ants-doc/locatives:section)
(@gnu-directory-dump-entry 40ants-doc/locatives:section)
(@gnu-sparse-file-entry 40ants-doc/locatives:section)
(@gnu-volume-header-name-entry 40ants-doc/locatives:section)
(@unknown-entry 40ants-doc/locatives:section))
(40ants-doc:defsection @file-entry (:title "File Entry"
:export nil)
(file-entry 40ants-doc/locatives:class)
(write-file-entry 40ants-doc/locatives:generic-function)
(entry-file-p 40ants-doc/locatives:generic-function))
(40ants-doc:defsection @symbolic-link-entry (:title "Symbolic Link Entry"
:export nil)
(symbolic-link-entry 40ants-doc/locatives:class)
(write-symbolic-link-entry 40ants-doc/locatives:generic-function)
(entry-symbolic-link-p 40ants-doc/locatives:generic-function))
(40ants-doc:defsection @hard-link-entry (:title "Hard Link Entry"
:export nil)
(hard-link-entry 40ants-doc/locatives:class)
(write-hard-link-entry 40ants-doc/locatives:generic-function)
(entry-hard-link-p 40ants-doc/locatives:generic-function))
(40ants-doc:defsection @character-device-entry (:title "Character Device Entry"
:export nil)
(character-device-entry 40ants-doc/locatives:class)
(write-character-device-entry 40ants-doc/locatives:generic-function)
(entry-character-device-p 40ants-doc/locatives:generic-function))
(40ants-doc:defsection @block-device-entry (:title "Block Device Entry"
:export nil)
(block-device-entry 40ants-doc/locatives:class)
(write-block-device-entry 40ants-doc/locatives:generic-function)
(entry-block-device-p 40ants-doc/locatives:generic-function))
(40ants-doc:defsection @fifo-entry (:title "Fifo Entry"
:export nil)
(fifo-entry 40ants-doc/locatives:class)
(write-fifo-entry 40ants-doc/locatives:generic-function)
(entry-fifo-p 40ants-doc/locatives:generic-function))
(40ants-doc:defsection @directory-entry (:title "Directory Entry"
:export nil)
(directory-entry 40ants-doc/locatives:class)
(write-directory-entry 40ants-doc/locatives:generic-function)
(entry-directory-p 40ants-doc/locatives:generic-function))
(40ants-doc:defsection @pax-extended-attributes-entry (:title "Pax Extended Attributes Entry"
:export nil)
(pax-extended-attributes-entry 40ants-doc/locatives:class)
(write-pax-extended-attributes-entry 40ants-doc/locatives:generic-function)
(entry-pax-extended-attributes-p 40ants-doc/locatives:generic-function))
(40ants-doc:defsection @pax-global-attributes-entry (:title "Pax Global Attributes Entry"
:export nil)
(pax-global-attributes-entry 40ants-doc/locatives:class)
(write-pax-global-attributes-entry 40ants-doc/locatives:generic-function)
(entry-pax-global-attributes-p 40ants-doc/locatives:generic-function))
(40ants-doc:defsection @gnu-long-link-name-entry (:title "Gnu Long Link Name Entry"
:export nil)
(gnu-long-link-name-entry 40ants-doc/locatives:class)
(write-gnu-long-link-name-entry 40ants-doc/locatives:generic-function)
(entry-gnu-long-link-name-p 40ants-doc/locatives:generic-function))
(40ants-doc:defsection @gnu-long-name-entry (:title "Gnu Long Name Entry"
:export nil)
(gnu-long-name-entry 40ants-doc/locatives:class)
(write-gnu-long-name-entry 40ants-doc/locatives:generic-function)
(entry-gnu-long-name-p 40ants-doc/locatives:generic-function))
(40ants-doc:defsection @gnu-directory-dump-entry (:title "Gnu Directory Dump Entry"
:export nil)
(gnu-directory-dump-entry 40ants-doc/locatives:class)
(entry-gnu-directory-dump-p 40ants-doc/locatives:generic-function))
(40ants-doc:defsection @gnu-sparse-file-entry (:title "Gnu-Sparse-File Entry"
:export nil)
(gnu-sparse-file-entry 40ants-doc/locatives:class)
(entry-gnu-sparse-file-p 40ants-doc/locatives:generic-function))
(40ants-doc:defsection @gnu-volume-header-name-entry (:title "Gnu Volume Header Name Entry"
:export nil)
(gnu-volume-header-name-entry 40ants-doc/locatives:class)
(entry-gnu-volume-header-name-p 40ants-doc/locatives:generic-function))
(40ants-doc:defsection @unknown-entry (:title "Unknown Entry"
:export nil)
(unknown-entry 40ants-doc/locatives:class)
(entry-unknown-p 40ants-doc/locatives:generic-function))
(40ants-doc:defsection @conditions (:title "Conditions"
:export nil)
(tar-file-error condition)
(invalid-checksum-error condition)
(malformed-pax-attribute-entry condition))
......@@ -15,7 +15,9 @@
"The FILE-POSITION of the start of the entry.")
(header
:initarg :header
:reader header)))
:reader header))
(:documentation
"Base class for all entries in a tar file."))
(defclass has-data-mixin ()
())
......@@ -28,17 +30,35 @@
(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.
(let ((computed-size
(etypecase data
(string
(setf data (string-to-bytevec data :utf-8))
(push data args)
(push :data args)
(length data))
(vector
(length data))
(pathname
(with-open-file (s data :element-type '(unsigned-byte 8))
(file-length s)))
(null
0)
(stream
(file-length data)))))
(when (not (null computed-size))
(cond
((null size)
(setf size computed-size))
((/= size computed-size)
(error 'simple-tar-file-error
:format-control "Computed (~A) and specified (~A) sizes mismatch"
:format-args (list computed-size size))))))
(when (null size)
(etypecase data
(vector
(setf size (length data)))
(pathname
(with-open-file (s data :element-type '(unsigned-byte 8))
(setf size (file-length s))))
(stream
(setf size (file-length data))))
(push size args)
(push :size args))
(error 'simple-tar-file-error
:format-control "Size not provided and unable to compute it."))
(push size args)
(push :size args)
(let ((header (apply #'make-instance (header-type tar-file)
:name name
......@@ -47,7 +67,7 @@
+tar-regular-file+)
(uiop:remove-plist-key :data args)))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry-to-tar-file tar-file header :stream data)
(write-entry tar-file header :stream data)
(make-instance 'file-entry :header header :tar-file tar-file :start-position start-position)))
(defclass hard-link-entry (entry)
......@@ -62,7 +82,7 @@
:typeflag +tar-hard-link+
args))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry-to-tar-file tar-file header)
(write-entry tar-file header)
(make-instance 'hard-link-entry :header header :tar-file tar-file :start-position start-position)))
(defclass symbolic-link-entry (entry)
......@@ -77,7 +97,7 @@
:typeflag +tar-symbolic-link+
args))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry-to-tar-file tar-file header)
(write-entry tar-file header)
(make-instance 'symbolic-link-entry :header header :tar-file tar-file :start-position start-position)))
(defclass character-device-entry (entry)
......@@ -93,7 +113,7 @@
:typeflag +tar-character-device+
args))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry-to-tar-file tar-file header)
(write-entry tar-file header)
(make-instance 'character-device-entry :header header :tar-file tar-file :start-position start-position)))
(defclass block-device-entry (entry)
......@@ -109,7 +129,7 @@
:typeflag +tar-block-device+
args))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry-to-tar-file tar-file header)
(write-entry tar-file header)
(make-instance 'block-device-entry :header header :tar-file tar-file :start-position start-position)))
(defclass directory-entry (entry)
......@@ -124,7 +144,7 @@
:typeflag +tar-directory-file+
args))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry-to-tar-file tar-file header)
(write-entry tar-file header)
(make-instance 'directory-entry :header header :tar-file tar-file :start-position start-position)))
(defclass fifo-entry (entry)
......@@ -139,7 +159,7 @@
:typeflag +tar-fifo-device+
args))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry-to-tar-file tar-file header)
(write-entry 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)
......@@ -152,13 +172,25 @@
(:documentation
"Get the NAME attribute from ENTRY."))
(defgeneric (setf attribute) (new-value entry name &optional default))
(defmethod attribute ((entry pax-attributes-entry) name &optional default)
(gethash name (attributes entry) default))
(defmethod (setf attribute) (new-value (entry pax-attributes-entry) name &optional default)
(setf (gethash name (attributes entry) default) new-value))
(defgeneric attribute-names (entry)
(:documentation
"Return a list of attribute names contained within ENTRY."))
(defmethod attribute-names ((entry pax-attributes-entry))
(alexandria:hash-table-values (attributes entry)))
(defmacro do-attributes ((name value entry &optional result) &body body)
"Given a PAX ENTRY with attributes, execute BODY for every attribute, with
NAME bound to the attribute name and VALUE bound to the attribute value."
`(block nil
(maphash
(lambda (,name ,value)
,@body)
(attributes ,entry))
,result))
(defun read-attribute-length (stream)
"Pop bytes out of the buffer until a space is read, then try turning that
......@@ -166,8 +198,6 @@
(let* ((bytes-read 0)
(bytes (loop
:for byte := (read-byte stream nil :eof)
:when (eql byte :eof)
:do (return :eof)
:end
......@@ -220,15 +250,44 @@
(: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 user-attributes-to-alist ((attributes hash-table))
(alexandria:hash-table-alist attributes))
(defmethod user-attributes-to-alist ((attributes list))
attributes)
(defun attribute-pair-to-bytevec (pair)
(let* ((pair-string (concatenate 'string " "
(car pair)
"="
(cdr pair)
(list #\Linefeed)))
(pair-vector (string-to-bytevec pair-string :utf-8))
(base-length (length pair-vector)))
(loop
:for offset :upfrom 0 :below 2
:for estimated-length := (+ offset (ceiling (log base-length 10)) base-length)
:for length-vector := (string-to-bytevec (prin1-to-string estimated-length)
:utf-8)
:do (format t "~S~%" offset)
:when (= estimated-length (+ (length length-vector) base-length))
:return (concatenate '(vector (unsigned-byte 8)) length-vector pair-vector))))
(defun attribute-alist-to-bytevec (alist)
(apply #'concatenate '(vector (unsigned-byte 8)) (mapcar #'attribute-pair-to-bytevec alist)))
(defmethod write-pax-extended-attributes-entry (tar-file name &rest args &key attributes)
(let* ((alist (user-attributes-to-alist attributes))
(data (attribute-alist-to-bytevec alist))
(size (length data)))
(let ((header (apply #'make-instance (header-type tar-file)
:name name
:typeflag +posix-extended-header+
:size size
(alexandria:remove-from-plist args :attributes)))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry tar-file header :stream data)
(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)
......@@ -238,15 +297,18 @@
(: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 write-pax-global-attributes-entry (tar-file name &rest args &key attributes)
(let* ((alist (user-attributes-to-alist attributes))
(data (attribute-alist-to-bytevec alist))
(size (length data)))
(let ((header (apply #'make-instance (header-type tar-file)
:name name
:typeflag +posix-global-header+
:size size
(alexandria:remove-from-plist args :attributes)))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry tar-file header :stream data)
(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)
......@@ -268,15 +330,24 @@
(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 write-gnu-long-link-name-entry (tar-file name &rest args &key data)
(let* ((data (etypecase data
(string
(string-to-bytevec data :utf-8))
((vector (unsigned-byte 8))
data)))
(size (length data))
(header (apply #'make-instance (header-type tar-file)
:name name
:typeflag +gnutar-long-link-name+
:size size
(alexandria:remove-from-plist args :data)))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry tar-file header :stream data)
(make-instance 'gnu-long-link-name-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)
......@@ -292,15 +363,24 @@
(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 write-gnu-long-name-entry (tar-file name &rest args &key data)
(let* ((data (etypecase data
(string
(string-to-bytevec data :utf-8))
((vector (unsigned-byte 8))
data)))
(size (length data))
(header (apply #'make-instance (header-type tar-file)
:name name
:typeflag +gnutar-long-link-name+
:size size
(alexandria:remove-from-plist args :data)))
(start-position (file-position (tar-file-stream tar-file))))
(write-entry tar-file header :stream data)
(make-instance 'gnu-long-name-entry
:header header
:tar-file tar-file
:start-position start-position)))
(defmethod entry-gnu-long-name-p ((entry gnu-long-name-entry))
t)
......@@ -326,18 +406,23 @@
t)
(defgeneric entry-has-data-p (entry)
(:documentation
"Returns non-NIL if ENTRY has associated data that can be read using MAKE-ENTRY-STREAM.")
(:method (entry) nil)
(:method ((entry has-data-mixin)) t))
(defgeneric make-entry-stream (entry))
(defgeneric make-entry-stream (entry)
(:documentation
"Returns a new binary stream that contains ENTRY's data."))
(defmethod make-entry-stream ((entry has-data-mixin))
(make-bounded-stream (tar-file-stream (entry-tar-file entry)) (size entry)
(+ (start-position entry) +tar-n-block-bytes+)))
(defmacro make-header-forwarder (name)
`(defmethod ,name ((entry entry))
(,name (header entry))))
`(progn
(defmethod ,name ((entry entry))
(,name (header entry)))))
(make-header-forwarder name)
(make-header-forwarder mode)
......@@ -373,27 +458,23 @@
(print-unreadable-object (entry stream)
(format stream "Entry ~A" (name entry))))
(defmethod entry-file-p (entry)
(or (eql (typeflag entry) +tar-regular-file+)
(eql (typeflag entry) +tar-regular-alternate-file+)))
(defmethod entry-directory-p (entry)
(eql (typeflag entry) +tar-directory-file+))
(defmethod entry-file-p ((entry file-entry))
t)
(defmethod entry-hard-link-p (entry)
(eql (typeflag entry) +tar-hard-link+))
(defmethod entry-directory-p ((entry directory-entry))
t)
(defmethod entry-symbolic-link-p (entry)
(eql (typeflag entry) +tar-symbolic-link+))
(defmethod entry-hard-link-p ((entry hard-link-entry))
t)
(defmethod entry-hard-link-p (entry)
(eql (typeflag entry) +tar-hard-link+))
(defmethod entry-symbolic-link-p ((entry symbolic-link-entry))
t)
(defmethod entry-character-device-p (entry)
(eql (typeflag entry) +tar-character-device+))
(defmethod entry-character-device-p ((entry character-device-entry))
t)
(defmethod entry-block-device-p (entry)
(eql (typeflag entry) +tar-block-device+))
(defmethod entry-block-device-p ((entry block-device-entry))
t)
(defmethod entry-fifo-p (entry)
(eql (typeflag entry) +tar-fifo-device+))
(defmethod entry-fifo-p ((entry fifo-entry))
t)
......@@ -10,26 +10,151 @@ 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."))
(defgeneric name (entry)
(:documentation "Return the name of the ENTRY (a string)."))
(defgeneric mode (entry)
(:documentation "Return the mode of the ENTRY (an integer)."))
(defgeneric uid (entry)
(:documentation "Return the uid of the ENTRY (an integer)."))
(defgeneric gid (entry)
(:documentation "Return the gid of the ENTRY (an integer)."))
(defgeneric size (entry)
(:documentation "Return the size of the ENTRY (an integer)."))
(defgeneric mtime (entry)
(:documentation "Return the mtime of the ENTRY (an integer)."))
(defgeneric linkname (entry)
(:documentation "Return the linkname of the ENTRY (a string)."))
(defgeneric uname (entry)
(:documentation "Return the uname of the ENTRY (a string)."))
(defgeneric gname (entry)
(:documentation "Return the gname of the ENTRY (a string)."))
(defgeneric devmajor (entry)
(:documentation "Return the major device of the ENTRY (an integer)."))
(defgeneric devminor (entry)
(:documentation "Return the minor device of the ENTRY (an integer)."))
(defgeneric prefix (entry)
(:documentation "Return the prefix of the ENTRY (a string)."))
(defgeneric atime (entry)
(:documentation "Return the atime of the ENTRY (an integer)."))
(defgeneric ctime (entry)
(:documentation "Return the ctime of the ENTRY (an integer)."))
(defgeneric offset (entry)
(:documentation "Return the offset of the ENTRY (an integer)."))
(defgeneric offset-sparse-0 (entry)
(:documentation "Return the offset of the first sparse block of the ENTRY (an integer)."))
(defgeneric numbytes-sparse-0 (entry)
(:documentation "Return the numbytes of the first sparse block of the ENTRY (an integer)."))
(defgeneric offset-sparse-1 (entry)
(:documentation "Return the offset of the second sparse block of the ENTRY (an integer)."))
(defgeneric numbytes-sparse-1 (entry)
(:documentation "Return the numbytes of the second sparse block of the ENTRY (an integer)."))
(defgeneric offset-sparse-2 (entry)
(:documentation "Return the offset of the third sparse block of the ENTRY (an integer)."))
(defgeneric numbytes-sparse-2 (entry)
(:documentation "Return the numbytes of the third sparse block of the ENTRY (an integer)."))
(defgeneric offset-sparse-3 (entry)
(:documentation "Return the offset of the fourth sparse block of the ENTRY (an integer)."))
(defgeneric numbytes-sparse-3 (entry)
(:documentation "Return the numbytes of the fourth sparse block of the ENTRY (an integer)."))