Commit 5774ec2f authored by Eric Timmons's avatar Eric Timmons
Browse files

Checkpoint

parent a21d99d8
......@@ -25,15 +25,17 @@ 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. 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.
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 do this 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 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!).
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
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
......@@ -2,19 +2,19 @@
(in-package #:tar-file)
(defvar *archive-type-detectors* nil
(defvar *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
(defparameter *default-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 register-type-detector (f)
(pushnew f *type-detectors*))
(defun detect-archive-type (buffer)
(or (some (lambda (f) (funcall f buffer)) *archive-type-detectors*)
*default-archive-type*))
(defun detect-type (buffer)
(or (some (lambda (f) (funcall f buffer)) *type-detectors*)
*default-type*))
(defclass archive ()
((direction
......@@ -43,8 +43,8 @@
(:documentation
"Return a symbol naming the class to use to represent the entry for HEADER in ARCHIVE."))
(defun open-archive (archive-type stream &key (direction :input)
(blocking-factor 20))
(defun open-tar-file (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))
......@@ -58,13 +58,13 @@ STREAM should not be read from or written to anymore."
: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)
(make-instance (if (eql type :auto)
(detect-type (read-buffer))
type)
:stream blocked-stream
:direction direction))))
(defun close-archive (archive)
(defun close-tar-file (archive)
"Closes the stream associated with ARCHIVE and the archive itself.
Further operations on the archive are undefined."
(when (open-archive-p archive)
......@@ -126,7 +126,7 @@ Further operations on the archive are undefined."
(defmethod read-entry-from-archive :before ((archive archive))
(unless (file-position (archive-stream archive) (next-entry-start archive))
(error 'simple-archive-error :format-control "Unable to set FILE-POSITION.")))
(error 'simple-tar-file-error :format-control "Unable to set FILE-POSITION.")))
(defmethod read-entry-from-archive ((archive archive))
(let ((start-position (file-position (archive-stream archive)))
......@@ -171,18 +171,6 @@ Further operations on the archive are undefined."
:initial-element 0)
(archive-stream archive))))
(defmethod write-entry-to-archive :before ((archive archive)
(entry entry)
&key stream)
(declare (ignore stream))
(unless (member (typeflag entry) (list +tar-regular-file+
+tar-hard-link+
+tar-symbolic-link+
+tar-directory-file+
+gnutar-long-name+)
:test #'=)
(error 'unhandled-write-entry-error :typeflag (typeflag entry))))
(defmethod finalize-archive ((archive archive))
(let ((null-block (make-array +tar-n-block-bytes+
:element-type '(unsigned-byte 8)
......
......@@ -4,14 +4,14 @@
(in-package #:tar-file)
(define-condition archive-error (error)
(define-condition tar-file-error (error)
()
(:documentation "All errors signaled are of this type."))
(define-condition simple-archive-error (archive-error simple-error)
(define-condition simple-tar-file-error (tar-file-error simple-error)
())
(define-condition invalid-checksum-error (archive-error)
(define-condition invalid-checksum-error (tar-file-error)
((provided :initarg :provided :reader provided)
(computed :initarg :computed :reader computed))
(:report (lambda (condition stream)
......@@ -19,29 +19,5 @@
(provided condition) (computed condition))))
(:documentation "Signaled when the checksum in a tar header is invalid."))
(define-condition unhandled-error (archive-error)
((typeflag :initarg :typeflag :reader typeflag))
(:documentation "Signaled when a tar entry that ARCHIVE doesn't understand is encountered."))
(define-condition unhandled-read-header-error (archive-error)
()
(:report (lambda (condition stream)
(let ((flag (typeflag condition)))
(cond
((= flag +posix-global-header+)
(format stream "Don't understand POSIX extended header entry"))
((= flag +gnutar-sparse+)
(format stream "Don't understand GNU tar sparse entry"))
(t
(format stream "Can't understand typeflag: ~A" flag))))))
(:documentation "Signaled when attempting to parse an unsupported tar entry."))
(define-condition unhandled-write-entry-error (archive-error)
()
(:report (lambda (condition stream)
(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)
(define-condition malformed-pax-attribute-entry (tar-file-error)
())
......@@ -280,12 +280,25 @@
(make-header-forwarder devmajor)
(make-header-forwarder devminor)
(make-header-forwarder prefix)
(make-header-forwarder atime)
(make-header-forwarder ctime)
(make-header-forwarder offset)
(make-header-forwarder offset-sparse-0)
(make-header-forwarder numbytes-sparse-0)
(make-header-forwarder offset-sparse-1)
(make-header-forwarder numbytes-sparse-1)
(make-header-forwarder offset-sparse-2)
(make-header-forwarder numbytes-sparse-2)
(make-header-forwarder offset-sparse-3)
(make-header-forwarder numbytes-sparse-3)
(make-header-forwarder isextended)
(make-header-forwarder realsize)
(defmethod print-object ((entry entry) stream)
(print-unreadable-object (entry stream)
(format stream "Entry ~A" (name entry))))
(defmethod entry-regular-file-p (entry)
(defmethod entry-file-p (entry)
(or (eql (typeflag entry) +tar-regular-file+)
(eql (typeflag entry) +tar-regular-alternate-file+)))
......
......@@ -4,11 +4,11 @@
(in-package #:tar-file)
(defun call-with-open-archive (thunk pathname &key (direction :input)
(if-exists nil)
(if-does-not-exist nil)
(archive-type :auto)
(blocking-factor 20))
(defun call-with-open-tar-file (thunk pathname &key (direction :input)
(if-exists nil)
(if-does-not-exist nil)
(type :auto)
(blocking-factor 20))
(when (or (eq direction :io) (eq direction :probe))
(error "Cannot open archives in direction ~A" direction))
(let (archive
......@@ -29,38 +29,38 @@
(when if-does-not-exist
(list :if-does-not-exist if-does-not-exist))))
pathname))
(setf archive (open-archive archive-type stream :direction direction
:blocking-factor blocking-factor))
(setf archive (open-tar-file type stream :direction direction
:blocking-factor blocking-factor))
(multiple-value-prog1
(funcall thunk archive)
(setf abort nil)))
(when archive
(when (eql direction :output)
(finalize-archive archive))
(close-archive archive)
(close-tar-file archive)
(setf archive nil))
(when should-close
(close stream :abort abort)))))
(defmacro with-open-archive ((archive-var pathname
&key (direction :input)
(if-exists nil)
(if-does-not-exist nil)
(archive-type :auto)
(blocking-factor 20))
&body body)
(defmacro with-open-tar-file ((archive-var pathname
&key (direction :input)
(if-exists nil)
(if-does-not-exist nil)
(type :auto)
(blocking-factor 20))
&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)
,pathname
:direction ,direction
:if-exists ,if-exists
:if-does-not-exist ,if-does-not-exist
:archive-type ,archive-type
:blocking-factor ,blocking-factor))
`(call-with-open-tar-file (lambda (,archive-var) ,@body)
,pathname
:direction ,direction
:if-exists ,if-exists
:if-does-not-exist ,if-does-not-exist
:type ,type
:blocking-factor ,blocking-factor))
(defmacro do-archive-entries ((entry archive &optional result)
&body body)
(defmacro do-entries ((entry archive &optional result)
&body body)
"Iterate over the entries in ARCHIVE. For each entry, ENTRY is bound to
an ARCHIVE-ENTRY representing the entry. RESULT is used as in DOTIMES."
(let ((archive-var (gensym)))
......
......@@ -6,7 +6,7 @@
(defgeneric (setf name) (value entry)
(:documentation "Sets the name of ENTRY to VALUE."))
(defgeneric entry-regular-file-p (entry)
(defgeneric entry-file-p (entry)
(:documentation "Returns T if ENTRY denotes a regular file."))
(defgeneric entry-directory-p (entry)
......@@ -54,5 +54,4 @@ interpreted as in WRITE-ENTRY-TO-ARCHIVE."))
(defgeneric finalize-archive (archive)
(:documentation "Perform any necessary processing for finalizing ARCHIVE.
This function must be called prior to calling CLOSE-ARCHIVE."))
This function must be called prior to calling CLOSE-TAR-FILE."))
......@@ -58,7 +58,7 @@
(subseq buffer offset (+ offset length)))
'gnu-archive)))
(register-archive-type-detector 'detect-gnu-archive)
(register-type-detector 'detect-gnu-archive)
(defmethod archive-entry-type ((archive gnu-archive) header)
(alexandria:switch ((typeflag header))
......
......@@ -2,59 +2,72 @@
(uiop:define-package #:tar-file
(:use :cl)
(:export ;; types
#:archive #:tar-archive
;; creating
#:open-archive #:close-archive
;; conditions
#:archive-error
#:archive-error
#:invalid-checksum-error #:unhandled-error
#:unhandled-read-header-error
#:unhandled-write-entry-error
;; entry slot readers
#:name
#:make-entry-stream
#:size
#:uname
#:gname
#:mode
#:mtime
#:uid
#:gid
#:linkname
#:devmajor
#:devminor
#:attribute
#:write-file-entry
#:write-symbolic-link-entry
#:write-hard-link-entry
#:write-fifo-entry
#:write-block-device-entry
#:write-character-device-entry
;; entry tests
#:entry-directory-p
#:entry-regular-file-p
#:entry-symbolic-link-p
#:entry-hard-link-p
#:entry-character-device-p
#:entry-block-device-p
#:entry-fifo-p
;; reading archives
#:read-entry-from-archive
;; writing archives
#:write-entry-to-archive #:finalize-archive
;; convenience macros
#:do-archive-entries #:with-open-archive
;; external support
#:*default-header-encoding*))
(:export
;; Classes
#:tar-file
#:gnu-tar-file
#:ustar-tar-file
#:v7-tar-file
#:*default-header-encoding*
#:open-tar-file
#:close-tar-file
;; conditions
#:tar-file-error
#:invalid-checksum-error
#:malformed-pax-attribute-entry
#:entry
#:file-entry
#:hard-link-entry
#:symbolic-link-entry
#:character-device-entry
#:block-device-entry
#:directory-entry
#:fifo-entry
#:pax-extended-attributes-entry
#:pax-global-attributes-entry
#:gnu-directory-dump-entry
#:gnu-long-link-name-entry
#:gnu-long-name-entry
#:gnu-sparse-file-entry
#:gnu-volume-header-name-entry
#:unknown-entry
#:entry-has-data-p
#:attribute
#:write-file-entry
#:write-symbolic-link-entry
#:write-hard-link-entry
#:write-fifo-entry
#:write-block-device-entry
#:write-character-device-entry
#:entry-file-p
#:entry-symbolic-link-p
#:entry-hard-link-p
#:entry-fifo-p
#:entry-block-device-p
#:entry-character-device-p
#:with-open-tar-file
#:do-entries
#:name
#:entry-type
#:size
#:uname
#:gname
#:mode
#:mtime
#:uid
#:gid
#:linkname
#:devmajor
#:devminor
#:read-entry-from-archive
#:make-entry-stream))
......@@ -47,7 +47,7 @@
(subseq buffer offset (+ offset length)))
'ustar-archive)))
(register-archive-type-detector 'detect-ustar-archive)
(register-type-detector 'detect-ustar-archive)
(defmethod archive-entry-type ((archive ustar-archive) header)
(alexandria:switch ((typeflag header))
......
;;; -*- mode: lisp -*-
(asdf:defsystem #:tar-file
:version "0.9"
:version "0.10"
:author "Nathan Froyd <froydnj@gmail.com>"
:maintainer "Eric Timmons <eric@timmons.dev>"
:description "A package for reading and writing archive (currently only tar) files."
:description "A package for reading and writing tar files."
:license "BSD-style (http://opensource.org/licenses/BSD-3-Clause)"
:depends-on ("alexandria" "babel" "trivial-gray-streams" "uiop")
:pathname "src"
......@@ -14,35 +14,30 @@
:parachute :status
(uiop:symbol-call :parachute :test :tar-file-test)))
(error "Tests failed")))
:components ((:file "package")
:components ((:file "archive"
:depends-on ("generics" "bounded-stream" "macros"
"external-macros" "entry" "constants"))
(:file "blocked-stream" :depends-on ("package"))
(:file "bounded-stream" :depends-on ("package"))
(:file "buffer-ops" :depends-on ("package" "constants"))
(:file "conditions" :depends-on ("package" "constants"))
(:file "constants" :depends-on ("package"))
(:file "buffer-ops" :depends-on ("package" "constants"))
(:file "utils" :depends-on ("package"))
(:file "entry" :depends-on ("package" "constants"))
(:file "external-macros" :depends-on ("generics"))
(:file "generics" :depends-on ("package"))
(:file "blocked-stream" :depends-on ("package"))
(:file "gnu" :depends-on ("package" "macros" "archive"))
(:file "macros" :depends-on ("generics"))
(:file "external-macros" :depends-on ("generics"))
(:file "package")
(:file "utils" :depends-on ("package"))
(:file "ustar" :depends-on ("package" "macros" "archive"))
(:file "v7" :depends-on ("package" "macros" "archive"))
(:file "gnu" :depends-on ("package" "macros" "archive"))
(:file "entry" :depends-on ("package" "constants"))
(:file "bounded-stream" :depends-on ("package"))
(:file "archive" :depends-on ("generics" "bounded-stream" "macros" "external-macros" "entry" "constants"))))
(defmethod asdf:perform :around ((o asdf:compile-op)
(c (eql (asdf:find-system "tar-file"))))
(let ((use-sb-posix #+(and sbcl (not win32)) t))
(if use-sb-posix
(let ((*features* (cons :use-sb-posix *features*)))
(call-next-method))
(call-next-method))))
(:file "v7" :depends-on ("package" "macros" "archive"))))
(defsystem #:tar-file/test
:pathname "test"
:components ((:file "package")
(:file "blocked-stream" :depends-on ("package"))
(:file "shared" :depends-on ("package"))
:components ((:file "blocked-stream" :depends-on ("package"))
(:file "package")
(:file "read" :depends-on ("package"))
(:file "shared" :depends-on ("package"))
(:file "write" :depends-on ("package")))
:depends-on (#:tar-file #:parachute))
(uiop:define-package #:tar-file-test
(:use #:cl)
(cl:defpackage #:tar-file-test
(:use #:cl)
(:local-nicknames (#:para #:parachute)))
(in-package #:tar-file-test)
(para:define-test read-ustar
(tar-file:with-open-archive (a (asdf:system-relative-pathname
:tar-file "test/ustar.tar"))
(tar-file:with-open-tar-file (a (asdf:system-relative-pathname
:tar-file "test/ustar.tar"))
(let (entry)
;; First entry is a plain file, with the contents "Hello, world!"
(setf entry (tar-file:read-entry-from-archive a))
......@@ -33,8 +33,8 @@
(para:true (null entry)))))
(para:define-test read-pax
(tar-file:with-open-archive (a (asdf:system-relative-pathname
:tar-file "test/pax.tar"))
(tar-file:with-open-tar-file (a (asdf:system-relative-pathname
:tar-file "test/pax.tar"))
(let (entry)
(setf entry (tar-file:read-entry-from-archive a))
(read-a.txt-attr :pax entry)
......@@ -83,8 +83,8 @@
(para:true (null entry)))))
(para:define-test read-gnu
(tar-file:with-open-archive (a (asdf:system-relative-pathname
:tar-file "test/gnu.tar"))
(tar-file:with-open-tar-file (a (asdf:system-relative-pathname
:tar-file "test/gnu.tar"))
(let (entry)
;; First entry is a plain file, with the contents "Hello, world!"
(setf entry (tar-file:read-entry-from-archive a))
......@@ -119,8 +119,8 @@
(para:true (null entry)))))
(para:define-test read-v7
(tar-file:with-open-archive (a (asdf:system-relative-pathname
:tar-file "test/v7.tar"))
(tar-file:with-open-tar-file (a (asdf:system-relative-pathname
:tar-file "test/v7.tar"))
(let (entry)
;; First entry is a plain file, with the contents "Hello, world!"
(setf entry (tar-file:read-entry-from-archive a))
......
......@@ -215,7 +215,7 @@
(para:is equal "root" (tar-file:uname entry))
(para:is equal "root" (tar-file:gname entry)))
(para:is = #o644 (tar-file:mode entry))
(para:true (tar-file:entry-regular-file-p entry))
(para:true (tar-file:entry-file-p entry))
(para:is = *default-mtime* (tar-file:mtime entry))
(para:is = 0 (tar-file:uid entry))
(para:is = 0 (tar-file:gid entry))
......@@ -300,6 +300,9 @@
(para:is = 0 (tar-file:size entry)))
(:pax
(para:is = 512 (tar-file:size entry))))
(when (eql type :gnu)
(para:is = 5242880 (tar-file::offset-sparse-0 entry))
(para:is = 0 (tar-file::numbytes-sparse-0 entry)))
(para:is equal "root" (tar-file:uname entry))
(para:is equal "root" (tar-file:gname entry))
(para:is = #o644 (tar-file:mode entry))
......
......@@ -4,9 +4,9 @@
(uiop:with-temporary-file (:stream s :pathname pn :type "tar" :direction :output
:element-type '(unsigned-byte 8)
:keep *keep-written-archives*)
(tar-file:with-open-archive (a s
:direction :output
:archive-type 'tar-file::ustar-archive)
(tar-file:with-open-tar-file (a s
:direction :output
:type 'tar-file:ustar-archive)
(write-a.txt :ustar a)
(write-a-symlink.txt :ustar a)
......@@ -24,9 +24,9 @@
(uiop:with-temporary-file (:stream s :pathname pn :type "tar" :direction :output
:element-type '(unsigned-byte 8)
:keep *keep-written-archives*)
(tar-file:with-open-archive (a s
:direction :output
:archive-type 'tar-file::v7-archive)
(tar-file:with-open-tar-file (a s
:direction :output
:type 'tar-file:v7-archive)
(write-a.txt :v7 a)
(write-a-symlink.txt :v7 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