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
a0430bd5
Commit
a0430bd5
authored
Sep 06, 2021
by
Eric Timmons
Browse files
Replace most instances of archive with tar-file and reindent
parent
375a9ec6
Changes
14
Hide whitespace changes
Inline
Side-by-side
src/archive.lisp
View file @
a0430bd5
...
...
@@ -4,10 +4,10 @@
(
defvar
*type-detectors*
nil
"A list of functions, that when called with a header buffer must return a
symbol naming the type of ar
chiv
e that the header belongs to, or NIL."
)
symbol naming the type of
t
ar
-fil
e that the header belongs to, or NIL."
)
(
defparameter
*default-type*
'v7-ar
chiv
e
"The default ar
chiv
e type if no detectors register a hit."
)
(
defparameter
*default-type*
'v7-
t
ar
-fil
e
"The default
t
ar
-fil
e type if no detectors register a hit."
)
(
defun
register-type-detector
(
f
)
(
pushnew
f
*type-detectors*
))
...
...
@@ -16,36 +16,36 @@
(
or
(
some
(
lambda
(
f
)
(
funcall
f
buffer
))
*type-detectors*
)
*default-type*
))
(
defclass
ar
chiv
e
()
(
defclass
t
ar
-fil
e
()
((
direction
:initarg
:direction
:reader
%ar
chiv
e-direction
:reader
%
t
ar
-fil
e-direction
:type
(
member
:input
:output
))
(
open-ar
chiv
e-p
(
open-
t
ar
-fil
e-p
:initform
t
:accessor
open-ar
chiv
e-p
)
:accessor
open-
t
ar
-fil
e-p
)
(
stream
:initarg
:stream
:reader
ar
chiv
e-stream
:reader
t
ar
-fil
e-stream
:type
stream
)
(
next-entry-start
:accessor
next-entry-start
:type
integer
:initform
0
))
(
:documentation
"Base class of a tar ar
chiv
e."
))
"Base class of a tar
t
ar
-fil
e."
))
(
defgeneric
header-type
(
ar
chiv
e
)
(
defgeneric
header-type
(
t
ar
-fil
e
)
(
:documentation
"Given a tar-file, return a symbol naming the header class."
))
(
defgeneric
entry-type
(
ar
chiv
e
header
)
(
defgeneric
entry-type
(
t
ar
-fil
e
header
)
(
:documentation
"Return a symbol naming the class to use to represent the entry for HEADER in AR
CHIV
E."
))
"Return a symbol naming the class to use to represent the entry for HEADER in
T
AR
-FIL
E."
))
(
defun
open-tar-file
(
type
stream
&key
(
direction
:input
)
(
blocking-factor
20
))
"Return an ar
chiv
e. STREAM is the underlying Lisp stream for the ar
chiv
e.
(
blocking-factor
20
))
"Return an
t
ar
-fil
e. STREAM is the underlying Lisp stream for the
t
ar
-fil
e.
STREAM should not be read from or written to anymore."
(
declare
(
type
(
member
:input
:output
)
direction
))
(
let
((
blocked-stream
(
make-instance
(
ecase
direction
...
...
@@ -64,90 +64,90 @@ STREAM should not be read from or written to anymore."
:stream
blocked-stream
:direction
direction
))))
(
defun
close-tar-file
(
ar
chiv
e
)
"Closes the stream associated with AR
CHIV
E and the ar
chiv
e itself.
Further operations on the ar
chiv
e are undefined."
(
when
(
open-ar
chiv
e-p
ar
chiv
e
)
(
close
(
ar
chiv
e-stream
ar
chiv
e
))
(
setf
(
open-ar
chiv
e-p
ar
chiv
e
)
nil
))
(
defun
close-tar-file
(
t
ar
-fil
e
)
"Closes the stream associated with
T
AR
-FIL
E and the
t
ar
-fil
e itself.
Further operations on the
t
ar
-fil
e are undefined."
(
when
(
open-
t
ar
-fil
e-p
t
ar
-fil
e
)
(
close
(
t
ar
-fil
e-stream
t
ar
-fil
e
))
(
setf
(
open-
t
ar
-fil
e-p
t
ar
-fil
e
)
nil
))
t
)
(
defmethod
read-entry
:before
((
ar
chiv
e
ar
chiv
e
))
(
unless
(
eq
(
%ar
chiv
e-direction
ar
chiv
e
)
:input
)
(
error
"Attempting to read from a non-input ar
chiv
e"
))
(
unless
(
open-ar
chiv
e-p
ar
chiv
e
)
(
error
"Attempting to read from a closed ar
chiv
e"
)))
(
defmethod
read-entry
:before
((
t
ar
-fil
e
t
ar
-fil
e
))
(
unless
(
eq
(
%
t
ar
-fil
e-direction
t
ar
-fil
e
)
:input
)
(
error
"Attempting to read from a non-input
t
ar
-fil
e"
))
(
unless
(
open-
t
ar
-fil
e-p
t
ar
-fil
e
)
(
error
"Attempting to read from a closed
t
ar
-fil
e"
)))
(
defmethod
write-entry-to-ar
chiv
e
:before
((
ar
chiv
e
ar
chiv
e
)
entry
&key
stream
)
(
defmethod
write-entry-to-
t
ar
-fil
e
:before
((
t
ar
-fil
e
t
ar
-fil
e
)
entry
&key
stream
)
(
declare
(
ignore
stream
))
(
unless
(
eq
(
%ar
chiv
e-direction
ar
chiv
e
)
:output
)
(
error
"Attempting to write to a non-output ar
chiv
e"
))
(
unless
(
open-ar
chiv
e-p
ar
chiv
e
)
(
error
"Attempting to write to a closed ar
chiv
e"
)))
(
unless
(
eq
(
%
t
ar
-fil
e-direction
t
ar
-fil
e
)
:output
)
(
error
"Attempting to write to a non-output
t
ar
-fil
e"
))
(
unless
(
open-
t
ar
-fil
e-p
t
ar
-fil
e
)
(
error
"Attempting to write to a closed
t
ar
-fil
e"
)))
(
defmethod
write-entry-data
((
ar
chiv
e
ar
chiv
e
)
entry
stream
)
(
defmethod
write-entry-data
((
t
ar
-fil
e
t
ar
-fil
e
)
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-ar
chiv
e
ar
chiv
e
stream
)
(
transfer-stream-to-
t
ar
-fil
e
t
ar
-fil
e
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-ar
chiv
e
ar
chiv
e
stream
)))
(
transfer-stream-to-
t
ar
-fil
e
t
ar
-fil
e
stream
)))
((
typep
stream
'string
)
(
transfer-octets-to-ar
chiv
e
ar
chiv
e
(
string-to-bytevec
stream
:utf-8
)))
(
transfer-octets-to-
t
ar
-fil
e
t
ar
-fil
e
(
string-to-bytevec
stream
:utf-8
)))
((
typep
stream
'vector
)
(
transfer-octets-to-ar
chiv
e
ar
chiv
e
stream
))
(
transfer-octets-to-
t
ar
-fil
e
t
ar
-fil
e
stream
))
((
eq
nil
stream
)
;; do nothing
)
(
t
(
error
"Invalid argument for :STREAM: ~A"
stream
))))
(
defmethod
write-entry-to-ar
chiv
e
((
ar
chiv
e
ar
chiv
e
)
entry
&key
stream
)
(
with-slots
((
ar
chiv
e-stream
stream
))
ar
chiv
e
(
defmethod
write-entry-to-
t
ar
-fil
e
((
t
ar
-fil
e
t
ar
-fil
e
)
entry
&key
stream
)
(
with-slots
((
t
ar
-fil
e-stream
stream
))
t
ar
-fil
e
(
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
ar
chiv
e-stream
))
(
write-sequence
buffer
t
ar
-fil
e-stream
))
;; write any associated data
(
write-entry-data
ar
chiv
e
entry
stream
)
(
write-entry-data
t
ar
-fil
e
entry
stream
)
(
values
)))
;;; providing streamy access for an entry
(
defun
make-stream-for-entry
(
ar
chiv
e
entry
)
(
make-bounded-stream
(
ar
chiv
e-stream
ar
chiv
e
)
(
size
entry
)))
(
defun
make-stream-for-entry
(
t
ar
-fil
e
entry
)
(
make-bounded-stream
(
t
ar
-fil
e-stream
t
ar
-fil
e
)
(
size
entry
)))
(
defmethod
read-entry
:before
((
ar
chiv
e
ar
chiv
e
))
(
unless
(
file-position
(
ar
chiv
e-stream
ar
chiv
e
)
(
next-entry-start
ar
chiv
e
))
(
defmethod
read-entry
:before
((
t
ar
-fil
e
t
ar
-fil
e
))
(
unless
(
file-position
(
t
ar
-fil
e-stream
t
ar
-fil
e
)
(
next-entry-start
t
ar
-fil
e
))
(
error
'simple-tar-file-error
:format-control
"Unable to set FILE-POSITION."
)))
(
defmethod
read-entry
((
ar
chiv
e
ar
chiv
e
))
(
let
((
start-position
(
file-position
(
ar
chiv
e-stream
ar
chiv
e
)))
(
defmethod
read-entry
((
t
ar
-fil
e
t
ar
-fil
e
))
(
let
((
start-position
(
file-position
(
t
ar
-fil
e-stream
t
ar
-fil
e
)))
(
buffer
(
make-array
+tar-n-block-bytes+
:element-type
'
(
unsigned-byte
8
))))
(
declare
(
dynamic-extent
buffer
))
(
with-slots
(
stream
)
ar
chiv
e
(
with-slots
(
stream
)
t
ar
-fil
e
(
let
((
nbytes
(
read-sequence
buffer
stream
)))
(
unless
(
=
nbytes
+tar-n-block-bytes+
)
(
error
"Corrupt ar
chiv
e"
))))
(
error
"Corrupt
t
ar
-fil
e"
))))
(
if
(
null-block-p
buffer
0
)
nil
(
let
((
header
(
read-header-from-buffer
(
header-type
ar
chiv
e
)
buffer
:start
0
)))
(
make-instance
(
entry-type
ar
chiv
e
header
)
:ar
chiv
e
ar
chiv
e
(
let
((
header
(
read-header-from-buffer
(
header-type
t
ar
-fil
e
)
buffer
:start
0
)))
(
make-instance
(
entry-type
t
ar
-fil
e
header
)
:
t
ar
-fil
e
t
ar
-fil
e
:header
header
:start-position
start-position
)))))
(
defmethod
read-entry
:around
((
ar
chiv
e
ar
chiv
e
))
(
defmethod
read-entry
:around
((
t
ar
-fil
e
t
ar
-fil
e
))
(
let
((
entry
(
call-next-method
)))
(
unless
(
null
entry
)
(
setf
(
next-entry-start
ar
chiv
e
)
(
setf
(
next-entry-start
t
ar
-fil
e
)
(
+
(
start-position
entry
)
+tar-n-block-bytes+
(
if
(
entry-has-data-p
entry
)
...
...
@@ -155,27 +155,27 @@ Further operations on the archive are undefined."
0
))))
entry
))
(
defun
transfer-stream-to-ar
chiv
e
(
ar
chiv
e
stream
)
(
let*
((
bytes-copied
(
alexandria:copy-stream
stream
(
ar
chiv
e-stream
ar
chiv
e
)))
(
defun
transfer-stream-to-
t
ar
-fil
e
(
t
ar
-fil
e
stream
)
(
let*
((
bytes-copied
(
alexandria:copy-stream
stream
(
t
ar
-fil
e-stream
t
ar
-fil
e
)))
(
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
)
(
ar
chiv
e-stream
ar
chiv
e
))))
(
t
ar
-fil
e-stream
t
ar
-fil
e
))))
(
defun
transfer-octets-to-ar
chiv
e
(
ar
chiv
e
octets
)
(
defun
transfer-octets-to-
t
ar
-fil
e
(
t
ar
-fil
e
octets
)
(
let*
((
rounded-bytes
(
round-up-to-tar-block
(
length
octets
)))
(
bytes-remaining
(
-
rounded-bytes
(
length
octets
))))
(
write-sequence
octets
(
ar
chiv
e-stream
ar
chiv
e
))
(
write-sequence
octets
(
t
ar
-fil
e-stream
t
ar
-fil
e
))
(
write-sequence
(
make-array
bytes-remaining
:element-type
'
(
unsigned-byte
8
)
:initial-element
0
)
(
ar
chiv
e-stream
ar
chiv
e
))))
(
t
ar
-fil
e-stream
t
ar
-fil
e
))))
(
defmethod
finalize-ar
chiv
e
((
ar
chiv
e
ar
chiv
e
))
(
defmethod
finalize-
t
ar
-fil
e
((
t
ar
-fil
e
t
ar
-fil
e
))
(
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
(
ar
chiv
e-stream
ar
chiv
e
)))
(
write-sequence
null-block
(
t
ar
-fil
e-stream
t
ar
-fil
e
)))
(
values
)))
src/bounded-stream.lisp
View file @
a0430bd5
...
...
@@ -11,7 +11,7 @@
(
defun
make-bounded-stream
(
stream
size
&optional
start-position
)
(
make-instance
'bounded-input-stream
:stream
stream
:bytes
size
:position
(
or
start-position
(
file-position
stream
))))
:position
(
or
start-position
(
file-position
stream
))))
#+
nil
(
defmethod
trivial-gray-streams:stream-element-type
((
stream
bounded-input
stream
))
...
...
src/buffer-ops.lisp
View file @
a0430bd5
...
...
@@ -16,18 +16,18 @@
;; indicated by starting the field with #x80.
(
if
(
=
(
aref
buffer
start
)
#x80
)
(
loop
for
i
from
(
1-
end
)
downto
(
1+
start
)
for
base
=
1
then
(
*
base
256
)
sum
(
*
(
aref
buffer
i
)
base
))
for
base
=
1
then
(
*
base
256
)
sum
(
*
(
aref
buffer
i
)
base
))
(
loop
for
i
from
(
1-
end
)
downto
start
for
base
=
1
then
(
*
base
radix
)
sum
(
let
((
byte
(
aref
buffer
i
)))
(
cond
((
<=
+ascii-zero+
byte
+ascii-nine+
)
(
*
base
(
-
byte
+ascii-zero+
)))
((
<=
+ascii-a+
byte
+ascii-z+
)
(
*
base
(
+
10
(
-
byte
+ascii-a+
))))
(
t
(
error
"Invalid byte: ~A in ~A"
byte
(
subseq
buffer
start
end
)))))))))
for
base
=
1
then
(
*
base
radix
)
sum
(
let
((
byte
(
aref
buffer
i
)))
(
cond
((
<=
+ascii-zero+
byte
+ascii-nine+
)
(
*
base
(
-
byte
+ascii-zero+
)))
((
<=
+ascii-a+
byte
+ascii-z+
)
(
*
base
(
+
10
(
-
byte
+ascii-a+
))))
(
t
(
error
"Invalid byte: ~A in ~A"
byte
(
subseq
buffer
start
end
)))))))))
(
defun
write-number-to-buffer
(
number
buffer
&key
(
start
0
)
end
(
radix
10
)
nullp
)
...
...
src/entry.lisp
View file @
a0430bd5
...
...
@@ -40,77 +40,77 @@
(
push
size
args
)
(
push
:size
args
))
(
let
((
header
(
apply
#'
make-instance
(
header-type
ar
chiv
e
)
(
let
((
header
(
apply
#'
make-instance
(
header-type
t
ar
-fil
e
)
:name
name
:typeflag
(
if
(
typep
ar
chiv
e
'v7-ar
chiv
e
)
:typeflag
(
if
(
typep
t
ar
-fil
e
'v7-
t
ar
-fil
e
)
+tar-regular-alternate-file+
+tar-regular-file+
)
(
uiop:remove-plist-key
:data
args
)))
(
start-position
(
file-position
(
ar
chiv
e-stream
ar
chiv
e
))))
(
write-entry-to-ar
chiv
e
ar
chiv
e
header
:stream
data
)
(
make-instance
'file-entry
:header
header
:ar
chiv
e
ar
chiv
e
:start-position
start-position
)))
(
start-position
(
file-position
(
t
ar
-fil
e-stream
t
ar
-fil
e
))))
(
write-entry-to-
t
ar
-fil
e
t
ar
-fil
e
header
:stream
data
)
(
make-instance
'file-entry
:header
header
:
t
ar
-fil
e
t
ar
-fil
e
:start-position
start-position
)))
(
defclass
hard-link-entry
(
entry
)
()
(
:documentation
"A hard link."
))
(
defun
write-hard-link-entry
(
ar
chiv
e
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
linkname
)
(
defun
write-hard-link-entry
(
t
ar
-fil
e
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
ar
chiv
e
)
(
let
((
header
(
apply
#'
make-instance
(
header-type
t
ar
-fil
e
)
:name
name
:typeflag
+tar-hard-link+
args
))
(
start-position
(
file-position
(
ar
chiv
e-stream
ar
chiv
e
))))
(
write-entry-to-ar
chiv
e
ar
chiv
e
header
)
(
make-instance
'hard-link-entry
:header
header
:ar
chiv
e
ar
chiv
e
:start-position
start-position
)))
(
start-position
(
file-position
(
t
ar
-fil
e-stream
t
ar
-fil
e
))))
(
write-entry-to-
t
ar
-fil
e
t
ar
-fil
e
header
)
(
make-instance
'hard-link-entry
:header
header
:
t
ar
-fil
e
t
ar
-fil
e
:start-position
start-position
)))
(
defclass
symbolic-link-entry
(
entry
)
()
(
:documentation
"A symbolic link."
))
(
defun
write-symbolic-link-entry
(
ar
chiv
e
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
linkname
)
(
defun
write-symbolic-link-entry
(
t
ar
-fil
e
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
ar
chiv
e
)
(
let
((
header
(
apply
#'
make-instance
(
header-type
t
ar
-fil
e
)
:name
name
:typeflag
+tar-symbolic-link+
args
))
(
start-position
(
file-position
(
ar
chiv
e-stream
ar
chiv
e
))))
(
write-entry-to-ar
chiv
e
ar
chiv
e
header
)
(
make-instance
'symbolic-link-entry
:header
header
:ar
chiv
e
ar
chiv
e
:start-position
start-position
)))
(
start-position
(
file-position
(
t
ar
-fil
e-stream
t
ar
-fil
e
))))
(
write-entry-to-
t
ar
-fil
e
t
ar
-fil
e
header
)
(
make-instance
'symbolic-link-entry
:header
header
:
t
ar
-fil
e
t
ar
-fil
e
:start-position
start-position
)))
(
defclass
character-device-entry
(
entry
)
()
(
:documentation
"A character device."
))
(
defun
write-character-device-entry
(
ar
chiv
e
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
devmajor
devminor
)
(
defun
write-character-device-entry
(
t
ar
-fil
e
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
ar
chiv
e
)
(
let
((
header
(
apply
#'
make-instance
(
header-type
t
ar
-fil
e
)
:name
name
:typeflag
+tar-character-device+
args
))
(
start-position
(
file-position
(
ar
chiv
e-stream
ar
chiv
e
))))
(
write-entry-to-ar
chiv
e
ar
chiv
e
header
)
(
make-instance
'character-device-entry
:header
header
:ar
chiv
e
ar
chiv
e
:start-position
start-position
)))
(
start-position
(
file-position
(
t
ar
-fil
e-stream
t
ar
-fil
e
))))
(
write-entry-to-
t
ar
-fil
e
t
ar
-fil
e
header
)
(
make-instance
'character-device-entry
:header
header
:
t
ar
-fil
e
t
ar
-fil
e
:start-position
start-position
)))
(
defclass
block-device-entry
(
entry
)
()
(
:documentation
"A block device."
))
(
defun
write-block-device-entry
(
ar
chiv
e
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
devmajor
devminor
)
(
defun
write-block-device-entry
(
t
ar
-fil
e
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
ar
chiv
e
)
(
let
((
header
(
apply
#'
make-instance
(
header-type
t
ar
-fil
e
)
:name
name
:typeflag
+tar-block-device+
args
))
(
start-position
(
file-position
(
ar
chiv
e-stream
ar
chiv
e
))))
(
write-entry-to-ar
chiv
e
ar
chiv
e
header
)
(
make-instance
'block-device-entry
:header
header
:ar
chiv
e
ar
chiv
e
:start-position
start-position
)))
(
start-position
(
file-position
(
t
ar
-fil
e-stream
t
ar
-fil
e
))))
(
write-entry-to-
t
ar
-fil
e
t
ar
-fil
e
header
)
(
make-instance
'block-device-entry
:header
header
:
t
ar
-fil
e
t
ar
-fil
e
:start-position
start-position
)))
(
defclass
directory-entry
(
entry
)
()
...
...
@@ -122,15 +122,15 @@
(
:documentation
"A FIFO."
))
(
defun
write-fifo-entry
(
ar
chiv
e
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
)
(
defun
write-fifo-entry
(
t
ar
-fil
e
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
ar
chiv
e
)
(
let
((
header
(
apply
#'
make-instance
(
header-type
t
ar
-fil
e
)
:name
name
:typeflag
+tar-fifo-device+
args
))
(
start-position
(
file-position
(
ar
chiv
e-stream
ar
chiv
e
))))
(
write-entry-to-ar
chiv
e
ar
chiv
e
header
)
(
make-instance
'fifo-entry
:header
header
:ar
chiv
e
ar
chiv
e
:start-position
start-position
)))
(
start-position
(
file-position
(
t
ar
-fil
e-stream
t
ar
-fil
e
))))
(
write-entry-to-
t
ar
-fil
e
t
ar
-fil
e
header
)
(
make-instance
'fifo-entry
:header
header
:
t
ar
-fil
e
t
ar
-fil
e
:start-position
start-position
)))
(
defclass
pax-attributes-entry
(
entry
has-data-mixin
)
((
attributes
...
...
@@ -257,7 +257,7 @@
(
defgeneric
make-entry-stream
(
entry
))
(
defmethod
make-entry-stream
((
entry
has-data-mixin
))
(
make-bounded-stream
(
ar
chiv
e-stream
(
entry-ar
chiv
e
entry
))
(
size
entry
)
(
make-bounded-stream
(
t
ar
-fil
e-stream
(
entry-
t
ar
-fil
e
entry
))
(
size
entry
)
(
+
(
start-position
entry
)
+tar-n-block-bytes+
)))
(
defmacro
make-header-forwarder
(
name
)
...
...
src/external-macros.lisp
View file @
a0430bd5
...
...
@@ -10,8 +10,8 @@
(
type
:auto
)
(
blocking-factor
20
))
(
when
(
or
(
eq
direction
:io
)
(
eq
direction
:probe
))
(
error
"Cannot open ar
chiv
es in direction ~A"
direction
))
(
let
(
ar
chiv
e
(
error
"Cannot open
t
ar
-fil
es in direction ~A"
direction
))
(
let
(
t
ar
-fil
e
stream
(
should-close
t
)
(
abort
t
))
...
...
@@ -29,20 +29,20 @@
(
when
if-does-not-exist
(
list
:if-does-not-exist
if-does-not-exist
))))
pathname
))
(
setf
ar
chiv
e
(
open-tar-file
type
stream
:direction
direction
:blocking-factor
blocking-factor
))
(
setf
t
ar
-fil
e
(
open-tar-file
type
stream
:direction
direction
:blocking-factor
blocking-factor
))
(
multiple-value-prog1
(
funcall
thunk
ar
chiv
e
)
(
funcall
thunk
t
ar
-fil
e
)
(
setf
abort
nil
)))
(
when
ar
chiv
e
(
when
t
ar
-fil
e
(
when
(
eql
direction
:output
)
(
finalize-ar
chiv
e
ar
chiv
e
))
(
close-tar-file
ar
chiv
e
)
(
setf
ar
chiv
e
nil
))
(
finalize-
t
ar
-fil
e
t
ar
-fil
e
))
(
close-tar-file
t
ar
-fil
e
)
(
setf
t
ar
-fil
e
nil
))
(
when
should-close
(
close
stream
:abort
abort
)))))
(
defmacro
with-open-tar-file
((
ar
chiv
e-var
pathname
(
defmacro
with-open-tar-file
((
t
ar
-fil
e-var
pathname
&key
(
direction
:input
)
(
if-exists
nil
)
(
if-does-not-exist
nil
)
...
...
@@ -50,8 +50,8 @@
(
blocking-factor
20
))
&body
body
)
(
when
(
or
(
eq
direction
:io
)
(
eq
direction
:probe
))
(
error
"Cannot open ar
chiv
es in direction ~A"
direction
))
`
(
call-with-open-tar-file
(
lambda
(
,
ar
chiv
e-var
)
,@
body
)
(
error
"Cannot open
t
ar
-fil
es in direction ~A"
direction
))
`
(
call-with-open-tar-file
(
lambda
(
,
t
ar
-fil
e-var
)
,@
body
)
,
pathname
:direction
,
direction
:if-exists
,
if-exists
...
...
@@ -59,13 +59,13 @@
:type
,
type
:blocking-factor
,
blocking-factor
))
(
defmacro
do-entries
((
entry
ar
chiv
e
&optional
result
)
(
defmacro
do-entries
((
entry
t
ar
-fil
e
&optional
result
)
&body
body
)
"Iterate over the entries in AR
CHIV
E. For each entry, ENTRY is bound to an
"Iterate over the entries in
T
AR
-FIL
E. For each entry, ENTRY is bound to an
ENTRY representing the entry. RESULT is used as in DOTIMES."
(
let
((
ar
chiv
e-var
(
gensym
)))
`
(
let
((
,
ar
chiv
e-var
,
ar
chiv
e
))
(
do
((
,
entry
(
read-entry
,
ar
chiv
e-var
)
(
read-entry
,
ar
chiv
e-var
)))
((
null
,
entry
)
,
result
)
,@
body
))))
(
let
((
t
ar
-fil
e-var
(
gensym
)))
`
(
let
((
,
t
ar
-fil
e-var
,
t
ar
-fil
e
))
(
do
((
,
entry
(
read-entry
,
t
ar
-fil
e-var
)
(
read-entry
,
t
ar
-fil
e-var
)))
((
null
,
entry
)
,
result
)
,@
body
))))
src/generics.lisp
View file @
a0430bd5
...
...
@@ -27,31 +27,31 @@
;;; reading
(
defgeneric
read-entry
(
ar
chiv
e
)
(
:documentation
"Return the next entry in AR
CHIV
E or NIL if there is no
(
defgeneric
read-entry
(
t
ar
-fil
e
)
(
:documentation
"Return the next entry in
T
AR
-FIL
E or NIL if there is no
next entry"
))
;;; writing
(
defgeneric
write-entry-to-ar
chiv
e
(
ar
chiv
e
entry
&key
stream
)
(
:documentation
"Write ENTRY to AR
CHIV
E. gData associated with ENTRY
is written to AR
CHIV
E according to the :STREAM argument. If :STREAM is
(
defgeneric
write-entry-to-
t
ar
-fil
e
(
t
ar
-fil
e
entry
&key
stream
)
(
:documentation
"Write ENTRY to
T
AR
-FIL
E. gData associated with ENTRY
is written to
T
AR
-FIL
E according to the :STREAM argument. If :STREAM is
T, the expression (NAME ENTRY) is expected to refer to an existing file
from which data may be read. If :STREAM is a stream, then data is read
from that stream and written to AR
CHIV
E. If :STREAM is NIL, then no
from that stream and written to
T
AR
-FIL
E. If :STREAM is NIL, then no
entry data is written."
))
(
defgeneric
write-header-to-buffer
(
header
buffer
&optional
start
)
(
:documentation
"Write the information associated with HEADER into BUFFER,
beginning at position START."
))
(
defgeneric
write-entry-data
(
ar
chiv
e
entry
stream
)
(
defgeneric
write-entry-data
(
t
ar
-fil
e
entry
stream
)
(
:documentation
"Write any data associated with ENTRY, possibly found
in STREAM to AR
CHIV
E; called after WRITE-HEADER-TO-BUFFER. STREAM is
interpreted as in WRITE-ENTRY-TO-AR
CHIV
E."
))
in STREAM to
T
AR
-FIL
E; called after WRITE-HEADER-TO-BUFFER. STREAM is
interpreted as in WRITE-ENTRY-TO-
T
AR
-FIL
E."
))
(
defgeneric
finalize-ar
chiv
e
(
ar
chiv
e
)
(
:documentation
"Perform any necessary processing for finalizing AR
CHIV
E.
(
defgeneric
finalize-
t
ar
-fil
e
(
t
ar
-fil
e
)
(
:documentation
"Perform any necessary processing for finalizing
T
AR
-FIL
E.
This function must be called prior to calling CLOSE-TAR-FILE."
))
src/gnu.lisp
View file @
a0430bd5
;;;; gnu.lisp -- header format for GNU ar
chiv
es
;;;; gnu.lisp -- header format for GNU
t
ar
-fil
es
;;;;
;;;; This is part of tar-file. See README.org and LICENSE for more information.
...
...
@@ -7,14 +7,14 @@
(
defparameter
*gnu-magic-vector*
(
coerce
`
(
,@
(
map
'list
#'
char-code
"ustar "
))
'
(
vector
(
unsigned-byte
8
)))
"The contents of the magic field for gnu ar
chiv
es."
)
"The contents of the magic field for gnu
t
ar
-fil
es."
)
(
defparameter
*gnu-version-vector*
(
coerce
`
(
,@
(
map
'list
#'
char-code
" "
)
0
)
'
(
vector
(
unsigned-byte
8
)))
"The contents of the version field for gnu ar
chiv
es."
)
"The contents of the version field for gnu
t
ar
-fil
es."
)
(
define-octet-header
gnu-header
(
name
100
:string-null
)
(
name
100
:string-null
)
(
mode
8
:octnum
)
(
uid
8
:octnum
)
(
gid
8
:octnum
)
...
...
@@ -46,21 +46,21 @@
(
realsize
12
:octnum
)
(
%%padding
17
:string
))
(
defclass
gnu-ar
chiv
e
(
ar
chiv
e
)
())
(
defclass
gnu-
t
ar
-fil
e
(
t
ar
-fil
e
)
())
(
defmethod
header-type
((
ar
chiv
e
gnu-ar
chiv
e
))
(
defmethod
header-type
((
t
ar
-fil
e
gnu-
t
ar
-fil
e
))
'gnu-header
)
(
defun
detect-gnu-ar
chiv
e
(
buffer
)
(
defun
detect-gnu-
t
ar
-fil
e
(
buffer
)
(
let
((
offset
(
field-offset
'gnu-header
'magic
))
(
length
(
field-length
'gnu-header
'magic
)))
(
when
(
equalp
*gnu-magic-vector*
(
subseq
buffer
offset
(
+
offset
length
)))
'gnu-ar
chiv
e
)))
'gnu-
t
ar
-fil
e
)))
(
register-type-detector
'detect-gnu-ar
chiv
e
)
(
register-type-detector
'detect-gnu-
t
ar
-fil
e
)
(
defmethod
entry-type
((
ar
chiv
e
gnu-ar
chiv
e
)
header
)
(
defmethod
entry-type
((
t
ar
-fil
e
gnu-
t
ar
-fil
e
)
header
)
(
alexandria:switch
((
typeflag
header
))
(
+tar-regular-file+
'file-entry
)
...
...
src/macros.lisp
View file @
a0430bd5
...
...
@@ -13,8 +13,8 @@
&body
body
)
`
(
let
,
(
mapcar
#'
(
lambda
(
field-name
)
`
(
,
field-name
(
,
(
extractor-function-name
entry-class
field-name
)
,
buffer
,
offset
)))
fields
)
,@
body
))
fields
)
,@
body
))
(
defgeneric
field-offset
(
header
field-name
))
...
...
@@ -36,47 +36,47 @@
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
)
(
declare
(
type
(
simple-array
(
unsigned-byte
8
)
(
*
))
buffer
))
,
(
ecase
kind
(
:string
`
(
bytevec-to-string
(
read-bytevec-from-buffer
buffer
:start
(
+
entry-start
,
offset
)
:end
(
+
entry-start
,
offset
,
length
)
:nullp
nil
)))
(
:string-null
`
(
bytevec-to-string
(
read-bytevec-from-buffer
buffer
:start
(
+
entry-start
,
offset
)