Commit a21d99d8 authored by Eric Timmons's avatar Eric Timmons
Browse files

Add some write tests

parent 9dd96744
......@@ -108,7 +108,7 @@ Further operations on the archive are undefined."
(error "Invalid argument for :STREAM: ~A" stream))))
(defmethod write-entry-to-archive ((archive archive) entry
&key (stream t))
&key stream)
(with-slots ((archive-stream stream)) archive
(let ((buffer (make-array +tar-n-block-bytes+ :element-type '(unsigned-byte 8))))
(declare (dynamic-extent buffer))
......
......@@ -42,7 +42,9 @@
(let ((header (apply #'make-instance (archive-header-type archive)
:name name
:typeflag +tar-regular-file+
:typeflag (if (typep archive 'v7-archive)
+tar-regular-alternate-file+
+tar-regular-file+)
(uiop:remove-plist-key :data args)))
(start-position (file-position (archive-stream archive))))
(write-entry-to-archive archive header :stream data)
......@@ -53,21 +55,63 @@
(:documentation
"A hard link."))
(defun write-hard-link-entry (archive name &rest args &key uname gname mode mtime uid gid linkname)
(declare (ignore uname gname mode mtime uid gid linkname))
(let ((header (apply #'make-instance (archive-header-type archive)
:name name
:typeflag +tar-hard-link+
args))
(start-position (file-position (archive-stream archive))))
(write-entry-to-archive archive header)
(make-instance 'hard-link-entry :header header :archive archive :start-position start-position)))
(defclass symbolic-link-entry (entry)
()
(:documentation
"A symbolic link."))
(defun write-symbolic-link-entry (archive name &rest args &key uname gname mode mtime uid gid linkname)
(declare (ignore uname gname mode mtime uid gid linkname))
(let ((header (apply #'make-instance (archive-header-type archive)
:name name
:typeflag +tar-symbolic-link+
args))
(start-position (file-position (archive-stream archive))))
(write-entry-to-archive archive header)
(make-instance 'symbolic-link-entry :header header :archive archive :start-position start-position)))
(defclass character-device-entry (entry)
()
(:documentation
"A character device."))
(defun write-character-device-entry (archive name &rest args &key uname gname mode mtime uid gid
devmajor devminor)
(declare (ignore uname gname mode mtime uid gid devmajor devminor))
(let ((header (apply #'make-instance (archive-header-type archive)
:name name
:typeflag +tar-character-device+
args))
(start-position (file-position (archive-stream archive))))
(write-entry-to-archive archive header)
(make-instance 'character-device-entry :header header :archive archive :start-position start-position)))
(defclass block-device-entry (entry)
()
(:documentation
"A block device."))
(defun write-block-device-entry (archive name &rest args &key uname gname mode mtime uid gid
devmajor devminor)
(declare (ignore uname gname mode mtime uid gid devmajor devminor))
(let ((header (apply #'make-instance (archive-header-type archive)
:name name
:typeflag +tar-block-device+
args))
(start-position (file-position (archive-stream archive))))
(write-entry-to-archive archive header)
(make-instance 'block-device-entry :header header :archive archive :start-position start-position)))
(defclass directory-entry (entry)
()
(:documentation
......@@ -78,6 +122,16 @@
(:documentation
"A FIFO."))
(defun write-fifo-entry (archive name &rest args &key uname gname mode mtime uid gid)
(declare (ignore uname gname mode mtime uid gid))
(let ((header (apply #'make-instance (archive-header-type archive)
:name name
:typeflag +tar-fifo-device+
args))
(start-position (file-position (archive-stream archive))))
(write-entry-to-archive archive header)
(make-instance 'fifo-entry :header header :archive archive :start-position start-position)))
(defclass pax-attributes-entry (entry has-data-mixin)
((attributes
:accessor attributes
......
......@@ -35,6 +35,8 @@
(funcall thunk archive)
(setf abort nil)))
(when archive
(when (eql direction :output)
(finalize-archive archive))
(close-archive archive)
(setf archive nil))
(when should-close
......
......@@ -32,6 +32,11 @@
#:attribute
#:write-file-entry
#:write-symbolic-link-entry
#:write-hard-link-entry
#:write-fifo-entry
#:write-block-device-entry
#:write-character-device-entry
;; entry tests
#:entry-directory-p
......
......@@ -42,5 +42,7 @@
:pathname "test"
:components ((:file "package")
(:file "blocked-stream" :depends-on ("package"))
(:file "tar" :depends-on ("package")))
(:file "shared" :depends-on ("package"))
(:file "read" :depends-on ("package"))
(:file "write" :depends-on ("package")))
:depends-on (#:tar-file #:parachute))
(in-package #:tar-file-test)
(para:define-test read-ustar
(tar-file:with-open-archive (a (asdf:system-relative-pathname
:tar-file "test/ustar.tar"))
(let (entry)
;; First entry is a plain file, with the contents "Hello, world!"
(setf entry (tar-file:read-entry-from-archive a))
(read-a.txt :ustar entry)
;; Next is the a-symlink.txt -> a.txt symlink
(setf entry (tar-file:read-entry-from-archive a))
(read-a-symlink.txt :ustar entry)
;; Next is the a-hardlink.txt -> a.txt hardlink
(setf entry (tar-file:read-entry-from-archive a))
(read-a-hardlink.txt :ustar entry)
;; fifo
(setf entry (tar-file:read-entry-from-archive a))
(read-fifo :ustar entry)
;; sda1
(setf entry (tar-file:read-entry-from-archive a))
(read-sda1 :ustar entry)
;; tty0
(setf entry (tar-file:read-entry-from-archive a))
(read-tty0 :ustar entry)
;; End of archive
(setf entry (tar-file:read-entry-from-archive a))
(para:true (null entry)))))
(para:define-test read-pax
(tar-file:with-open-archive (a (asdf:system-relative-pathname
:tar-file "test/pax.tar"))
(let (entry)
(setf entry (tar-file:read-entry-from-archive a))
(read-a.txt-attr :pax entry)
(setf entry (tar-file:read-entry-from-archive a))
(read-a.txt :pax entry)
(setf entry (tar-file:read-entry-from-archive a))
(read-a-symlink.txt-attr :pax entry)
(setf entry (tar-file:read-entry-from-archive a))
(read-a-symlink.txt :pax entry)
(setf entry (tar-file:read-entry-from-archive a))
(read-a-hardlink.txt-attr :pax entry)
(setf entry (tar-file:read-entry-from-archive a))
(read-a-hardlink.txt :pax entry)
(setf entry (tar-file:read-entry-from-archive a))
(read-fifo-attr :pax entry)
(setf entry (tar-file:read-entry-from-archive a))
(read-fifo :pax entry)
(setf entry (tar-file:read-entry-from-archive a))
(read-sda1-attr :pax entry)
(setf entry (tar-file:read-entry-from-archive a))
(read-sda1 :pax entry)
(setf entry (tar-file:read-entry-from-archive a))
(read-tty0-attr :pax entry)
(setf entry (tar-file:read-entry-from-archive a))
(read-tty0 :pax entry)
(setf entry (tar-file:read-entry-from-archive a))
(read-sparse.txt-attr :pax entry)
(setf entry (tar-file:read-entry-from-archive a))
(read-sparse.txt :pax entry)
;; End of archive
(setf entry (tar-file:read-entry-from-archive a))
(para:true (null entry)))))
(para:define-test read-gnu
(tar-file:with-open-archive (a (asdf:system-relative-pathname
:tar-file "test/gnu.tar"))
(let (entry)
;; First entry is a plain file, with the contents "Hello, world!"
(setf entry (tar-file:read-entry-from-archive a))
(read-a.txt :gnu entry)
;; Next is the a-symlink.txt -> a.txt symlink
(setf entry (tar-file:read-entry-from-archive a))
(read-a-symlink.txt :gnu entry)
;; Next is the a-hardlink.txt -> a.txt hardlink
(setf entry (tar-file:read-entry-from-archive a))
(read-a-hardlink.txt :gnu entry)
;; fifo
(setf entry (tar-file:read-entry-from-archive a))
(read-fifo :gnu entry)
;; sda1
(setf entry (tar-file:read-entry-from-archive a))
(read-sda1 :gnu entry)
;; tty0
(setf entry (tar-file:read-entry-from-archive a))
(read-tty0 :gnu entry)
;; sparse.txt
(setf entry (tar-file:read-entry-from-archive a))
(read-sparse.txt :gnu entry)
;; End of archive
(setf entry (tar-file:read-entry-from-archive a))
(para:true (null entry)))))
(para:define-test read-v7
(tar-file:with-open-archive (a (asdf:system-relative-pathname
:tar-file "test/v7.tar"))
(let (entry)
;; First entry is a plain file, with the contents "Hello, world!"
(setf entry (tar-file:read-entry-from-archive a))
(read-a.txt :v7 entry)
;; Next is the a-symlink.txt -> a.txt symlink
(setf entry (tar-file:read-entry-from-archive a))
(read-a-symlink.txt :v7 entry)
;; Next is the a-hardlink.txt -> a.txt hardlink
(setf entry (tar-file:read-entry-from-archive a))
(read-a-hardlink.txt :v7 entry)
;; End of archive
(setf entry (tar-file:read-entry-from-archive a))
(para:true (null entry)))))
(in-package #:tar-file-test)
(defparameter *default-mtime* 1628903146)
(defparameter *default-pax-mtime* "1628903146.5")
(defparameter *default-pax-atime* "1628903146.75")
(defparameter *keep-written-archives* nil)
(defclass file-comparison-result (para:result)
((expected-file
:initarg :expected-file
:reader expected-file)
(actual-file
:initarg :actual-file
:reader actual-file)))
(defmethod para:eval-in-context (context (result file-comparison-result))
(flet ((fail ()
(setf (para:status result) :failed)
(return-from para:eval-in-context nil)))
(with-open-file (expected-stream (expected-file result) :element-type '(unsigned-byte 8))
(with-open-file (actual-stream (actual-file result) :element-type '(unsigned-byte 8))
(unless (= (file-length expected-stream)
(file-length actual-stream))
(fail))))
(with-open-file (expected-stream (expected-file result) :element-type '(unsigned-byte 8))
(with-open-file (actual-stream (actual-file result) :element-type '(unsigned-byte 8))
(let ((expected-buffer (make-array 8096 :element-type '(unsigned-byte 8) :initial-element 0))
(actual-buffer (make-array 8096 :element-type '(unsigned-byte 8) :initial-element 0)))
(loop
(let ((expected-bytes-read (read-sequence expected-buffer expected-stream)))
(read-sequence actual-buffer actual-stream)
(unless (equalp expected-buffer actual-buffer)
(fail))
(unless (null expected-bytes-read)
(return))))
(setf (para:status result) :passed))))))
(defmacro files-equal (expected actual &optional description &rest format-args)
`(para:eval-in-context para:*context*
(make-instance 'file-comparison-result
:expression '(files-equal ,expected ,actual)
:expected-file ,expected
:actual-file ,actual
,@(when description
`(:description (format NIL ,description ,@format-args))))))
(defun contents-as-string (entry)
(let* ((stream (tar-file:make-entry-stream entry))
(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)
(defun read-a.txt-attr (type entry)
(declare (ignore type))
(para:is equal "./PaxHeaders/a.txt" (tar-file:name entry))
(para:is equal "" (tar-file:uname entry))
(para:is equal "" (tar-file:gname entry))
(para:is = #o644 (tar-file:mode entry))
(para:is = 1628903146 (tar-file:mtime entry))
(para:is = *default-mtime* (tar-file:mtime entry))
(para:is = 0 (tar-file:uid entry))
(para:is = 0 (tar-file:gid entry))
(para:is equal "1628903146.5" (tar-file:attribute entry "mtime"))
(para:is equal "1628903146.75" (tar-file:attribute entry "atime")))
(defun a-symlink.txt-attr (type entry)
(para:is equal *default-pax-mtime* (tar-file:attribute entry "mtime"))
(para:is equal *default-pax-atime* (tar-file:attribute entry "atime")))
(defun write-a.txt (type archive)
(let ((args (list :mode #o644
:mtime *default-mtime*
:uid 0
:gid 0
:data "Hello, world!
")))
(unless (eql type :v7)
(setf args (append (list :uname "root" :gname "root") args)))
(apply #'tar-file:write-file-entry
archive
"a.txt"
args)))
(defun read-a-symlink.txt-attr (type entry)
(declare (ignore type))
(para:is equal "./PaxHeaders/a-symlink.txt" (tar-file:name entry))
(para:is equal "" (tar-file:uname entry))
(para:is equal "" (tar-file:gname entry))
(para:is = #o644 (tar-file:mode entry))
(para:is = 1628903146 (tar-file:mtime entry))
(para:is = *default-mtime* (tar-file:mtime entry))
(para:is = 0 (tar-file:uid entry))
(para:is = 0 (tar-file:gid entry))
(para:is equal "1628903146.5" (tar-file:attribute entry "mtime"))
(para:is equal "1628903146.75" (tar-file:attribute entry "atime")))
(defun a-hardlink.txt-attr (type entry)
(para:is equal *default-pax-mtime* (tar-file:attribute entry "mtime"))
(para:is equal *default-pax-atime* (tar-file:attribute entry "atime")))
(defun write-a-symlink.txt (type archive)
(let ((args (list :mode #o777
:mtime *default-mtime*
:uid 0
:gid 0
:linkname "a.txt")))
(unless (eql type :v7)
(setf args (append (list :uname "root" :gname "root") args)))
(apply #'tar-file:write-symbolic-link-entry archive
"a-symlink.txt"
args)))
(defun read-a-hardlink.txt-attr (type entry)
(declare (ignore type))
(para:is equal "./PaxHeaders/a-hardlink.txt" (tar-file:name entry))
(para:is equal "" (tar-file:uname entry))
(para:is equal "" (tar-file:gname entry))
(para:is = #o644 (tar-file:mode entry))
(para:is = 1628903146 (tar-file:mtime entry))
(para:is = *default-mtime* (tar-file:mtime entry))
(para:is = 0 (tar-file:uid entry))
(para:is = 0 (tar-file:gid entry))
(para:is equal "1628903146.5" (tar-file:attribute entry "mtime")))
(defun sparse.txt-attr (type entry)
(para:is equal *default-pax-mtime* (tar-file:attribute entry "mtime")))
(defun write-a-hardlink.txt (type archive)
(let ((args (list :mode #o644
:mtime *default-mtime*
:uid 0
:gid 0
:linkname "a.txt")))
(unless (eql type :v7)
(setf args (append (list :uname "root" :gname "root") args)))
(apply #'tar-file:write-hard-link-entry archive
"a-hardlink.txt"
args)))
(defun read-sparse.txt-attr (type entry)
(declare (ignore type))
(para:is equal "./PaxHeaders/sparse.txt" (tar-file:name entry))
(para:is equal "" (tar-file:uname entry))
(para:is equal "" (tar-file:gname entry))
(para:is = #o644 (tar-file:mode entry))
(para:is = 1628903146 (tar-file:mtime entry))
(para:is = *default-mtime* (tar-file:mtime entry))
(para:is = 0 (tar-file:uid entry))
(para:is = 0 (tar-file:gid entry))
(para:is equal "1628903146.5" (tar-file:attribute entry "mtime"))
(para:is equal "1628903146.75" (tar-file:attribute entry "atime"))
(para:is equal *default-pax-mtime* (tar-file:attribute entry "mtime"))
(para:is equal *default-pax-atime* (tar-file:attribute entry "atime"))
(para:is equal "1" (tar-file:attribute entry "GNU.sparse.major"))
(para:is equal "0" (tar-file:attribute entry "GNU.sparse.minor"))
(para:is equal "sparse.txt" (tar-file:attribute entry "GNU.sparse.name"))
(para:is equal "5242880" (tar-file:attribute entry "GNU.sparse.realsize")))
(defun fifo-attr (type entry)
(defun read-fifo-attr (type entry)
(declare (ignore type))
(para:is equal "./PaxHeaders/fifo" (tar-file:name entry))
(para:is equal "" (tar-file:uname entry))
(para:is equal "" (tar-file:gname entry))
(para:is = #o644 (tar-file:mode entry))
(para:is = 1628903146 (tar-file:mtime entry))
(para:is = *default-mtime* (tar-file:mtime entry))
(para:is = 0 (tar-file:uid entry))
(para:is = 0 (tar-file:gid entry))
(para:is equal "1628903146.5" (tar-file:attribute entry "mtime"))
(para:is equal "1628903146.75" (tar-file:attribute entry "atime")))
(para:is equal *default-pax-mtime* (tar-file:attribute entry "mtime"))
(para:is equal *default-pax-atime* (tar-file:attribute entry "atime")))
(defun sda1-attr (type entry)
(defun write-fifo (type archive)
(declare (ignore type))
(tar-file:write-fifo-entry archive
"fifo"
:uname "root" :gname "root"
:mode #o644
:mtime *default-mtime*
:uid 0
:gid 0))
(defun read-sda1-attr (type entry)
(declare (ignore type))
(para:is equal "./PaxHeaders/sda1" (tar-file:name entry))
(para:is equal "" (tar-file:uname entry))
(para:is equal "" (tar-file:gname entry))
(para:is = #o644 (tar-file:mode entry))
(para:is = 1628903146 (tar-file:mtime entry))
(para:is = *default-mtime* (tar-file:mtime entry))
(para:is = 0 (tar-file:uid entry))
(para:is = 0 (tar-file:gid entry))
(para:is equal "1628903146.5" (tar-file:attribute entry "mtime"))
(para:is equal "1628903146.75" (tar-file:attribute entry "atime")))
(para:is equal *default-pax-mtime* (tar-file:attribute entry "mtime"))
(para:is equal *default-pax-atime* (tar-file:attribute entry "atime")))
(defun tty0-attr (type entry)
(defun write-sda1 (type archive)
(declare (ignore type))
(tar-file:write-block-device-entry archive
"sda1"
:uname "root" :gname "root"
:mode #o644
:mtime *default-mtime*
:uid 0
:gid 0
:devmajor 8
:devminor 1))
(defun read-tty0-attr (type entry)
(declare (ignore type))
(para:is equal "./PaxHeaders/tty0" (tar-file:name entry))
(para:is equal "" (tar-file:uname entry))
(para:is equal "" (tar-file:gname entry))
(para:is = #o644 (tar-file:mode entry))
(para:is = 1628903146 (tar-file:mtime entry))
(para:is = *default-mtime* (tar-file:mtime entry))
(para:is = 0 (tar-file:uid entry))
(para:is = 0 (tar-file:gid entry))
(para:is equal "1628903146.5" (tar-file:attribute entry "mtime"))
(para:is equal "1628903146.75" (tar-file:attribute entry "atime")))
(para:is equal *default-pax-mtime* (tar-file:attribute entry "mtime"))
(para:is equal *default-pax-atime* (tar-file:attribute entry "atime")))
(defun a.txt (type entry)
(defun write-tty0 (type archive)
(declare (ignore type))
(tar-file:write-character-device-entry archive
"tty0"
:uname "root" :gname "root"
:mode #o644
:mtime *default-mtime*
:uid 0
:gid 0
:devmajor 4
:devminor 0))
(defun read-a.txt (type entry)
(para:is equal "a.txt" (tar-file:name entry))
(para:is = 14 (tar-file:size entry))
(unless (eql type :v7)
......@@ -100,13 +216,13 @@
(para:is equal "root" (tar-file:gname entry)))
(para:is = #o644 (tar-file:mode entry))
(para:true (tar-file:entry-regular-file-p entry))
(para:is = 1628903146 (tar-file:mtime entry))
(para:is = *default-mtime* (tar-file:mtime entry))
(para:is = 0 (tar-file:uid entry))
(para:is = 0 (tar-file:gid entry))
(para:is equal "Hello, world!
" (contents-as-string entry)))
(defun a-symlink.txt (type entry)
(defun read-a-symlink.txt (type entry)
(para:is equal "a-symlink.txt" (tar-file:name entry))
(para:is = 0 (tar-file:size entry))
(unless (eql type :v7)
......@@ -114,12 +230,12 @@
(para:is equal "root" (tar-file:gname entry)))
(para:is = #o777 (tar-file:mode entry))
(para:true (tar-file:entry-symbolic-link-p entry))
(para:is = 1628903146 (tar-file:mtime entry))
(para:is = *default-mtime* (tar-file:mtime entry))
(para:is = 0 (tar-file:uid entry))
(para:is = 0 (tar-file:gid entry))
(para:is equal "a.txt" (tar-file:linkname entry)))
(defun a-hardlink.txt (type entry)
(defun read-a-hardlink.txt (type entry)
(para:is equal "a-hardlink.txt" (tar-file:name entry))
(para:is = 0 (tar-file:size entry))
(unless (eql type :v7)
......@@ -127,12 +243,12 @@
(para:is equal "root" (tar-file:gname entry)))
(para:is = #o644 (tar-file:mode entry))
(para:true (tar-file:entry-hard-link-p entry))
(para:is = 1628903146 (tar-file:mtime entry))
(para:is = *default-mtime* (tar-file:mtime entry))
(para:is = 0 (tar-file:uid entry))
(para:is = 0 (tar-file:gid entry))
(para:is equal "a.txt" (tar-file:linkname entry)))
(defun fifo (type entry)
(defun read-fifo (type entry)
(declare (ignore type))
(para:is equal "fifo" (tar-file:name entry))
(para:is = 0 (tar-file:size entry))
......@@ -140,11 +256,11 @@
(para:is equal "root" (tar-file:gname entry))
(para:is = #o644 (tar-file:mode entry))
(para:true (tar-file:entry-fifo-p entry))
(para:is = 1628903146 (tar-file:mtime entry))
(para:is = *default-mtime* (tar-file:mtime entry))
(para:is = 0 (tar-file:uid entry))
(para:is = 0 (tar-file:gid entry)))
(defun sda1 (type entry)
(defun read-sda1 (type entry)
(declare (ignore type))
(para:is equal "sda1" (tar-file:name entry))
(para:is = 0 (tar-file:size entry))
......@@ -152,13 +268,13 @@
(para:is equal "root" (tar-file:gname entry))
(para:is = #o644 (tar-file:mode entry))
(para:true (tar-file:entry-block-device-p entry))
(para:is = 1628903146 (tar-file:mtime entry))
(para:is = *default-mtime* (tar-file:mtime entry))
(para:is = 0 (tar-file:uid entry))
(para:is = 0 (tar-file:gid entry))
(para:is = 8 (tar-file:devmajor entry))
(para:is = 1 (tar-file:devminor entry)))
(defun tty0 (type entry)
(defun read-tty0 (type entry)
(declare (ignore type))
(para:is equal "tty0" (tar-file:name entry))
(para:is = 0 (tar-file:size entry))
......@@ -166,13 +282,13 @@
(para:is equal "root" (tar-file:gname entry))
(para:is = #o644 (tar-file:mode entry))
(para:true (tar-file:entry-character-device-p entry))
(para:is = 1628903146 (tar-file:mtime entry))
(para:is = *default-mtime* (tar-file:mtime entry))
(para:is = 0 (tar-file:uid entry))
(para:is = 0 (tar-file:gid entry))
(para:is = 4 (tar-file:devmajor entry))
(para:is = 0 (tar-file:devminor entry)))
(defun sparse.txt (type entry)
(defun read-sparse.txt (type entry)
(ecase type
(:gnu
(para:is equal "sparse.txt" (tar-file:name entry)))
......@@ -187,144 +303,6 @@
(para:is equal "root" (tar-file:uname entry))
(para:is equal "root" (tar-file:gname entry))