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
f29671cb
Commit
f29671cb
authored
Aug 16, 2021
by
Eric Timmons
Browse files
Add PAX header parsing and tests
parent
151da6da
Changes
8
Hide whitespace changes
Inline
Side-by-side
cl-tar.asd
View file @
f29671cb
...
...
@@ -6,7 +6,7 @@
:maintainer
"Eric Timmons <eric@timmons.dev>"
:description
"A package for reading and writing archive (currently only tar) files."
:license
"BSD-style (http://opensource.org/licenses/BSD-3-Clause)"
:depends-on
(
"alexandria"
"babel"
#+
sbcl
"sb-posix"
"trivial-gray-streams"
"uiop"
)
:depends-on
(
"alexandria"
"babel"
"trivial-gray-streams"
"uiop"
)
:pathname
"src"
:in-order-to
((
test-op
(
load-op
"cl-tar/test"
)))
:perform
(
test-op
(
o
c
)
...
...
@@ -25,7 +25,7 @@
(
: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
"entry"
:depends-on
(
"package"
"constants"
))
(
:file
"bounded-stream"
:depends-on
(
"package"
))
(
:file
"archive"
:depends-on
(
"generics"
"bounded-stream"
"macros"
"external-macros"
"entry"
"constants"
))))
...
...
src/conditions.lisp
View file @
f29671cb
...
...
@@ -40,3 +40,6 @@
(
format
stream
"Don't know how to write a type ~A tar entry yet"
(
typeflag
condition
))))
(
:documentation
"Signaled when attempting to write an unsupported tar entry."
))
(
define-condition
malformed-pax-attribute-entry
(
archive-error
)
())
src/constants.lisp
View file @
f29671cb
...
...
@@ -32,3 +32,4 @@
(
defconstant
+ascii-a+
#x61
)
(
defconstant
+ascii-z+
#x7a
)
(
defconstant
+ascii-/+
#x29
)
(
defconstant
+ascii-newline+
#xa
)
src/entry.lisp
View file @
f29671cb
...
...
@@ -50,12 +50,84 @@
(
:documentation
"A FIFO."
))
(
defclass
pax-extended-attributes-entry
(
entry
)
(
defclass
pax-attributes-entry
(
entry
)
((
attributes
:accessor
attributes
:documentation
"A hash table mapping attribute names (strings) to values (strings)."
)))
(
defgeneric
attribute
(
entry
name
&optional
default
)
(
:documentation
"Get the NAME attribute from ENTRY."
))
(
defgeneric
(
setf
attribute
)
(
new-value
entry
name
&optional
default
))
(
defmethod
attribute
((
entry
pax-attributes-entry
)
name
&optional
default
)
(
gethash
name
(
attributes
entry
)
default
))
(
defmethod
(
setf
attribute
)
(
new-value
(
entry
pax-attributes-entry
)
name
&optional
default
)
(
setf
(
gethash
name
(
attributes
entry
)
default
)
new-value
))
(
defun
read-attribute-length
(
stream
)
"Pop bytes out of the buffer until a space is read, then try turning that
into a number."
(
let*
((
bytes-read
0
)
(
bytes
(
loop
:for
byte
:=
(
read-byte
stream
nil
:eof
)
:when
(
eql
byte
:eof
)
:do
(
return
:eof
)
:end
:do
(
incf
bytes-read
)
:until
(
eql
byte
+ascii-space+
)
:collect
byte
)))
(
if
(
eql
bytes
:eof
)
:eof
(
values
(
parse-integer
(
bytevec-to-string
(
coerce
bytes
'
(
vector
(
unsigned-byte
8
)))))
bytes-read
))))
(
defun
read-attribute
(
stream
)
(
multiple-value-bind
(
num-bytes
bytes-read
)
(
read-attribute-length
stream
)
(
let
(
buffer
num-read
kv-string
=-position
)
(
unless
(
eql
num-bytes
:eof
)
(
setf
buffer
(
make-array
(
-
num-bytes
bytes-read
)
:element-type
'
(
unsigned-byte
8
)
:initial-element
0
))
(
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
))
(
unless
(
=
(
aref
buffer
(
1-
num-read
))
+ascii-newline+
)
(
error
'malformed-pax-attribute-entry
))
(
setf
=-position
(
position
#\=
kv-string
))
(
when
(
null
=-position
)
(
error
'malformed-pax-attribute-entry
))
(
values
(
subseq
kv-string
0
=-position
)
(
subseq
kv-string
(
1+
=-position
)
(
1-
num-read
))
t
)))))
(
defun
populate-pax-attributes
(
entry
)
(
let
((
stream
(
make-entry-stream
entry
))
(
ht
(
make-hash-table
:test
'equal
)))
(
loop
(
multiple-value-bind
(
key
value
exists-p
)
(
read-attribute
stream
)
(
unless
exists-p
(
return
))
(
setf
(
gethash
key
ht
)
value
)))
(
setf
(
attributes
entry
)
ht
)))
(
defmethod
slot-unbound
(
class
(
entry
pax-attributes-entry
)
(
slot-name
(
eql
'attributes
)))
(
populate-pax-attributes
entry
))
(
defclass
pax-extended-attributes-entry
(
pax-attributes-entry
)
()
(
:documentation
"Extended attributes for the subsequent record."
))
(
defclass
pax-global-attributes-entry
(
entry
)
(
defclass
pax-global-attributes-entry
(
pax-attributes-
entry
)
()
(
:documentation
"Extended attributes for all subsequent records."
))
...
...
@@ -78,6 +150,18 @@
(
make-bounded-stream
(
archive-stream
(
entry-archive
entry
))
(
size
entry
)
(
+
(
start-position
entry
)
+tar-n-block-bytes+
)))
(
defmethod
make-entry-stream
((
entry
pax-extended-attributes-entry
))
(
make-bounded-stream
(
archive-stream
(
entry-archive
entry
))
(
size
entry
)
(
+
(
start-position
entry
)
+tar-n-block-bytes+
)))
(
defmethod
make-entry-stream
((
entry
pax-global-attributes-entry
))
(
make-bounded-stream
(
archive-stream
(
entry-archive
entry
))
(
size
entry
)
(
+
(
start-position
entry
)
+tar-n-block-bytes+
)))
(
defmethod
make-entry-stream
((
entry
unknown-entry
))
(
make-bounded-stream
(
archive-stream
(
entry-archive
entry
))
(
size
entry
)
(
+
(
start-position
entry
)
+tar-n-block-bytes+
)))
(
defmacro
make-header-forwarder
(
name
)
`
(
defmethod
,
name
((
entry
entry
))
(
,
name
(
header
entry
))))
...
...
src/package.lisp
View file @
f29671cb
...
...
@@ -27,6 +27,7 @@
#:linkname
#:devmajor
#:devminor
#:attribute
;; entry tests
#:entry-directory-p
...
...
test/make-test-tars.sh
View file @
f29671cb
...
...
@@ -5,7 +5,7 @@ DIR="$(mktemp -d)"
MTIME
=
"Fri Aug 13 09:05:46.75 PM EDT 2021"
touch_file
()
{
touch
-a
--date
"
$MTIME
"
"
$1
"
touch
-h
-a
--date
"
$MTIME
"
"
$1
"
}
touch_files
()
{
...
...
test/pax.tar
View file @
f29671cb
No preview for this file type
test/tar.lisp
View file @
f29671cb
...
...
@@ -5,10 +5,81 @@
(
byte-contents
(
alexandria:read-stream-content-into-byte-vector
stream
)))
(
babel:octets-to-string
byte-contents
:encoding
:utf-8
)))
(
defun
a.txt-attr
(
type
entry
)
(
declare
(
ignore
type
))
(
para:is
equal
"./PaxHeaders/a.txt"
(
tar:name
entry
))
(
para:is
equal
""
(
tar:uname
entry
))
(
para:is
equal
""
(
tar:gname
entry
))
(
para:is
=
#o644
(
tar:mode
entry
))
(
para:is
=
1628903146
(
tar:mtime
entry
))
(
para:is
=
0
(
tar:uid
entry
))
(
para:is
=
0
(
tar:gid
entry
))
(
para:is
equal
"1628903146.5"
(
tar:attribute
entry
"mtime"
))
(
para:is
equal
"1628903146.75"
(
tar:attribute
entry
"atime"
)))
(
defun
a-symlink.txt-attr
(
type
entry
)
(
declare
(
ignore
type
))
(
para:is
equal
"./PaxHeaders/a-symlink.txt"
(
tar:name
entry
))
(
para:is
equal
""
(
tar:uname
entry
))
(
para:is
equal
""
(
tar:gname
entry
))
(
para:is
=
#o644
(
tar:mode
entry
))
(
para:is
=
1628903146
(
tar:mtime
entry
))
(
para:is
=
0
(
tar:uid
entry
))
(
para:is
=
0
(
tar:gid
entry
))
(
para:is
equal
"1628903146.5"
(
tar:attribute
entry
"mtime"
))
(
para:is
equal
"1628903146.75"
(
tar:attribute
entry
"atime"
)))
(
defun
a-hardlink.txt-attr
(
type
entry
)
(
declare
(
ignore
type
))
(
para:is
equal
"./PaxHeaders/a-hardlink.txt"
(
tar:name
entry
))
(
para:is
equal
""
(
tar:uname
entry
))
(
para:is
equal
""
(
tar:gname
entry
))
(
para:is
=
#o644
(
tar:mode
entry
))
(
para:is
=
1628903146
(
tar:mtime
entry
))
(
para:is
=
0
(
tar:uid
entry
))
(
para:is
=
0
(
tar:gid
entry
))
(
para:is
equal
"1628903146.5"
(
tar:attribute
entry
"mtime"
)))
(
defun
fifo-attr
(
type
entry
)
(
declare
(
ignore
type
))
(
para:is
equal
"./PaxHeaders/fifo"
(
tar:name
entry
))
(
para:is
equal
""
(
tar:uname
entry
))
(
para:is
equal
""
(
tar:gname
entry
))
(
para:is
=
#o644
(
tar:mode
entry
))
(
para:is
=
1628903146
(
tar:mtime
entry
))
(
para:is
=
0
(
tar:uid
entry
))
(
para:is
=
0
(
tar:gid
entry
))
(
para:is
equal
"1628903146.5"
(
tar:attribute
entry
"mtime"
))
(
para:is
equal
"1628903146.75"
(
tar:attribute
entry
"atime"
)))
(
defun
sda1-attr
(
type
entry
)
(
declare
(
ignore
type
))
(
para:is
equal
"./PaxHeaders/sda1"
(
tar:name
entry
))
(
para:is
equal
""
(
tar:uname
entry
))
(
para:is
equal
""
(
tar:gname
entry
))
(
para:is
=
#o644
(
tar:mode
entry
))
(
para:is
=
1628903146
(
tar:mtime
entry
))
(
para:is
=
0
(
tar:uid
entry
))
(
para:is
=
0
(
tar:gid
entry
))
(
para:is
equal
"1628903146.5"
(
tar:attribute
entry
"mtime"
))
(
para:is
equal
"1628903146.75"
(
tar:attribute
entry
"atime"
)))
(
defun
tty0-attr
(
type
entry
)
(
declare
(
ignore
type
))
(
para:is
equal
"./PaxHeaders/tty0"
(
tar:name
entry
))
(
para:is
equal
""
(
tar:uname
entry
))
(
para:is
equal
""
(
tar:gname
entry
))
(
para:is
=
#o644
(
tar:mode
entry
))
(
para:is
=
1628903146
(
tar:mtime
entry
))
(
para:is
=
0
(
tar:uid
entry
))
(
para:is
=
0
(
tar:gid
entry
))
(
para:is
equal
"1628903146.5"
(
tar:attribute
entry
"mtime"
))
(
para:is
equal
"1628903146.75"
(
tar:attribute
entry
"atime"
)))
(
defun
a.txt
(
type
entry
)
(
para:is
equal
"a.txt"
(
tar:name
entry
))
(
para:is
=
14
(
tar:size
entry
))
(
unless
(
eql
type
:
ustar
)
(
unless
(
eql
type
:
v7
)
(
para:is
equal
"root"
(
tar:uname
entry
))
(
para:is
equal
"root"
(
tar:gname
entry
)))
(
para:is
=
#o644
(
tar:mode
entry
))
...
...
@@ -22,7 +93,7 @@
(
defun
a-symlink.txt
(
type
entry
)
(
para:is
equal
"a-symlink.txt"
(
tar:name
entry
))
(
para:is
=
0
(
tar:size
entry
))
(
unless
(
eql
type
:
ustar
)
(
unless
(
eql
type
:
v7
)
(
para:is
equal
"root"
(
tar:uname
entry
))
(
para:is
equal
"root"
(
tar:gname
entry
)))
(
para:is
=
#o777
(
tar:mode
entry
))
...
...
@@ -35,7 +106,7 @@
(
defun
a-hardlink.txt
(
type
entry
)
(
para:is
equal
"a-hardlink.txt"
(
tar:name
entry
))
(
para:is
=
0
(
tar:size
entry
))
(
unless
(
eql
type
:
ustar
)
(
unless
(
eql
type
:
v7
)
(
para:is
equal
"root"
(
tar:uname
entry
))
(
para:is
equal
"root"
(
tar:gname
entry
)))
(
para:is
=
#o644
(
tar:mode
entry
))
...
...
@@ -46,6 +117,7 @@
(
para:is
equal
"a.txt"
(
tar:linkname
entry
)))
(
defun
fifo
(
type
entry
)
(
declare
(
ignore
type
))
(
para:is
equal
"fifo"
(
tar:name
entry
))
(
para:is
=
0
(
tar:size
entry
))
(
para:is
equal
"root"
(
tar:uname
entry
))
...
...
@@ -57,6 +129,7 @@
(
para:is
=
0
(
tar:gid
entry
)))
(
defun
sda1
(
type
entry
)
(
declare
(
ignore
type
))
(
para:is
equal
"sda1"
(
tar:name
entry
))
(
para:is
=
0
(
tar:size
entry
))
(
para:is
equal
"root"
(
tar:uname
entry
))
...
...
@@ -70,6 +143,7 @@
(
para:is
=
1
(
tar:devminor
entry
)))
(
defun
tty0
(
type
entry
)
(
declare
(
ignore
type
))
(
para:is
equal
"tty0"
(
tar:name
entry
))
(
para:is
=
0
(
tar:size
entry
))
(
para:is
equal
"root"
(
tar:uname
entry
))
...
...
@@ -114,21 +188,65 @@
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
para:true
(
null
entry
)))))
(
para:define-test
read-pax
(
tar:with-open-archive
(
a
(
asdf:system-relative-pathname
:cl-tar
"test/pax.tar"
))
(
let
(
entry
)
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
a.txt-attr
:pax
entry
)
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
a.txt
:pax
entry
)
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
a-symlink.txt-attr
:pax
entry
)
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
a-symlink.txt
:pax
entry
)
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
a-hardlink.txt-attr
:pax
entry
)
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
a-hardlink.txt
:pax
entry
)
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
fifo-attr
:pax
entry
)
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
fifo
:pax
entry
)
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
sda1-attr
:pax
entry
)
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
sda1
:pax
entry
)
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
tty0-attr
:pax
entry
)
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
tty0
:pax
entry
)
;; 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
))
(
a.txt
:
ustar
entry
)
(
a.txt
:
v7
entry
)
;; Next is the a-symlink.txt -> a.txt symlink
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
a-symlink.txt
:
ustar
entry
)
(
a-symlink.txt
:
v7
entry
)
;; Next is the a-hardlink.txt -> a.txt hardlink
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
a-hardlink.txt
:
ustar
entry
)
(
a-hardlink.txt
:
v7
entry
)
;; End of archive
(
setf
entry
(
tar:read-entry-from-archive
a
))
...
...
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