Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
cl-tar
cl-tar-file
Commits
450d0f1b
Commit
450d0f1b
authored
Sep 06, 2021
by
Eric Timmons
Browse files
Start working on documentation
parent
a0430bd5
Changes
9
Hide whitespace changes
Inline
Side-by-side
README.
org
→
README.
md
View file @
450d0f1b
#+TITLE: Tar File
This project provides functionality to read and write a variety of tar archive
formats. Currently supported are the POSIX ustar, PAX (ustar with a few new
entry types), GNU, and v7 (very old) formats.
...
...
@@ -16,26 +14,25 @@ owners, etc.) and properly separate concerns. Another system will be written
that does the non portable bits and other systems can use tar-file directly if
they have a need to perform low level operations on tar archives.
This project is a fork of [[https://github.com/froydnj/archive][Nathan Froyd's archive library]]. Much code remains,
but the non-portable bits have been stripped, better support for multiple
archive types (and autodetection) has been added, better blocking support added
(tar readers/writers are supposed to read/write in multiples of 512 bytes),
cpio support removed, and a test suite added, along with other miscellaneous
fixes and improvements.
This project is a fork
of
[
Nathan Froyd's archive library
](
https://github.com/froydnj/archive
)
. Much
code remains, but the non-portable bits have been stripped, better support for
multiple archive types (and autodetection) has been added, better blocking
support added (tar readers/writers are supposed to read/write in multiples of
512 bytes), cpio support removed, and a test suite added, along with other
miscellaneous 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
=
under
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 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
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
src/archive.lisp
deleted
100644 → 0
View file @
a0430bd5
;;;; This is part of tar-file. See README.org and LICENSE for more information.
(
in-package
#:tar-file
)
(
defvar
*type-detectors*
nil
"A list of functions, that when called with a header buffer must return a
symbol naming the type of tar-file that the header belongs to, or NIL."
)
(
defparameter
*default-type*
'v7-tar-file
"The default tar-file type if no detectors register a hit."
)
(
defun
register-type-detector
(
f
)
(
pushnew
f
*type-detectors*
))
(
defun
detect-type
(
buffer
)
(
or
(
some
(
lambda
(
f
)
(
funcall
f
buffer
))
*type-detectors*
)
*default-type*
))
(
defclass
tar-file
()
((
direction
:initarg
:direction
:reader
%tar-file-direction
:type
(
member
:input
:output
))
(
open-tar-file-p
:initform
t
:accessor
open-tar-file-p
)
(
stream
:initarg
:stream
:reader
tar-file-stream
:type
stream
)
(
next-entry-start
:accessor
next-entry-start
:type
integer
:initform
0
))
(
:documentation
"Base class of a tar tar-file."
))
(
defgeneric
header-type
(
tar-file
)
(
:documentation
"Given a tar-file, return a symbol naming the header class."
))
(
defgeneric
entry-type
(
tar-file
header
)
(
:documentation
"Return a symbol naming the class to use to represent the entry for HEADER in TAR-FILE."
))
(
defun
open-tar-file
(
type
stream
&key
(
direction
:input
)
(
blocking-factor
20
))
"Return an tar-file. STREAM is the underlying Lisp stream for the tar-file.
STREAM should not be read from or written to anymore."
(
declare
(
type
(
member
:input
:output
)
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
type
:auto
)
(
detect-type
(
read-buffer
))
type
)
:stream
blocked-stream
:direction
direction
))))
(
defun
close-tar-file
(
tar-file
)
"Closes the stream associated with TAR-FILE and the tar-file itself.
Further operations on the tar-file are undefined."
(
when
(
open-tar-file-p
tar-file
)
(
close
(
tar-file-stream
tar-file
))
(
setf
(
open-tar-file-p
tar-file
)
nil
))
t
)
(
defmethod
read-entry
:before
((
tar-file
tar-file
))
(
unless
(
eq
(
%tar-file-direction
tar-file
)
:input
)
(
error
"Attempting to read from a non-input tar-file"
))
(
unless
(
open-tar-file-p
tar-file
)
(
error
"Attempting to read from a closed tar-file"
)))
(
defmethod
write-entry-to-tar-file
:before
((
tar-file
tar-file
)
entry
&key
stream
)
(
declare
(
ignore
stream
))
(
unless
(
eq
(
%tar-file-direction
tar-file
)
:output
)
(
error
"Attempting to write to a non-output tar-file"
))
(
unless
(
open-tar-file-p
tar-file
)
(
error
"Attempting to write to a closed tar-file"
)))
(
defmethod
write-entry-data
((
tar-file
tar-file
)
entry
stream
)
(
cond
((
typep
stream
'stream
)
(
if
(
and
(
subtypep
(
stream-element-type
stream
)
'
(
unsigned-byte
8
))
(
subtypep
'
(
unsigned-byte
8
)
(
stream-element-type
stream
)))
(
transfer-stream-to-tar-file
tar-file
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-tar-file
tar-file
stream
)))
((
typep
stream
'string
)
(
transfer-octets-to-tar-file
tar-file
(
string-to-bytevec
stream
:utf-8
)))
((
typep
stream
'vector
)
(
transfer-octets-to-tar-file
tar-file
stream
))
((
eq
nil
stream
)
;; do nothing
)
(
t
(
error
"Invalid argument for :STREAM: ~A"
stream
))))
(
defmethod
write-entry-to-tar-file
((
tar-file
tar-file
)
entry
&key
stream
)
(
with-slots
((
tar-file-stream
stream
))
tar-file
(
let
((
buffer
(
make-array
+tar-n-block-bytes+
:element-type
'
(
unsigned-byte
8
))))
(
declare
(
dynamic-extent
buffer
))
;; write the entry
(
write-header-to-buffer
entry
buffer
0
)
(
write-sequence
buffer
tar-file-stream
))
;; write any associated data
(
write-entry-data
tar-file
entry
stream
)
(
values
)))
;;; providing streamy access for an entry
(
defun
make-stream-for-entry
(
tar-file
entry
)
(
make-bounded-stream
(
tar-file-stream
tar-file
)
(
size
entry
)))
(
defmethod
read-entry
:before
((
tar-file
tar-file
))
(
unless
(
file-position
(
tar-file-stream
tar-file
)
(
next-entry-start
tar-file
))
(
error
'simple-tar-file-error
:format-control
"Unable to set FILE-POSITION."
)))
(
defmethod
read-entry
((
tar-file
tar-file
))
(
let
((
start-position
(
file-position
(
tar-file-stream
tar-file
)))
(
buffer
(
make-array
+tar-n-block-bytes+
:element-type
'
(
unsigned-byte
8
))))
(
declare
(
dynamic-extent
buffer
))
(
with-slots
(
stream
)
tar-file
(
let
((
nbytes
(
read-sequence
buffer
stream
)))
(
unless
(
=
nbytes
+tar-n-block-bytes+
)
(
error
"Corrupt tar-file"
))))
(
if
(
null-block-p
buffer
0
)
nil
(
let
((
header
(
read-header-from-buffer
(
header-type
tar-file
)
buffer
:start
0
)))
(
make-instance
(
entry-type
tar-file
header
)
:tar-file
tar-file
:header
header
:start-position
start-position
)))))
(
defmethod
read-entry
:around
((
tar-file
tar-file
))
(
let
((
entry
(
call-next-method
)))
(
unless
(
null
entry
)
(
setf
(
next-entry-start
tar-file
)
(
+
(
start-position
entry
)
+tar-n-block-bytes+
(
if
(
entry-has-data-p
entry
)
(
round-up-to-tar-block
(
size
entry
))
0
))))
entry
))
(
defun
transfer-stream-to-tar-file
(
tar-file
stream
)
(
let*
((
bytes-copied
(
alexandria:copy-stream
stream
(
tar-file-stream
tar-file
)))
(
rounded-bytes
(
round-up-to-tar-block
bytes-copied
))
(
bytes-remaining
(
-
rounded-bytes
bytes-copied
)))
(
write-sequence
(
make-array
bytes-remaining
:element-type
'
(
unsigned-byte
8
)
:initial-element
0
)
(
tar-file-stream
tar-file
))))
(
defun
transfer-octets-to-tar-file
(
tar-file
octets
)
(
let*
((
rounded-bytes
(
round-up-to-tar-block
(
length
octets
)))
(
bytes-remaining
(
-
rounded-bytes
(
length
octets
))))
(
write-sequence
octets
(
tar-file-stream
tar-file
))
(
write-sequence
(
make-array
bytes-remaining
:element-type
'
(
unsigned-byte
8
)
:initial-element
0
)
(
tar-file-stream
tar-file
))))
(
defmethod
finalize-tar-file
((
tar-file
tar-file
))
(
let
((
null-block
(
make-array
+tar-n-block-bytes+
:element-type
'
(
unsigned-byte
8
)
:initial-element
0
)))
(
declare
(
dynamic-extent
null-block
))
(
dotimes
(
i
2
)
(
write-sequence
null-block
(
tar-file-stream
tar-file
)))
(
values
)))
src/entry.lisp
View file @
450d0f1b
...
...
@@ -25,7 +25,7 @@
(
:documentation
"A regular file."
))
(
def
un
write-file-entry
(
tar-file
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
size
data
)
(
def
method
write-file-entry
(
tar-file
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
)
...
...
@@ -55,7 +55,7 @@
(
:documentation
"A hard link."
))
(
def
un
write-hard-link-entry
(
tar-file
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
linkname
)
(
def
method
write-hard-link-entry
(
tar-file
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
linkname
)
(
declare
(
ignore
uname
gname
mode
mtime
uid
gid
linkname
))
(
let
((
header
(
apply
#'
make-instance
(
header-type
tar-file
)
:name
name
...
...
@@ -70,7 +70,7 @@
(
:documentation
"A symbolic link."
))
(
def
un
write-symbolic-link-entry
(
tar-file
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
linkname
)
(
def
method
write-symbolic-link-entry
(
tar-file
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
linkname
)
(
declare
(
ignore
uname
gname
mode
mtime
uid
gid
linkname
))
(
let
((
header
(
apply
#'
make-instance
(
header-type
tar-file
)
:name
name
...
...
@@ -85,8 +85,8 @@
(
:documentation
"A character device."
))
(
def
un
write-character-device-entry
(
tar-file
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
devmajor
devminor
)
(
def
method
write-character-device-entry
(
tar-file
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
devmajor
devminor
)
(
declare
(
ignore
uname
gname
mode
mtime
uid
gid
devmajor
devminor
))
(
let
((
header
(
apply
#'
make-instance
(
header-type
tar-file
)
:name
name
...
...
@@ -101,8 +101,8 @@
(
:documentation
"A block device."
))
(
def
un
write-block-device-entry
(
tar-file
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
devmajor
devminor
)
(
def
method
write-block-device-entry
(
tar-file
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
devmajor
devminor
)
(
declare
(
ignore
uname
gname
mode
mtime
uid
gid
devmajor
devminor
))
(
let
((
header
(
apply
#'
make-instance
(
header-type
tar-file
)
:name
name
...
...
@@ -117,12 +117,22 @@
(
:documentation
"A directory."
))
(
defmethod
write-directory-entry
(
tar-file
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
size
)
(
declare
(
ignore
uname
gname
mode
mtime
uid
gid
size
))
(
let
((
header
(
apply
#'
make-instance
(
header-type
tar-file
)
:name
name
:typeflag
+tar-directory-file+
args
))
(
start-position
(
file-position
(
tar-file-stream
tar-file
))))
(
write-entry-to-tar-file
tar-file
header
)
(
make-instance
'directory-entry
:header
header
:tar-file
tar-file
:start-position
start-position
)))
(
defclass
fifo-entry
(
entry
)
()
(
:documentation
"A FIFO."
))
(
def
un
write-fifo-entry
(
tar-file
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
)
(
def
method
write-fifo-entry
(
tar-file
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
)
(
declare
(
ignore
uname
gname
mode
mtime
uid
gid
))
(
let
((
header
(
apply
#'
make-instance
(
header-type
tar-file
)
:name
name
...
...
@@ -166,7 +176,8 @@
:collect
byte
)))
(
if
(
eql
bytes
:eof
)
:eof
(
values
(
parse-integer
(
bytevec-to-string
(
coerce
bytes
'
(
vector
(
unsigned-byte
8
)))))
(
values
(
parse-integer
(
bytevec-to-string
(
coerce
bytes
'
(
vector
(
unsigned-byte
8
)))
:utf-8
))
bytes-read
))))
(
defun
read-attribute
(
stream
)
...
...
@@ -181,7 +192,7 @@
(
setf
num-read
(
read-sequence
buffer
stream
))
(
unless
(
=
num-read
(
-
num-bytes
bytes-read
))
(
error
'malformed-pax-attribute-entry
))
(
setf
kv-string
(
bytevec-to-string
buffer
))
(
setf
kv-string
(
bytevec-to-string
buffer
:utf-8
))
(
unless
(
=
(
aref
buffer
(
1-
num-read
))
+ascii-newline+
)
(
error
'malformed-pax-attribute-entry
))
(
setf
=-position
(
position
#\=
kv-string
))
...
...
@@ -209,14 +220,43 @@
(
:documentation
"Extended attributes for the subsequent record."
))
(
defmethod
write-pax-extended-attributes-entry
(
tar-file
name
&rest
args
)
;; (let ((header (apply #'make-instance (header-type tar-file)
;; :name name
;; :typeflag +tar-directory-file+
;; args))
;; (start-position (file-position (tar-file-stream tar-file))))
;; (write-entry-to-tar-file tar-file header)
;; (make-instance 'directory-entry :header header :tar-file tar-file :start-position start-position))
)
(
defmethod
entry-pax-extended-attributes-p
((
entry
pax-extended-attributes-entry
))
t
)
(
defclass
pax-global-attributes-entry
(
pax-attributes-entry
)
()
(
:documentation
"Extended attributes for all subsequent records."
))
(
defmethod
write-pax-global-attributes-entry
(
tar-file
name
&rest
args
)
;; (let ((header (apply #'make-instance (header-type tar-file)
;; :name name
;; :typeflag +tar-directory-file+
;; args))
;; (start-position (file-position (tar-file-stream tar-file))))
;; (write-entry-to-tar-file tar-file header)
;; (make-instance 'directory-entry :header header :tar-file tar-file :start-position start-position))
)
(
defmethod
entry-pax-global-attributes-p
((
entry
pax-global-attributes-entry
))
t
)
(
defclass
gnu-directory-dump-entry
(
entry
has-data-mixin
)
())
(
defmethod
entry-gnu-directory-dump-p
((
entry
gnu-directory-dump-entry
))
t
)
(
defclass
gnu-long-link-name-entry
(
entry
has-data-mixin
)
((
long-link-name
:accessor
long-link-name
)))
...
...
@@ -228,6 +268,19 @@
(
read-sequence
buffer
stream
)
(
setf
(
long-link-name
entry
)
(
bytevec-to-string
buffer
:utf-8
))))
(
defmethod
write-gnu-long-link-name-entry
(
tar-file
name
&rest
args
)
;; (let ((header (apply #'make-instance (header-type tar-file)
;; :name name
;; :typeflag +tar-directory-file+
;; args))
;; (start-position (file-position (tar-file-stream tar-file))))
;; (write-entry-to-tar-file tar-file header)
;; (make-instance 'directory-entry :header header :tar-file tar-file :start-position start-position))
)
(
defmethod
entry-gnu-long-link-name-p
((
entry
gnu-long-link-name-entry
))
t
)
(
defclass
gnu-long-name-entry
(
entry
has-data-mixin
)
((
long-name
:accessor
long-name
)))
...
...
@@ -239,17 +292,39 @@
(
read-sequence
buffer
stream
)
(
setf
(
long-name
entry
)
(
bytevec-to-string
buffer
:utf-8
))))
(
defmethod
write-gnu-long-name-entry
(
tar-file
name
&rest
args
)
;; (let ((header (apply #'make-instance (header-type tar-file)
;; :name name
;; :typeflag +tar-directory-file+
;; args))
;; (start-position (file-position (tar-file-stream tar-file))))
;; (write-entry-to-tar-file tar-file header)
;; (make-instance 'directory-entry :header header :tar-file tar-file :start-position start-position))
)
(
defmethod
entry-gnu-long-name-p
((
entry
gnu-long-name-entry
))
t
)
(
defclass
gnu-sparse-file-entry
(
entry
has-data-mixin
)
())
(
defmethod
entry-gnu-sparse-file-p
((
entry
gnu-sparse-file-entry
))
t
)
(
defclass
gnu-volume-header-name-entry
(
entry
)
())
(
defmethod
entry-gnu-volume-header-name-p
((
entry
gnu-volume-header-name-entry
))
t
)
(
defclass
unknown-entry
(
entry
has-data-mixin
)
()
(
:documentation
"An unknown entry."
))
(
defmethod
entry-unknown-p
((
entry
unknown-entry
))
t
)
(
defgeneric
entry-has-data-p
(
entry
)
(
:method
(
entry
)
nil
)
(
:method
((
entry
has-data-mixin
))
t
))
...
...
src/external-macros.lisp
View file @
450d0f1b
...
...
@@ -4,11 +4,13 @@
(
in-package
#:tar-file
)
(
defun
call-with-open-tar-file
(
thunk
pathname
&key
(
direction
:input
)
(
if-exists
nil
)
(
if-does-not-exist
nil
)
(
type
:auto
)
(
blocking-factor
20
))
(
defun
call-with-open-tar-file
(
thunk
pathname-or-stream
&key
(
direction
:input
)
(
if-exists
nil
)
(
if-does-not-exist
nil
)
(
type
:auto
)
(
blocking-factor
20
)
(
header-encoding
*default-header-encoding*
))
(
when
(
or
(
eq
direction
:io
)
(
eq
direction
:probe
))
(
error
"Cannot open tar-files in direction ~A"
direction
))
(
let
(
tar-file
...
...
@@ -17,10 +19,10 @@
(
abort
t
))
(
unwind-protect
(
progn
(
when
(
streamp
pathname
)
(
setf
should-close
nil
))
(
when
(
streamp
pathname
-or-stream
)
(
setf
should-close
nil
))
(
setf
stream
(
if
should-close
(
apply
#'
open
pathname
pathname
-or-stream
:direction
direction
:element-type
'
(
unsigned-byte
8
)
(
append
...
...
@@ -28,9 +30,11 @@
(
list
:if-exists
if-exists
))
(
when
if-does-not-exist
(
list
:if-does-not-exist
if-does-not-exist
))))
pathname
))
(
setf
tar-file
(
open-tar-file
type
stream
:direction
direction
:blocking-factor
blocking-factor
))
pathname-or-stream
))
(
setf
tar-file
(
open-tar-file
stream
:direction
direction
:type
type
:blocking-factor
blocking-factor
:header-encoding
header-encoding
))
(
multiple-value-prog1
(
funcall
thunk
tar-file
)
(
setf
abort
nil
)))
...
...
@@ -42,22 +46,35 @@
(
when
should-close
(
close
stream
:abort
abort
)))))
(
defmacro
with-open-tar-file
((
tar-file-var
pathname
(
defmacro
with-open-tar-file
((
tar-file-var
pathname
-or-stream
&key
(
direction
:input
)
(
if-exists
nil
)
(
if-does-not-exist
nil
)
(
type
:auto
)
(
blocking-factor
20
))
(
blocking-factor
20
)
(
header-encoding
'*default-header-encoding*
))
&body
body
)
"Bind TAR-FILE-VAR to a newly opened TAR-FILE, backed by
PATHNAME-OR-STREAM. If PATHNAME-OR-STREAM evaluates to a stream, that stream is
used directly, otherwise, it is opened via OPEN. If PATHNAME-OR-STREAM is a
stream, that stream is not closed upon exiting the body of the macro.
DIRECTION must be either :INPUT or :OUTPUT.
IF-EXISTS and IF-DOES-NOT-EXIST are passed to OPEN if PATHNAME-OR-STREAM is not
a stream.
See OPEN-TAR-FILE for a description of TYPE, BLOCKING-FACTOR, and HEADER-ENCODING."
(
when
(
or
(
eq
direction
:io
)
(
eq
direction
:probe
))
(
error
"Cannot open tar-files in direction ~A"
direction
))
`
(
call-with-open-tar-file
(
lambda
(
,
tar-file-var
)
,@
body
)
,
pathname
,
pathname
-or-stream
:direction
,
direction
:if-exists
,
if-exists
:if-does-not-exist
,
if-does-not-exist
:type
,
type
:blocking-factor
,
blocking-factor
))
:blocking-factor
,
blocking-factor
:header-encoding
,
header-encoding
))
(
defmacro
do-entries
((
entry
tar-file
&optional
result
)
&body
body
)
...
...
src/generics.lisp
View file @
450d0f1b
...
...
@@ -2,6 +2,13 @@
(
in-package
#:tar-file
)
(
defgeneric
close-tar-file
(
tar-file
)
(
:documentation
"Closes the stream associated with TAR-FILE and the tar-file itself.
Further operations on the tar-file are undefined.
Does NOT close the underlying STREAM that backed the TAR-FILE."
))
(
defgeneric
(
setf
name
)
(
value
entry
)
(
:documentation
"Sets the name of ENTRY to VALUE."
))
...
...
@@ -43,7 +50,7 @@ from which data may be read. If :STREAM is a stream, then data is read
from that stream and written to TAR-FILE. If :STREAM is NIL, then no
entry data is written."
))
(
defgeneric
write-header-to-buffer
(
header
buffer
&optional
start
)
(
defgeneric
write-header-to-buffer
(
header
buffer
encoding
&optional
start
)
(
:documentation
"Write the information associated with HEADER into BUFFER,
beginning at position START."
))
...
...
src/macros.lisp
View file @
450d0f1b
...
...
@@ -9,13 +9,6 @@
(
defun
injector-function-name
(
entry-name
field-name
)
(
intern
(
with-standard-io-syntax
(
format
nil
"~A-WRITE-~A-TO-BUFFER"
entry-name
field-name
))))
(
defmacro
with-extracted-fields
((
entry-class
buffer
offset
&rest
fields
)
&body
body
)
`
(
let
,
(
mapcar
#'
(
lambda
(
field-name
)
`
(
,
field-name
(
,
(
extractor-function-name
entry-class
field-name
)
,
buffer
,
offset
)))
fields
)
,@
body
))
(
defgeneric
field-offset
(
header
field-name
))
(
defgeneric
field-length
(
header
field-name
))
...
...
@@ -35,17 +28,20 @@
,
length
)
into
length-defs
collect
`
(
defmethod
field-length
((
header
(
eql
',class-name
))
(
field-name
(
eql
',name
)))
,
length
)
into
length-defs
collect
`
(
defun
,
(
extractor-function-name
class-name
name
)
(
buffer
entry-start
)
collect
`
(
defun
,
(
extractor-function-name
class-name
name
)
(
buffer
entry-start
encoding
)
(
declare
(
type
(
simple-array
(
unsigned-byte
8
)
(
*
))
buffer
))
(
declare
(
ignorable
encoding
))
,
(
ecase
kind
(
:string
`
(
bytevec-to-string
(
read-bytevec-from-buffer
buffer
:start
(
+
entry-start
,
offset
)
:end
(
+
entry-start
,
offset
,
length
)
:nullp
nil
)))
:end
(
+
entry-start
,
offset
,
length
)
:nullp
nil
)
encoding
))
(
:string-null
`
(
bytevec-to-string
(
read-bytevec-from-buffer
buffer
:start
(
+
entry-start
,
offset
)
:end
(
+
entry-start
,
offset
,
length
)
:nullp
t
)))
:end
(
+
entry-start
,
offset
,
length
)
:nullp
t
)
encoding
))
(
:byte
(
unless
(
=
length
1
)
(
error
":BYTE fields cannot be longer than 1"
))
...
...
@@ -56,11 +52,12 @@
:end
(
+
entry-start
,
offset
,
length
)
:radix
8
))
(
:hexnum
`
(
read-number-from-buffer
buffer
:start
(
+
entry-start
,
offset
)
:end
(
+
entry-start
,
offset
,
length
)
:radix
16
))))
into
reader-defs
collect
`
(
defun
,
(
injector-function-name
class-name
name
)
(
buffer
entry-start
thing
)
collect
`
(
defun
,
(
injector-function-name
class-name
name
)
(
buffer
entry-start
thing
encoding
)
(
declare
(
type
(
simple-array
(
unsigned-byte
8
)
(
*
))
buffer
))
(
declare
(
ignorable
encoding
))
,
(
ecase
kind
((
:string
:string-null
)
`
(
let
((
thing
(
string-to-bytevec
thing
)))
`
(
let
((
thing
(
string-to-bytevec
thing
encoding
)))
(
dotimes
(
i
(
length
thing
)
(
values
))
(
setf
(
aref
buffer
(
+
entry-start
,
offset
i
))
(
aref
thing
i
)))))
(
:byte
...
...
@@ -99,7 +96,7 @@
,
offset
)
(
defmethod
header-length
((
header
(
eql
',class-name
)))
,
offset
)
(
defmethod
write-header-to-buffer
((
header
,
class-name
)
buffer
&optional
(
start
0
))
(
defmethod
write-header-to-buffer
((
header
,
class-name
)
buffer
encoding
&optional
(
start
0
))
(
declare
(
type
(
simple-array
(
unsigned-byte
8
)
(
*
))
buffer
))
;; Ensure we can write the entire header to this
...
...
@@ -111,7 +108,8 @@
,@
(
loop
:for
(
name
length
kind
)
:in
field-defs
:unless
(
eql
name
'checksum
)
:collect
`
(
,
(
injector-function-name
class-name
name
)
buffer
start
(
,
name
header
)))
:collect
`
(
,
(
injector-function-name
class-name
name
)
buffer
start
(
,
name
header
)
encoding
))
;; Write the checksum
(
let*
((
checksum
(
compute-checksum-for-tar-header
header
buffer
start
))
...
...
@@ -125,8 +123,8 @@
;; terminated with a NULL and then a space (!?)
(
setf
(
aref
buffer
(
+
checksum-offset
6
))
0
(
aref
buffer
(
+
checksum-offset
7
))
+ascii-space+
)))
(
defmethod
read-header-from-buffer
((
header
(
eql
',class-name
))
buffer
&key
(
start
0
))
(
let
((
checksum
(
,
(
extractor-function-name
class-name
'checksum
)
buffer
start
)))
(
defmethod
read-header-from-buffer
((
header
(
eql
',class-name
))
buffer
encoding
&key
(
start
0
))
(
let
((
checksum
(
,
(
extractor-function-name
class-name
'checksum
)
buffer
start
encoding
)))
(
multiple-value-bind
(
validp
computed
)
(
tar-block-checksum-matches-p
header
buffer
checksum
start
)
(
unless
validp
...
...
@@ -138,4 +136,4 @@
:unless
(
eql
name
'%%padding
)
:appending
`
(
,
(
keywordify-name
name
)
(
,
(
extractor-function-name
class-name
name
)
buffer
start
)))))))))))))
buffer
start
encoding
)))))))))))))
src/package.lisp
View file @
450d0f1b
...
...
@@ -44,6 +44,11 @@
#:write-fifo-entry
#:write-block-device-entry
#:write-character-device-entry