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
22a64d96
Commit
22a64d96
authored
Aug 17, 2021
by
Eric Timmons
Browse files
Add gnu headers
parent
f29671cb
Changes
9
Hide whitespace changes
Inline
Side-by-side
cl-tar.asd
View file @
22a64d96
...
...
@@ -25,6 +25,7 @@
(
:file
"external-macros"
:depends-on
(
"generics"
))
(
:file
"ustar"
:depends-on
(
"package"
"macros"
"archive"
))
(
:file
"v7"
:depends-on
(
"package"
"macros"
"archive"
))
(
:file
"gnu"
:depends-on
(
"package"
"macros"
"archive"
))
(
: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/constants.lisp
View file @
22a64d96
...
...
@@ -25,6 +25,8 @@
(
defconstant
+gnutar-long-link-name+
#x4b
)
(
defconstant
+gnutar-long-name+
#x4c
)
(
defconstant
+gnutar-sparse+
#x53
)
(
defconstant
+gnutar-directory-dump+
#x44
)
(
defconstant
+gnutar-volume-header-name+
#x56
)
(
defconstant
+ascii-space+
#x20
)
(
defconstant
+ascii-zero+
#x30
)
...
...
src/entry.lisp
View file @
22a64d96
...
...
@@ -15,7 +15,10 @@
:initarg
:header
:reader
header
)))
(
defclass
file-entry
(
entry
)
(
defclass
has-data-mixin
()
())
(
defclass
file-entry
(
entry
has-data-mixin
)
()
(
:documentation
"A regular file."
))
...
...
@@ -50,7 +53,7 @@
(
:documentation
"A FIFO."
))
(
defclass
pax-attributes-entry
(
entry
)
(
defclass
pax-attributes-entry
(
entry
has-data-mixin
)
((
attributes
:accessor
attributes
:documentation
...
...
@@ -132,33 +135,49 @@
(
:documentation
"Extended attributes for all subsequent records."
))
(
defclass
unknown-entry
(
entry
)
(
defclass
gnu-directory-dump-entry
(
entry
has-data-mixin
)
())
(
defclass
gnu-long-link-name-entry
(
entry
has-data-mixin
)
((
long-link-name
:accessor
long-link-name
)))
(
defmethod
slot-unbound
(
class
(
entry
gnu-long-link-name-entry
)
(
slot-name
(
eql
'long-link-name
)))
(
let
((
buffer
(
make-array
(
size
entry
)
:element-type
'
(
unsigned-byte
8
)
:initial-element
0
))
(
stream
(
make-entry-stream
entry
)))
(
read-sequence
buffer
stream
)
(
setf
(
long-link-name
entry
)
(
bytevec-to-string
buffer
:utf-8
))))
(
defclass
gnu-long-name-entry
(
entry
has-data-mixin
)
((
long-name
:accessor
long-name
)))
(
defmethod
slot-unbound
(
class
(
entry
gnu-long-name-entry
)
(
slot-name
(
eql
'long-name
)))
(
let
((
buffer
(
make-array
(
size
entry
)
:element-type
'
(
unsigned-byte
8
)
:initial-element
0
))
(
stream
(
make-entry-stream
entry
)))
(
read-sequence
buffer
stream
)
(
setf
(
long-name
entry
)
(
bytevec-to-string
buffer
:utf-8
))))
(
defclass
gnu-sparse-file-entry
(
entry
has-data-mixin
)
())
(
defclass
gnu-volume-header-name-entry
(
entry
)
())
(
defclass
unknown-entry
(
entry
has-data-mixin
)
()
(
:documentation
"An unknown entry."
))
(
defgeneric
entry-has-data-p
(
entry
)
(
:method
(
entry
)
nil
)
(
:method
((
entry
file-entry
))
t
)
(
:method
((
entry
pax-extended-attributes-entry
))
t
)
(
:method
((
entry
pax-global-attributes-entry
))
t
)
(
:method
((
entry
unknown-entry
))
t
))
(
:method
((
entry
has-data-mixin
))
t
))
(
defgeneric
make-entry-stream
(
entry
))
(
defmethod
make-entry-stream
((
entry
file-entry
))
(
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
))
(
defmethod
make-entry-stream
((
entry
has-data-mixin
))
(
make-bounded-stream
(
archive-stream
(
entry-archive
entry
))
(
size
entry
)
(
+
(
start-position
entry
)
+tar-n-block-bytes+
)))
...
...
src/gnu.lisp
0 → 100644
View file @
22a64d96
;;;; gnu.lisp -- header format for GNU archives
(
in-package
#:tar
)
(
defparameter
*gnu-magic-vector*
(
coerce
`
(
,@
(
map
'list
#'
char-code
"ustar "
))
'
(
vector
(
unsigned-byte
8
)))
"The contents of the magic field for gnu archives."
)
(
defparameter
*gnu-version-vector*
(
coerce
`
(
,@
(
map
'list
#'
char-code
" "
)
0
)
'
(
vector
(
unsigned-byte
8
)))
"The contents of the version field for gnu archives."
)
(
define-octet-header
gnu-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
)
(
magic
6
:string
*gnu-magic-vector*
)
(
version
2
:string
*gnu-version-vector*
)
(
uname
32
:string-null
)
(
gname
32
:string-null
)
(
devmajor
8
:octnum
)
(
devminor
8
:octnum
)
(
atime
12
:octnum
)
(
ctime
12
:octnum
)
(
offset
12
:octnum
)
(
longnames
4
:string
)
(
unused
1
:byte
)
(
offset-sparse-0
12
:octnum
)
(
numbytes-sparse-0
12
:octnum
)
(
offset-sparse-1
12
:octnum
)
(
numbytes-sparse-1
12
:octnum
)
(
offset-sparse-2
12
:octnum
)
(
numbytes-sparse-2
12
:octnum
)
(
offset-sparse-3
12
:octnum
)
(
numbytes-sparse-3
12
:octnum
)
(
isextended
1
:byte
)
(
realsize
12
:octnum
)
(
%%padding
17
:string
))
(
defclass
gnu-archive
(
archive
)
())
(
defmethod
archive-header-type
((
archive
gnu-archive
))
'gnu-header
)
(
defun
detect-gnu-archive
(
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-archive
)))
(
register-archive-type-detector
'detect-gnu-archive
)
(
defmethod
archive-entry-type
((
archive
gnu-archive
)
header
)
(
alexandria:switch
((
typeflag
header
))
(
+tar-regular-file+
'file-entry
)
(
+tar-regular-alternate-file+
'file-entry
)
(
+tar-hard-link+
'hard-link-entry
)
(
+tar-symbolic-link+
'symbolic-link-entry
)
(
+tar-character-device+
'character-device-entry
)
(
+tar-block-device+
'block-device-entry
)
(
+tar-directory-file+
'directory-entry
)
(
+tar-fifo-device+
'fifo-entry
)
(
+gnutar-long-name+
'gnu-long-name-entry
)
(
+gnutar-long-link-name+
'gnu-long-link-name-entry
)
(
+gnutar-sparse+
'gnu-sparse-file-entry
)
(
+gnutar-directory-dump+
'gnu-directory-dump-entry
)
(
+gnutar-volume-header-name+
'gnu-volume-header-name-entry
)
(
t
'unknown-entry
)))
src/v7.lisp
View file @
22a64d96
...
...
@@ -32,13 +32,7 @@
'hard-link-entry
)
(
+tar-symbolic-link+
'symbolic-link-entry
)
(
+tar-character-device+
'character-device-entry
)
(
+tar-block-device+
'block-device-entry
)
(
+tar-directory-file+
'directory-entry
)
(
+tar-fifo-device+
'fifo-entry
)
(
t
'unknown-entry
))))
test/gnu.tar
View file @
22a64d96
No preview for this file type
test/make-test-tars.sh
View file @
22a64d96
...
...
@@ -15,6 +15,7 @@ touch_files () {
touch_file
"
$DIR
/fifo"
sudo touch
-a
--date
"
$MTIME
"
"
$DIR
/sda1"
sudo touch
-a
--date
"
$MTIME
"
"
$DIR
/tty0"
touch_file
"
$DIR
/sparse.txt"
}
echo
"Hello, world!"
>
"
$DIR
/a.txt"
...
...
@@ -23,17 +24,25 @@ ln "$DIR/a.txt" "$DIR/a-hardlink.txt"
mkfifo
"
$DIR
/fifo"
sudo mknod
"
$DIR
/sda1"
b 8 1
sudo mknod
"
$DIR
/tty0"
c 4 0
truncate
-s
5M
"
$DIR
/sparse.txt"
run_tar
()
{
files
=
"a.txt a-symlink.txt a-hardlink.txt"
sparse_option
=
""
if
[
"
$1
"
!=
"v7"
]
;
then
files
=
"
$files
fifo sda1 tty0"
fi
if
[
"
$1
"
=
"gnu"
]
||
[
"
$1
"
=
"pax"
]
;
then
files
=
"
$files
sparse.txt"
sparse_option
=
"-S"
fi
tar
-H
"
$1
"
-C
"
$DIR
"
\
--group
=
root
--owner
=
root
\
-b
20
\
$sparse_option
\
--mtime
"Fri Aug 13 09:05:46.5 PM EDT 2021"
\
-cf
"
$1
.tar"
$files
}
...
...
test/pax.tar
View file @
22a64d96
No preview for this file type
test/tar.lisp
View file @
22a64d96
...
...
@@ -40,6 +40,22 @@
(
para:is
=
0
(
tar:gid
entry
))
(
para:is
equal
"1628903146.5"
(
tar:attribute
entry
"mtime"
)))
(
defun
sparse.txt-attr
(
type
entry
)
(
declare
(
ignore
type
))
(
para:is
equal
"./PaxHeaders/sparse.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"
))
(
para:is
equal
"1"
(
tar:attribute
entry
"GNU.sparse.major"
))
(
para:is
equal
"0"
(
tar:attribute
entry
"GNU.sparse.minor"
))
(
para:is
equal
"sparse.txt"
(
tar:attribute
entry
"GNU.sparse.name"
))
(
para:is
equal
"5242880"
(
tar:attribute
entry
"GNU.sparse.realsize"
)))
(
defun
fifo-attr
(
type
entry
)
(
declare
(
ignore
type
))
(
para:is
equal
"./PaxHeaders/fifo"
(
tar:name
entry
))
...
...
@@ -156,6 +172,25 @@
(
para:is
=
4
(
tar:devmajor
entry
))
(
para:is
=
0
(
tar:devminor
entry
)))
(
defun
sparse.txt
(
type
entry
)
(
ecase
type
(
:gnu
(
para:is
equal
"sparse.txt"
(
tar:name
entry
)))
(
:pax
(
para:true
(
uiop:string-prefix-p
"./GNUSparseFile."
(
tar:name
entry
)))
(
para:true
(
uiop:string-suffix-p
(
tar:name
entry
)
"/sparse.txt"
))))
(
ecase
type
(
:gnu
(
para:is
=
0
(
tar:size
entry
)))
(
:pax
(
para:is
=
512
(
tar:size
entry
))))
(
para:is
equal
"root"
(
tar:uname
entry
))
(
para:is
equal
"root"
(
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:define-test
read-ustar
(
tar:with-open-archive
(
a
(
asdf:system-relative-pathname
:cl-tar
"test/ustar.tar"
))
...
...
@@ -228,6 +263,48 @@
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
tty0
:pax
entry
)
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
sparse.txt-attr
:pax
entry
)
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
sparse.txt
:pax
entry
)
;; End of archive
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
para:true
(
null
entry
)))))
(
para:define-test
read-gnu
(
tar:with-open-archive
(
a
(
asdf:system-relative-pathname
:cl-tar
"test/gnu.tar"
))
(
let
(
entry
)
;; First entry is a plain file, with the contents "Hello, world!"
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
a.txt
:gnu
entry
)
;; Next is the a-symlink.txt -> a.txt symlink
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
a-symlink.txt
:gnu
entry
)
;; Next is the a-hardlink.txt -> a.txt hardlink
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
a-hardlink.txt
:gnu
entry
)
;; fifo
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
fifo
:gnu
entry
)
;; sda1
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
sda1
:gnu
entry
)
;; tty0
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
tty0
:gnu
entry
)
;; sparse.txt
(
setf
entry
(
tar:read-entry-from-archive
a
))
(
sparse.txt
:gnu
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