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
7278e83e
Commit
7278e83e
authored
Aug 15, 2021
by
Eric Timmons
Browse files
Add ARCHIVE-ENTRY-TYPE and ENTRY-HAS-DATA-P
parent
4b35488d
Changes
5
Hide whitespace changes
Inline
Side-by-side
src/archive.lisp
View file @
7278e83e
...
...
@@ -41,6 +41,8 @@
(
defgeneric
archive-header-type
(
archive
))
(
defgeneric
archive-entry-type
(
archive
header
))
(
defun
open-archive
(
archive-type
stream
&key
(
direction
:input
)
(
blocking-factor
20
))
"Return an archive. STREAM is the underlying Lisp stream for the archive.
...
...
@@ -140,11 +142,7 @@ requirements about alignment."
(
if
(
null-block-p
entry-block
0
)
nil
(
let
((
header
(
read-header-from-buffer
(
archive-header-type
archive
)
entry-block
:start
0
)))
(
make-instance
(
cond
((
entry-regular-file-p
header
)
'file-entry
)
(
t
'entry
))
(
make-instance
(
archive-entry-type
archive
header
)
:archive
archive
:header
header
:start-position
start-position
)))))
...
...
@@ -155,14 +153,9 @@ requirements about alignment."
(
setf
(
next-entry-start
archive
)
(
+
(
start-position
entry
)
+tar-n-block-bytes+
(
if
(
or
(
entry-directory-p
entry
)
(
entry-hard-link-p
entry
)
(
entry-symbolic-link-p
entry
)
(
entry-character-device-p
entry
)
(
entry-block-device-p
entry
)
(
entry-fifo-p
entry
))
+tar-n-block-bytes+
(
round-up-to-tar-block
(
size
entry
))))))
(
if
(
entry-has-data-p
entry
)
(
round-up-to-tar-block
(
size
entry
))
0
))))
entry
))
(
defun
transfer-stream-to-archive
(
archive
stream
)
...
...
src/constants.lisp
View file @
7278e83e
...
...
@@ -31,3 +31,4 @@
(
defconstant
+ascii-nine+
#x39
)
(
defconstant
+ascii-a+
#x61
)
(
defconstant
+ascii-z+
#x7a
)
(
defconstant
+ascii-/+
#x29
)
src/entry.lisp
View file @
7278e83e
...
...
@@ -20,6 +20,58 @@
(
:documentation
"A regular file."
))
(
defclass
hard-link-entry
(
entry
)
()
(
:documentation
"A hard link."
))
(
defclass
symbolic-link-entry
(
entry
)
()
(
:documentation
"A symbolic link."
))
(
defclass
character-device-entry
(
entry
)
()
(
:documentation
"A character device."
))
(
defclass
block-device-entry
(
entry
)
()
(
:documentation
"A block device."
))
(
defclass
directory-entry
(
entry
)
()
(
:documentation
"A directory."
))
(
defclass
fifo-entry
(
entry
)
()
(
:documentation
"A FIFO."
))
(
defclass
pax-extended-attributes-entry
(
entry
)
()
(
:documentation
"Extended attributes for the subsequent record."
))
(
defclass
pax-global-attributes-entry
(
entry
)
()
(
:documentation
"Extended attributes for all subsequent records."
))
(
defclass
unknown-entry
(
entry
)
()
(
: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
))
(
defgeneric
make-entry-stream
(
entry
))
(
defmethod
make-entry-stream
((
entry
file-entry
))
...
...
src/ustar.lisp
View file @
7278e83e
...
...
@@ -46,3 +46,28 @@
'ustar-archive
)))
(
register-archive-type-detector
'detect-ustar-archive
)
(
defmethod
archive-entry-type
((
archive
ustar-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
)
(
+posix-extended-header+
'pax-extended-attributes-entry
)
(
+posix-global-header+
'pax-global-attributes-entry
)
(
t
'unknown-entry
)))
src/v7.lisp
View file @
7278e83e
...
...
@@ -19,3 +19,26 @@
(
defmethod
archive-header-type
((
archive
v7-archive
))
'v7-header
)
(
defmethod
archive-entry-type
((
archive
v7-archive
)
header
)
(
if
(
alexandria:ends-with
+ascii-/+
(
name
header
))
'directory-entry
(
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
)
(
t
'unknown-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