Commit 7278e83e authored by Eric Timmons's avatar Eric Timmons
Browse files

Add ARCHIVE-ENTRY-TYPE and ENTRY-HAS-DATA-P

parent 4b35488d
......@@ -41,6 +41,8 @@
(defgeneric archive-header-type (archive))
(defgeneric archive-entry-type (archive header))
(defun open-archive (archive-type stream &key (direction :input)
(blocking-factor 20))
"Return an archive. STREAM is the underlying Lisp stream for the archive.
......@@ -140,11 +142,7 @@ requirements about alignment."
(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))
(make-instance (archive-entry-type archive header)
:archive archive
:header header
:start-position start-position)))))
......@@ -155,14 +153,9 @@ requirements about alignment."
(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))))))
(if (entry-has-data-p entry)
(round-up-to-tar-block (size entry))
0))))
entry))
(defun transfer-stream-to-archive (archive stream)
......
......@@ -31,3 +31,4 @@
(defconstant +ascii-nine+ #x39)
(defconstant +ascii-a+ #x61)
(defconstant +ascii-z+ #x7a)
(defconstant +ascii-/+ #x29)
......@@ -20,6 +20,58 @@
(:documentation
"A regular file."))
(defclass hard-link-entry (entry)
()
(:documentation
"A hard link."))
(defclass symbolic-link-entry (entry)
()
(:documentation
"A symbolic link."))
(defclass character-device-entry (entry)
()
(:documentation
"A character device."))
(defclass block-device-entry (entry)
()
(:documentation
"A block device."))
(defclass directory-entry (entry)
()
(:documentation
"A directory."))
(defclass fifo-entry (entry)
()
(:documentation
"A FIFO."))
(defclass pax-extended-attributes-entry (entry)
()
(:documentation
"Extended attributes for the subsequent record."))
(defclass pax-global-attributes-entry (entry)
()
(:documentation
"Extended attributes for all subsequent records."))
(defclass unknown-entry (entry)
()
(:documentation
"An unknown entry."))
(defgeneric entry-has-data-p (entry)
(:method (entry) nil)
(:method ((entry file-entry)) t)
(:method ((entry pax-extended-attributes-entry)) t)
(:method ((entry pax-global-attributes-entry)) t)
(:method ((entry unknown-entry)) t))
(defgeneric make-entry-stream (entry))
(defmethod make-entry-stream ((entry file-entry))
......
......@@ -46,3 +46,28 @@
'ustar-archive)))
(register-archive-type-detector 'detect-ustar-archive)
(defmethod archive-entry-type ((archive ustar-archive) header)
(alexandria:switch ((typeflag header))
(+tar-regular-file+
'file-entry)
(+tar-regular-alternate-file+
'file-entry)
(+tar-hard-link+
'hard-link-entry)
(+tar-symbolic-link+
'symbolic-link-entry)
(+tar-character-device+
'character-device-entry)
(+tar-block-device+
'block-device-entry)
(+tar-directory-file+
'directory-entry)
(+tar-fifo-device+
'fifo-entry)
(+posix-extended-header+
'pax-extended-attributes-entry)
(+posix-global-header+
'pax-global-attributes-entry)
(t
'unknown-entry)))
......@@ -19,3 +19,26 @@
(defmethod archive-header-type ((archive v7-archive))
'v7-header)
(defmethod archive-entry-type ((archive v7-archive) header)
(if (alexandria:ends-with +ascii-/+ (name header))
'directory-entry
(alexandria:switch ((typeflag header))
(+tar-regular-file+
'file-entry)
(+tar-regular-alternate-file+
'file-entry)
(+tar-hard-link+
'hard-link-entry)
(+tar-symbolic-link+
'symbolic-link-entry)
(+tar-character-device+
'character-device-entry)
(+tar-block-device+
'block-device-entry)
(+tar-directory-file+
'directory-entry)
(+tar-fifo-device+
'fifo-entry)
(t
'unknown-entry))))
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