Files unpacked from tarballs bear the archived mtime (SBCL, Allegro)

quicklisp/impl-util.lisp

@@ -174,6 +174,21 @@ quicklisp at CL startup."
   (:implementation clisp
     (nth-value 2 (ql-clisp:probe-pathname pathname))))
 
+;;;
+;;; Set file date
+;;;
+
+(definterface set-file-date (pathname access-time modification-time)
+  (:documentation "Set the access and modification time of the file designated
+  by PATHNAME as a unix time (seconds since 1970-01-01).")
+  (:implementation t
+    t)
+  (:implementation allegro
+                   (ql-allegro:utime pathname
+                                     (ql-allegro:unix-to-universal-time access-time)
+                                     (ql-allegro:unix-to-universal-time modification-time)))
+  (:implementation sbcl
+    (ql-sbcl:utime pathname access-time modification-time)))
 
 ;;;
 ;;; Deleting a directory tree
@@ -337,4 +352,3 @@ potentially dead symlinks."
           (if (directoryp entry)
               (push entry directories-to-process)
               (funcall fun entry)))))))
-

quicklisp/impl.lisp

@@ -132,8 +132,13 @@
   (:documentation
    "Allegro Common Lisp - http://www.franz.com/products/allegrocl/")
   (:class allegro)
+  (:prep
+   (require :osi))
   (:reexport-from #:socket
                   #:make-socket)
+  (:reexport-from #:excl.osi
+                  #:unix-to-universal-time
+                  #:utime)
   (:reexport-from #:excl
                   #:file-directory-p
                   #:delete-directory
@@ -289,7 +294,8 @@
    (require 'sb-bsd-sockets))
   (:intern #:host-network-address)
   (:reexport-from #:sb-posix
-                  #:rmdir)
+                  #:rmdir
+                  #:utime)
   (:reexport-from #:sb-ext
                   #:compiler-note
                   #:native-namestring)

quicklisp/minitar.lisp

@@ -84,6 +84,9 @@ value it specifies as multiple values."
 (defun payload-size (header)
   (values (parse-integer (block-asciiz-string header 124 12) :radix 8)))
 
+(defun payload-mtime (header)
+  (values (parse-integer (block-asciiz-string header 136 12) :radix 8)))
+
 (defun nth-block (n file)
   (with-open-file (stream file :element-type '(unsigned-byte 8))
     (let ((block (make-block-buffer)))
@@ -149,10 +152,12 @@ value it specifies as multiple values."
                               (full-path block)))
                 (full-path (merge-pathnames tar-path directory))
                 (payload-size (payload-size block))
+                (payload-mtime (payload-mtime block))
                 (block-count (ceiling (payload-size block) +block-size+)))
          (case payload-type
            (:file
-            (save-file full-path payload-size stream))
+            (save-file full-path payload-size stream)
+            (ql-impl-util::set-file-date full-path payload-mtime payload-mtime))
            (:directory
             (ensure-directories-exist full-path))
            ((:symlink :global-header)