Commit 22a64d96 authored by Eric Timmons's avatar Eric Timmons
Browse files

Add gnu headers

parent f29671cb
......@@ -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"))))
......
......@@ -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)
......
......@@ -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+)))
......
;;;; 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)))
......@@ -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))))
No preview for this file type
......@@ -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
}
......
No preview for this file type
......@@ -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)))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment