Commit 9dd96744 authored by Eric Timmons's avatar Eric Timmons
Browse files

Start on writing entries to archives

parent 661c6e48
......@@ -90,10 +90,17 @@ Further operations on the archive are undefined."
(cond
((typep stream 'stream)
(if (and (subtypep (stream-element-type stream) '(unsigned-byte 8))
(subtypep '(unsigned-byte 8) (stream-element-type stream)))
(subtypep '(unsigned-byte 8) (stream-element-type stream)))
(transfer-stream-to-archive archive stream)
(error "Stream has invalid STREAM-ELEMENT-TYPE ~A"
(stream-element-type stream))))
((typep stream 'pathname)
(with-open-file (stream stream :element-type '(unsigned-byte 8))
(transfer-stream-to-archive archive stream)))
((typep stream 'string)
(transfer-octets-to-archive archive (string-to-bytevec stream :utf-8)))
((typep stream 'vector)
(transfer-octets-to-archive archive stream))
((eq nil stream)
;; do nothing
)
......@@ -156,6 +163,14 @@ Further operations on the archive are undefined."
:initial-element 0)
(archive-stream archive))))
(defun transfer-octets-to-archive (archive octets)
(let* ((rounded-bytes (round-up-to-tar-block (length octets)))
(bytes-remaining (- rounded-bytes (length octets))))
(write-sequence octets (archive-stream archive))
(write-sequence (make-array bytes-remaining :element-type '(unsigned-byte 8)
:initial-element 0)
(archive-stream archive))))
(defmethod write-entry-to-archive :before ((archive archive)
(entry entry)
&key stream)
......
......@@ -201,6 +201,7 @@ the buffer to be written."
sequence start end
&key &allow-other-keys)
(ensure-buffer-valid stream)
(setf (dirty-p stream) t)
(let ((num-bytes (- (or end (length sequence)) start))
(num-bytes-remaining (- (block-size stream) (index stream))))
(replace (buffer stream) sequence
......
......@@ -25,6 +25,29 @@
(:documentation
"A regular file."))
(defun write-file-entry (archive name &rest args &key uname gname mode mtime uid gid size data)
(declare (ignore uname gname mode mtime uid gid))
;; Compute the size when necessary.
(when (null size)
(etypecase data
(vector
(setf size (length data)))
(pathname
(with-open-file (s data :element-type '(unsigned-byte 8))
(setf size (file-length s))))
(stream
(setf size (file-length data))))
(push size args)
(push :size args))
(let ((header (apply #'make-instance (archive-header-type archive)
:name name
:typeflag +tar-regular-file+
(uiop:remove-plist-key :data args)))
(start-position (file-position (archive-stream archive))))
(write-entry-to-archive archive header :stream data)
(make-instance 'file-entry :header header :archive archive :start-position start-position)))
(defclass hard-link-entry (entry)
()
(:documentation
......
......@@ -50,6 +50,8 @@
(unless (= length 1)
(error ":BYTE fields cannot be longer than 1"))
`(aref buffer (+ entry-start ,offset)))
(:bytes
`(subseq buffer (+ entry-start ,offset) (+ entry-start ,offset ,length)))
(:octnum `(read-number-from-buffer buffer :start (+ entry-start ,offset)
:end (+ entry-start ,offset ,length) :radix 8))
(:hexnum `(read-number-from-buffer buffer :start (+ entry-start ,offset)
......@@ -63,6 +65,9 @@
(setf (aref buffer (+ entry-start ,offset i)) (aref thing i)))))
(:byte
`(setf (aref buffer (+ entry-start ,offset)) thing))
(:bytes
`(setf (subseq buffer (+ entry-start ,offset) (+ entry-start ,offset ,length))
thing))
(:octnum
`(let ((start (+ entry-start ,offset))
(end (+ entry-start ,offset ,length)))
......@@ -114,7 +119,8 @@
(write-number-to-buffer checksum buffer
:start checksum-offset
:end (+ checksum-offset
(field-length header 'checksum))
(field-length header 'checksum)
-2)
:radix 8)
;; terminated with a NULL and then a space (!?)
(setf (aref buffer (+ checksum-offset 6)) 0
......
......@@ -31,6 +31,8 @@
#:devminor
#:attribute
#:write-file-entry
;; entry tests
#:entry-directory-p
#:entry-regular-file-p
......
......@@ -24,8 +24,8 @@
(checksum 8 :octnum)
(typeflag 1 :byte)
(linkname 100 :string-null)
(magic 6 :string *ustar-magic-vector*)
(version 2 :string *ustar-version-vector*)
(magic 6 :bytes *ustar-magic-vector*)
(version 2 :bytes *ustar-version-vector*)
;; to be used in preference to uid and gid, of course
(uname 32 :string-null)
(gname 32 :string-null)
......
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