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
9dd96744
Commit
9dd96744
authored
Aug 18, 2021
by
Eric Timmons
Browse files
Start on writing entries to archives
parent
661c6e48
Changes
6
Hide whitespace changes
Inline
Side-by-side
src/archive.lisp
View file @
9dd96744
...
...
@@ -90,10 +90,17 @@ Further operations on the archive are undefined."
(
cond
((
typep
stream
'stream
)
(
if
(
and
(
subtypep
(
stream-element-type
stream
)
'
(
unsigned-byte
8
))
(
subtypep
'
(
unsigned-byte
8
)
(
stream-element-type
stream
)))
(
subtypep
'
(
unsigned-byte
8
)
(
stream-element-type
stream
)))
(
transfer-stream-to-archive
archive
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-archive
archive
stream
)))
((
typep
stream
'string
)
(
transfer-octets-to-archive
archive
(
string-to-bytevec
stream
:utf-8
)))
((
typep
stream
'vector
)
(
transfer-octets-to-archive
archive
stream
))
((
eq
nil
stream
)
;; do nothing
)
...
...
@@ -156,6 +163,14 @@ Further operations on the archive are undefined."
:initial-element
0
)
(
archive-stream
archive
))))
(
defun
transfer-octets-to-archive
(
archive
octets
)
(
let*
((
rounded-bytes
(
round-up-to-tar-block
(
length
octets
)))
(
bytes-remaining
(
-
rounded-bytes
(
length
octets
))))
(
write-sequence
octets
(
archive-stream
archive
))
(
write-sequence
(
make-array
bytes-remaining
:element-type
'
(
unsigned-byte
8
)
:initial-element
0
)
(
archive-stream
archive
))))
(
defmethod
write-entry-to-archive
:before
((
archive
archive
)
(
entry
entry
)
&key
stream
)
...
...
src/blocked-stream.lisp
View file @
9dd96744
...
...
@@ -201,6 +201,7 @@ the buffer to be written."
sequence
start
end
&key
&allow-other-keys
)
(
ensure-buffer-valid
stream
)
(
setf
(
dirty-p
stream
)
t
)
(
let
((
num-bytes
(
-
(
or
end
(
length
sequence
))
start
))
(
num-bytes-remaining
(
-
(
block-size
stream
)
(
index
stream
))))
(
replace
(
buffer
stream
)
sequence
...
...
src/entry.lisp
View file @
9dd96744
...
...
@@ -25,6 +25,29 @@
(
:documentation
"A regular file."
))
(
defun
write-file-entry
(
archive
name
&rest
args
&key
uname
gname
mode
mtime
uid
gid
size
data
)
(
declare
(
ignore
uname
gname
mode
mtime
uid
gid
))
;; Compute the size when necessary.
(
when
(
null
size
)
(
etypecase
data
(
vector
(
setf
size
(
length
data
)))
(
pathname
(
with-open-file
(
s
data
:element-type
'
(
unsigned-byte
8
))
(
setf
size
(
file-length
s
))))
(
stream
(
setf
size
(
file-length
data
))))
(
push
size
args
)
(
push
:size
args
))
(
let
((
header
(
apply
#'
make-instance
(
archive-header-type
archive
)
:name
name
:typeflag
+tar-regular-file+
(
uiop:remove-plist-key
:data
args
)))
(
start-position
(
file-position
(
archive-stream
archive
))))
(
write-entry-to-archive
archive
header
:stream
data
)
(
make-instance
'file-entry
:header
header
:archive
archive
:start-position
start-position
)))
(
defclass
hard-link-entry
(
entry
)
()
(
:documentation
...
...
src/macros.lisp
View file @
9dd96744
...
...
@@ -50,6 +50,8 @@
(
unless
(
=
length
1
)
(
error
":BYTE fields cannot be longer than 1"
))
`
(
aref
buffer
(
+
entry-start
,
offset
)))
(
:bytes
`
(
subseq
buffer
(
+
entry-start
,
offset
)
(
+
entry-start
,
offset
,
length
)))
(
:octnum
`
(
read-number-from-buffer
buffer
:start
(
+
entry-start
,
offset
)
:end
(
+
entry-start
,
offset
,
length
)
:radix
8
))
(
:hexnum
`
(
read-number-from-buffer
buffer
:start
(
+
entry-start
,
offset
)
...
...
@@ -63,6 +65,9 @@
(
setf
(
aref
buffer
(
+
entry-start
,
offset
i
))
(
aref
thing
i
)))))
(
:byte
`
(
setf
(
aref
buffer
(
+
entry-start
,
offset
))
thing
))
(
:bytes
`
(
setf
(
subseq
buffer
(
+
entry-start
,
offset
)
(
+
entry-start
,
offset
,
length
))
thing
))
(
:octnum
`
(
let
((
start
(
+
entry-start
,
offset
))
(
end
(
+
entry-start
,
offset
,
length
)))
...
...
@@ -114,7 +119,8 @@
(
write-number-to-buffer
checksum
buffer
:start
checksum-offset
:end
(
+
checksum-offset
(
field-length
header
'checksum
))
(
field-length
header
'checksum
)
-2
)
:radix
8
)
;; terminated with a NULL and then a space (!?)
(
setf
(
aref
buffer
(
+
checksum-offset
6
))
0
...
...
src/package.lisp
View file @
9dd96744
...
...
@@ -31,6 +31,8 @@
#:devminor
#:attribute
#:write-file-entry
;; entry tests
#:entry-directory-p
#:entry-regular-file-p
...
...
src/ustar.lisp
View file @
9dd96744
...
...
@@ -24,8 +24,8 @@
(
checksum
8
:octnum
)
(
typeflag
1
:byte
)
(
linkname
100
:string-null
)
(
magic
6
:
string
*ustar-magic-vector*
)
(
version
2
:
string
*ustar-version-vector*
)
(
magic
6
:
bytes
*ustar-magic-vector*
)
(
version
2
:
bytes
*ustar-version-vector*
)
;; to be used in preference to uid and gid, of course
(
uname
32
:string-null
)
(
gname
32
:string-null
)
...
...
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