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

Add v7 archive and auto detection

parent 40eadca1
......@@ -24,6 +24,7 @@
(:file "macros" :depends-on ("generics"))
(: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 "bounded-stream" :depends-on ("package"))
(:file "archive" :depends-on ("generics" "bounded-stream" "macros" "external-macros" "entry" "constants"))))
......
......@@ -2,6 +2,20 @@
(in-package #:tar)
(defvar *archive-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.")
(defparameter *default-archive-type* 'v7-archive
"The default archive type if no detectors register a hit.")
(defun register-archive-type-detector (f)
(pushnew f *archive-type-detectors*))
(defun detect-archive-type (buffer)
(or (some (lambda (f) (funcall f buffer)) *archive-type-detectors*)
*default-archive-type*))
(defclass archive ()
((entry-buffer
:initarg :entry-buffer
......@@ -15,6 +29,7 @@
:initform t
:accessor open-archive-p)
(stream
:initarg :stream
:reader archive-stream
:type stream)
(next-entry-start
......@@ -26,21 +41,26 @@
(defgeneric archive-header-type (archive))
(defmethod initialize-instance :after ((instance archive)
&key stream direction
(blocking-factor 20))
(setf (slot-value instance 'stream)
(make-instance (ecase direction
(:input 'blocked-input-stream)
(:output 'blocked-output-stream))
:stream stream
:block-size (* +tar-n-block-bytes+ blocking-factor))))
(defun open-archive (archive-type stream &key (direction :input))
(defun open-archive (archive-type stream &key (direction :input)
(blocking-factor 20))
"Return an archive. STREAM is the underlying Lisp stream for the archive.
STREAM should not be read from or written to anymore."
(declare (type (member :input :output) direction))
(make-instance archive-type :stream stream :direction 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 archive-type :auto)
(detect-archive-type (read-buffer))
archive-type)
:stream blocked-stream
:direction direction))))
(defun close-archive (archive)
"Closes the stream associated with ARCHIVE and the archive itself.
......
......@@ -52,7 +52,8 @@
(format stream "Entry ~A" (name entry))))
(defmethod entry-regular-file-p (entry)
(eql (typeflag entry) +tar-regular-file+))
(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+))
......
......@@ -5,7 +5,7 @@
(defun call-with-open-archive (thunk pathname &key (direction :input)
(if-exists nil)
(if-does-not-exist nil)
(archive-type 'ustar-archive))
(archive-type :auto))
(when (or (eq direction :io) (eq direction :probe))
(error "Cannot open archives in direction ~A" direction))
(let (archive
......@@ -37,10 +37,10 @@
(close stream :abort abort)))))
(defmacro with-open-archive ((archive-var pathname
&key (direction :input)
(if-exists nil)
(if-does-not-exist nil)
(archive-type ''ustar-archive)) &body body)
&key (direction :input)
(if-exists nil)
(if-does-not-exist nil)
(archive-type :auto)) &body body)
(when (or (eq direction :io) (eq direction :probe))
(error "Cannot open archives in direction ~A" direction))
`(call-with-open-archive (lambda (,archive-var) ,@body)
......
......@@ -37,3 +37,12 @@
(defmethod archive-header-type ((archive ustar-archive))
'ustar-header)
(defun detect-ustar-archive (buffer)
(let ((offset (field-offset 'ustar-header 'magic))
(length (field-length 'ustar-header 'magic)))
(when (equalp *ustar-magic-vector*
(subseq buffer offset (+ offset length)))
'ustar-archive)))
(register-archive-type-detector 'detect-ustar-archive)
;;;; v7.lisp -- header formts for v7tar
(in-package #:tar)
(define-octet-header v7-header
(name 100 :string-null)
(mode 8 :octnum)
(uid 8 :octnum)
(gid 8 :octnum)
(size 12 :octnum)
(mtime 12 :octnum)
(checksum 8 :octnum)
(typeflag 1 :byte)
(linkname 100 :string-null)
;; not part of the tar format, but it makes defined constants come out right
(%%padding 255 :string))
(defclass v7-archive (archive) ())
(defmethod archive-header-type ((archive v7-archive))
'v7-header)
......@@ -25,3 +25,22 @@
;; 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))
(para:is = (tar:size entry) 14)
(para:is = (tar:mode entry) #o644)
(para:true (tar:entry-regular-file-p entry))
(para:is = (tar:mtime entry) 1628903146)
(para:is = (tar:uid entry) 0)
(para:is = (tar:gid entry) 0)
(para:is equal "Hello, world!
" (contents-as-string entry))
;; End of archive
(setf entry (tar:read-entry-from-archive a))
(para:true (null 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