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
baf2492c
Commit
baf2492c
authored
Aug 15, 2021
by
Eric Timmons
Browse files
Add v7 archive and auto detection
parent
40eadca1
Changes
7
Hide whitespace changes
Inline
Side-by-side
cl-tar.asd
View file @
baf2492c
...
...
@@ -24,6 +24,7 @@
(
:file
"macros"
:depends-on
(
"generics"
))
(
:file
"external-macros"
:depends-on
(
"generics"
))
(
:file
"ustar"
:depends-on
(
"package"
"macros"
"archive"
))
(
:file
"v7"
:depends-on
(
"package"
"macros"
"archive"
))
(
:file
"entry"
:depends-on
(
"package"
))
(
:file
"bounded-stream"
:depends-on
(
"package"
))
(
:file
"archive"
:depends-on
(
"generics"
"bounded-stream"
"macros"
"external-macros"
"entry"
"constants"
))))
...
...
src/archive.lisp
View file @
baf2492c
...
...
@@ -2,6 +2,20 @@
(
in-package
#:tar
)
(
defvar
*archive-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
"The default archive type if no detectors register a hit."
)
(
defun
register-archive-type-detector
(
f
)
(
pushnew
f
*archive-type-detectors*
))
(
defun
detect-archive-type
(
buffer
)
(
or
(
some
(
lambda
(
f
)
(
funcall
f
buffer
))
*archive-type-detectors*
)
*default-archive-type*
))
(
defclass
archive
()
((
entry-buffer
:initarg
:entry-buffer
...
...
@@ -15,6 +29,7 @@
:initform
t
:accessor
open-archive-p
)
(
stream
:initarg
:stream
:reader
archive-stream
:type
stream
)
(
next-entry-start
...
...
@@ -26,21 +41,26 @@
(
defgeneric
archive-header-type
(
archive
))
(
defmethod
initialize-instance
:after
((
instance
archive
)
&key
stream
direction
(
blocking-factor
20
))
(
setf
(
slot-value
instance
'stream
)
(
make-instance
(
ecase
direction
(
:input
'blocked-input-stream
)
(
:output
'blocked-output-stream
))
:stream
stream
:block-size
(
*
+tar-n-block-bytes+
blocking-factor
))))
(
defun
open-archive
(
archive-type
stream
&key
(
direction
:input
))
(
defun
open-archive
(
archive-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
))
(
make-instance
archive-type
:stream
stream
:direction
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
archive-type
:auto
)
(
detect-archive-type
(
read-buffer
))
archive-type
)
:stream
blocked-stream
:direction
direction
))))
(
defun
close-archive
(
archive
)
"Closes the stream associated with ARCHIVE and the archive itself.
...
...
src/entry.lisp
View file @
baf2492c
...
...
@@ -52,7 +52,8 @@
(
format
stream
"Entry ~A"
(
name
entry
))))
(
defmethod
entry-regular-file-p
(
entry
)
(
eql
(
typeflag
entry
)
+tar-regular-file+
))
(
or
(
eql
(
typeflag
entry
)
+tar-regular-file+
)
(
eql
(
typeflag
entry
)
+tar-regular-alternate-file+
)))
(
defmethod
entry-directory-p
(
entry
)
(
eql
(
typeflag
entry
)
+tar-directory-file+
))
...
...
src/external-macros.lisp
View file @
baf2492c
...
...
@@ -5,7 +5,7 @@
(
defun
call-with-open-archive
(
thunk
pathname
&key
(
direction
:input
)
(
if-exists
nil
)
(
if-does-not-exist
nil
)
(
archive-type
'ustar-archive
))
(
archive-type
:auto
))
(
when
(
or
(
eq
direction
:io
)
(
eq
direction
:probe
))
(
error
"Cannot open archives in direction ~A"
direction
))
(
let
(
archive
...
...
@@ -37,10 +37,10 @@
(
close
stream
:abort
abort
)))))
(
defmacro
with-open-archive
((
archive-var
pathname
&key
(
direction
:input
)
(
if-exists
nil
)
(
if-does-not-exist
nil
)
(
archive-type
'
'ustar-archive
))
&body
body
)
&key
(
direction
:input
)
(
if-exists
nil
)
(
if-does-not-exist
nil
)
(
archive-type
:auto
))
&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
)
...
...
src/ustar.lisp
View file @
baf2492c
...
...
@@ -37,3 +37,12 @@
(
defmethod
archive-header-type
((
archive
ustar-archive
))
'ustar-header
)
(
defun
detect-ustar-archive
(
buffer
)
(
let
((
offset
(
field-offset
'ustar-header
'magic
))
(
length
(
field-length
'ustar-header
'magic
)))
(
when
(
equalp
*ustar-magic-vector*
(
subseq
buffer
offset
(
+
offset
length
)))
'ustar-archive
)))
(
register-archive-type-detector
'detect-ustar-archive
)
src/v7.lisp
0 → 100644
View file @
baf2492c
;;;; v7.lisp -- header formts for v7tar
(
in-package
#:tar
)
(
define-octet-header
v7-header
(
name
100
:string-null
)
(
mode
8
:octnum
)
(
uid
8
:octnum
)
(
gid
8
:octnum
)
(
size
12
:octnum
)
(
mtime
12
:octnum
)
(
checksum
8
:octnum
)
(
typeflag
1
:byte
)
(
linkname
100
:string-null
)
;; not part of the tar format, but it makes defined constants come out right
(
%%padding
255
:string
))
(
defclass
v7-archive
(
archive
)
())
(
defmethod
archive-header-type
((
archive
v7-archive
))
'v7-header
)
test/tar.lisp
View file @
baf2492c
...
...
@@ -25,3 +25,22 @@
;; End of archive
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
para:true
(
null
entry
)))))
(
para:define-test
read-v7
(
tar:with-open-archive
(
a
(
asdf:system-relative-pathname
:cl-tar
"test/v7.tar"
))
(
let
(
entry
)
;; First entry is a plain file, with the contents "Hello, world!"
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
para:is
=
(
tar:size
entry
)
14
)
(
para:is
=
(
tar:mode
entry
)
#o644
)
(
para:true
(
tar:entry-regular-file-p
entry
))
(
para:is
=
(
tar:mtime
entry
)
1628903146
)
(
para:is
=
(
tar:uid
entry
)
0
)
(
para:is
=
(
tar:gid
entry
)
0
)
(
para:is
equal
"Hello, world!
"
(
contents-as-string
entry
))
;; End of archive
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
para:true
(
null
entry
)))))
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment