Commit 661c6e48 authored by Eric Timmons's avatar Eric Timmons
Browse files

Misc cleanups

parent 925746c4
......@@ -19,7 +19,8 @@
(defclass archive ()
((direction
:initarg :direction
:reader %archive-direction)
:reader %archive-direction
:type (member :input :output))
(open-archive-p
:initform t
:accessor open-archive-p)
......@@ -32,15 +33,19 @@
:type integer
:initform 0))
(:documentation
"Representation of a tar archive."))
"Base class of a tar archive."))
(defgeneric archive-header-type (archive))
(defgeneric archive-header-type (archive)
(:documentation
"Given an archive, return a symbol naming the header class."))
(defgeneric archive-entry-type (archive header))
(defgeneric archive-entry-type (archive header)
(: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))
"Return an archive. STREAM is the underlying Lisp stream for the archive.
"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))
(let ((blocked-stream (make-instance (ecase direction
......@@ -67,29 +72,19 @@ Further operations on the archive are undefined."
(setf (open-archive-p archive) nil))
t)
(defun read-data-block (archive block-length &optional (pad-func #'identity))
"Read a (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)) array of BLOCK-LENGTH
from ARCHIVE. BLOCK-LENGTH is padded with PAD-FUNC to meet archive
requirements about alignment."
(let* ((length (funcall pad-func block-length))
(buffer (make-array length :element-type '(unsigned-byte 8))))
(with-slots (stream) archive
(read-sequence buffer stream)
(subseq buffer 0 block-length))))
(defun write-data-block (archive block start &optional end)
(write-sequence block (archive-stream archive)
:start start :end (or end (length block))))
(defmethod read-entry-from-archive :before ((archive archive))
(unless (eq (%archive-direction archive) :input)
(error "Attempting to read from a non-input archive")))
(error "Attempting to read from a non-input archive"))
(unless (open-archive-p archive)
(error "Attempting to read from a closed archive")))
(defmethod write-entry-to-archive :before ((archive archive) entry
&key stream)
(declare (ignore stream))
(unless (eq (%archive-direction archive) :output)
(error "Attempting to write to a non-output archive")))
(error "Attempting to write to a non-output archive"))
(unless (open-archive-p archive)
(error "Attempting to write to a closed archive")))
(defmethod write-entry-data ((archive archive) entry stream)
(cond
......
......@@ -7,7 +7,8 @@
(defun call-with-open-archive (thunk pathname &key (direction :input)
(if-exists nil)
(if-does-not-exist nil)
(archive-type :auto))
(archive-type :auto)
(blocking-factor 20))
(when (or (eq direction :io) (eq direction :probe))
(error "Cannot open archives in direction ~A" direction))
(let (archive
......@@ -28,7 +29,8 @@
(when if-does-not-exist
(list :if-does-not-exist if-does-not-exist))))
pathname))
(setf archive (open-archive archive-type stream :direction direction))
(setf archive (open-archive archive-type stream :direction direction
:blocking-factor blocking-factor))
(multiple-value-prog1
(funcall thunk archive)
(setf abort nil)))
......@@ -42,7 +44,9 @@
&key (direction :input)
(if-exists nil)
(if-does-not-exist nil)
(archive-type :auto)) &body body)
(archive-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)
......@@ -50,7 +54,8 @@
:direction ,direction
:if-exists ,if-exists
:if-does-not-exist ,if-does-not-exist
:archive-type ,archive-type))
:archive-type ,archive-type
:blocking-factor ,blocking-factor))
(defmacro do-archive-entries ((entry archive &optional result)
&body body)
......
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