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

Add PAX header parsing and tests

parent 151da6da
......@@ -6,7 +6,7 @@
:maintainer "Eric Timmons <eric@timmons.dev>"
:description "A package for reading and writing archive (currently only tar) files."
:license "BSD-style (http://opensource.org/licenses/BSD-3-Clause)"
:depends-on ("alexandria" "babel" #+sbcl "sb-posix" "trivial-gray-streams" "uiop")
:depends-on ("alexandria" "babel" "trivial-gray-streams" "uiop")
:pathname "src"
:in-order-to ((test-op (load-op "cl-tar/test")))
:perform (test-op (o c)
......@@ -25,7 +25,7 @@
(:file "external-macros" :depends-on ("generics"))
(:file "ustar" :depends-on ("package" "macros" "archive"))
(:file "v7" :depends-on ("package" "macros" "archive"))
(:file "entry" :depends-on ("package"))
(:file "entry" :depends-on ("package" "constants"))
(:file "bounded-stream" :depends-on ("package"))
(:file "archive" :depends-on ("generics" "bounded-stream" "macros" "external-macros" "entry" "constants"))))
......
......@@ -40,3 +40,6 @@
(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."))
(define-condition malformed-pax-attribute-entry (archive-error)
())
......@@ -32,3 +32,4 @@
(defconstant +ascii-a+ #x61)
(defconstant +ascii-z+ #x7a)
(defconstant +ascii-/+ #x29)
(defconstant +ascii-newline+ #xa)
......@@ -50,12 +50,84 @@
(:documentation
"A FIFO."))
(defclass pax-extended-attributes-entry (entry)
(defclass pax-attributes-entry (entry)
((attributes
:accessor attributes
:documentation
"A hash table mapping attribute names (strings) to values (strings).")))
(defgeneric attribute (entry name &optional default)
(: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))
(defun read-attribute-length (stream)
"Pop bytes out of the buffer until a space is read, then try turning that
into a number."
(let* ((bytes-read 0)
(bytes (loop
:for byte := (read-byte stream nil :eof)
:when (eql byte :eof)
:do (return :eof)
:end
:do (incf bytes-read)
:until (eql byte +ascii-space+)
:collect byte)))
(if (eql bytes :eof)
:eof
(values (parse-integer (bytevec-to-string (coerce bytes '(vector (unsigned-byte 8)))))
bytes-read))))
(defun read-attribute (stream)
(multiple-value-bind (num-bytes bytes-read)
(read-attribute-length stream)
(let (buffer
num-read
kv-string
=-position)
(unless (eql num-bytes :eof)
(setf buffer (make-array (- num-bytes bytes-read) :element-type '(unsigned-byte 8) :initial-element 0))
(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))
(unless (= (aref buffer (1- num-read)) +ascii-newline+)
(error 'malformed-pax-attribute-entry))
(setf =-position (position #\= kv-string))
(when (null =-position)
(error 'malformed-pax-attribute-entry))
(values (subseq kv-string 0 =-position)
(subseq kv-string (1+ =-position) (1- num-read))
t)))))
(defun populate-pax-attributes (entry)
(let ((stream (make-entry-stream entry))
(ht (make-hash-table :test 'equal)))
(loop
(multiple-value-bind (key value exists-p)
(read-attribute stream)
(unless exists-p (return))
(setf (gethash key ht) value)))
(setf (attributes entry) ht)))
(defmethod slot-unbound (class (entry pax-attributes-entry) (slot-name (eql 'attributes)))
(populate-pax-attributes entry))
(defclass pax-extended-attributes-entry (pax-attributes-entry)
()
(:documentation
"Extended attributes for the subsequent record."))
(defclass pax-global-attributes-entry (entry)
(defclass pax-global-attributes-entry (pax-attributes-entry)
()
(:documentation
"Extended attributes for all subsequent records."))
......@@ -78,6 +150,18 @@
(make-bounded-stream (archive-stream (entry-archive entry)) (size entry)
(+ (start-position entry) +tar-n-block-bytes+)))
(defmethod make-entry-stream ((entry pax-extended-attributes-entry))
(make-bounded-stream (archive-stream (entry-archive entry)) (size entry)
(+ (start-position entry) +tar-n-block-bytes+)))
(defmethod make-entry-stream ((entry pax-global-attributes-entry))
(make-bounded-stream (archive-stream (entry-archive entry)) (size entry)
(+ (start-position entry) +tar-n-block-bytes+)))
(defmethod make-entry-stream ((entry unknown-entry))
(make-bounded-stream (archive-stream (entry-archive entry)) (size entry)
(+ (start-position entry) +tar-n-block-bytes+)))
(defmacro make-header-forwarder (name)
`(defmethod ,name ((entry entry))
(,name (header entry))))
......
......@@ -27,6 +27,7 @@
#:linkname
#:devmajor
#:devminor
#:attribute
;; entry tests
#:entry-directory-p
......
......@@ -5,7 +5,7 @@ DIR="$(mktemp -d)"
MTIME="Fri Aug 13 09:05:46.75 PM EDT 2021"
touch_file () {
touch -a --date "$MTIME" "$1"
touch -h -a --date "$MTIME" "$1"
}
touch_files () {
......
No preview for this file type
......@@ -5,10 +5,81 @@
(byte-contents (alexandria:read-stream-content-into-byte-vector stream)))
(babel:octets-to-string byte-contents :encoding :utf-8)))
(defun a.txt-attr (type entry)
(declare (ignore type))
(para:is equal "./PaxHeaders/a.txt" (tar:name entry))
(para:is equal "" (tar:uname entry))
(para:is equal "" (tar:gname entry))
(para:is = #o644 (tar:mode entry))
(para:is = 1628903146 (tar:mtime entry))
(para:is = 0 (tar:uid entry))
(para:is = 0 (tar:gid entry))
(para:is equal "1628903146.5" (tar:attribute entry "mtime"))
(para:is equal "1628903146.75" (tar:attribute entry "atime")))
(defun a-symlink.txt-attr (type entry)
(declare (ignore type))
(para:is equal "./PaxHeaders/a-symlink.txt" (tar:name entry))
(para:is equal "" (tar:uname entry))
(para:is equal "" (tar:gname entry))
(para:is = #o644 (tar:mode entry))
(para:is = 1628903146 (tar:mtime entry))
(para:is = 0 (tar:uid entry))
(para:is = 0 (tar:gid entry))
(para:is equal "1628903146.5" (tar:attribute entry "mtime"))
(para:is equal "1628903146.75" (tar:attribute entry "atime")))
(defun a-hardlink.txt-attr (type entry)
(declare (ignore type))
(para:is equal "./PaxHeaders/a-hardlink.txt" (tar:name entry))
(para:is equal "" (tar:uname entry))
(para:is equal "" (tar:gname entry))
(para:is = #o644 (tar:mode entry))
(para:is = 1628903146 (tar:mtime entry))
(para:is = 0 (tar:uid entry))
(para:is = 0 (tar:gid entry))
(para:is equal "1628903146.5" (tar:attribute entry "mtime")))
(defun fifo-attr (type entry)
(declare (ignore type))
(para:is equal "./PaxHeaders/fifo" (tar:name entry))
(para:is equal "" (tar:uname entry))
(para:is equal "" (tar:gname entry))
(para:is = #o644 (tar:mode entry))
(para:is = 1628903146 (tar:mtime entry))
(para:is = 0 (tar:uid entry))
(para:is = 0 (tar:gid entry))
(para:is equal "1628903146.5" (tar:attribute entry "mtime"))
(para:is equal "1628903146.75" (tar:attribute entry "atime")))
(defun sda1-attr (type entry)
(declare (ignore type))
(para:is equal "./PaxHeaders/sda1" (tar:name entry))
(para:is equal "" (tar:uname entry))
(para:is equal "" (tar:gname entry))
(para:is = #o644 (tar:mode entry))
(para:is = 1628903146 (tar:mtime entry))
(para:is = 0 (tar:uid entry))
(para:is = 0 (tar:gid entry))
(para:is equal "1628903146.5" (tar:attribute entry "mtime"))
(para:is equal "1628903146.75" (tar:attribute entry "atime")))
(defun tty0-attr (type entry)
(declare (ignore type))
(para:is equal "./PaxHeaders/tty0" (tar:name entry))
(para:is equal "" (tar:uname entry))
(para:is equal "" (tar:gname entry))
(para:is = #o644 (tar:mode entry))
(para:is = 1628903146 (tar:mtime entry))
(para:is = 0 (tar:uid entry))
(para:is = 0 (tar:gid entry))
(para:is equal "1628903146.5" (tar:attribute entry "mtime"))
(para:is equal "1628903146.75" (tar:attribute entry "atime")))
(defun a.txt (type entry)
(para:is equal "a.txt" (tar:name entry))
(para:is = 14 (tar:size entry))
(unless (eql type :ustar)
(unless (eql type :v7)
(para:is equal "root" (tar:uname entry))
(para:is equal "root" (tar:gname entry)))
(para:is = #o644 (tar:mode entry))
......@@ -22,7 +93,7 @@
(defun a-symlink.txt (type entry)
(para:is equal "a-symlink.txt" (tar:name entry))
(para:is = 0 (tar:size entry))
(unless (eql type :ustar)
(unless (eql type :v7)
(para:is equal "root" (tar:uname entry))
(para:is equal "root" (tar:gname entry)))
(para:is = #o777 (tar:mode entry))
......@@ -35,7 +106,7 @@
(defun a-hardlink.txt (type entry)
(para:is equal "a-hardlink.txt" (tar:name entry))
(para:is = 0 (tar:size entry))
(unless (eql type :ustar)
(unless (eql type :v7)
(para:is equal "root" (tar:uname entry))
(para:is equal "root" (tar:gname entry)))
(para:is = #o644 (tar:mode entry))
......@@ -46,6 +117,7 @@
(para:is equal "a.txt" (tar:linkname entry)))
(defun fifo (type entry)
(declare (ignore type))
(para:is equal "fifo" (tar:name entry))
(para:is = 0 (tar:size entry))
(para:is equal "root" (tar:uname entry))
......@@ -57,6 +129,7 @@
(para:is = 0 (tar:gid entry)))
(defun sda1 (type entry)
(declare (ignore type))
(para:is equal "sda1" (tar:name entry))
(para:is = 0 (tar:size entry))
(para:is equal "root" (tar:uname entry))
......@@ -70,6 +143,7 @@
(para:is = 1 (tar:devminor entry)))
(defun tty0 (type entry)
(declare (ignore type))
(para:is equal "tty0" (tar:name entry))
(para:is = 0 (tar:size entry))
(para:is equal "root" (tar:uname entry))
......@@ -114,21 +188,65 @@
(setf entry (tar:read-entry-from-archive a))
(para:true (null entry)))))
(para:define-test read-pax
(tar:with-open-archive (a (asdf:system-relative-pathname
:cl-tar "test/pax.tar"))
(let (entry)
(setf entry (tar:read-entry-from-archive a))
(a.txt-attr :pax entry)
(setf entry (tar:read-entry-from-archive a))
(a.txt :pax entry)
(setf entry (tar:read-entry-from-archive a))
(a-symlink.txt-attr :pax entry)
(setf entry (tar:read-entry-from-archive a))
(a-symlink.txt :pax entry)
(setf entry (tar:read-entry-from-archive a))
(a-hardlink.txt-attr :pax entry)
(setf entry (tar:read-entry-from-archive a))
(a-hardlink.txt :pax entry)
(setf entry (tar:read-entry-from-archive a))
(fifo-attr :pax entry)
(setf entry (tar:read-entry-from-archive a))
(fifo :pax entry)
(setf entry (tar:read-entry-from-archive a))
(sda1-attr :pax entry)
(setf entry (tar:read-entry-from-archive a))
(sda1 :pax entry)
(setf entry (tar:read-entry-from-archive a))
(tty0-attr :pax entry)
(setf entry (tar:read-entry-from-archive a))
(tty0 :pax entry)
;; End of archive
(setf entry (tar:read-entry-from-archive a))
(para:true (null entry)))))
(para:define-test read-v7
(tar:with-open-archive (a (asdf:system-relative-pathname
:cl-tar "test/v7.tar"))
(let (entry)
;; First entry is a plain file, with the contents "Hello, world!"
(setf entry (tar:read-entry-from-archive a))
(a.txt :ustar entry)
(a.txt :v7 entry)
;; Next is the a-symlink.txt -> a.txt symlink
(setf entry (tar:read-entry-from-archive a))
(a-symlink.txt :ustar entry)
(a-symlink.txt :v7 entry)
;; Next is the a-hardlink.txt -> a.txt hardlink
(setf entry (tar:read-entry-from-archive a))
(a-hardlink.txt :ustar entry)
(a-hardlink.txt :v7 entry)
;; End of archive
(setf entry (tar:read-entry-from-archive a))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment