tar: Support extracting of read-only archives.

check.sh

@@ -143,6 +143,7 @@ tests='
 100-tar-Z
 100-tar-Z-old
 100-tar-Z-pipe
+100-tar-ro
 
 100-tr
 '

gash/ustar.scm

@@ -453,17 +453,17 @@
                                                          #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity))
                    files))))))
 
-(define (ustar-header-file-name header)
+(define* (ustar-header-file-name header #:key (strip 0))
-  (let ((name (ustar-header-name header))
+  (let* ((name (ustar-header-name header))
-        (prefix (ustar-header-prefix header)))
+         (prefix (ustar-header-prefix header))
-    (if (string-null? prefix) name
+         (file-name (if (string-null? prefix) name
-        (string-append prefix "/" name))))
+                        (string-append prefix "/" name))))
+    (if (zero? strip) file-name
+        (string-join (list-tail (string-split file-name #\/) strip) "/"))))
 
 (define* (read-ustar-file port header #:key (extract? #t) (strip 0))
   (let* ((size (ustar-header-size header))
-         (file-name (ustar-header-file-name header))
+         (file-name (ustar-header-file-name header #:strip strip))
-         (file-name (if (zero? strip) file-name
-                        (string-join (list-tail (string-split file-name #\/) strip) "/")))
          (dir (dirname file-name))
          (extract? (and extract? (not (string-null? file-name))))
          (thunk (lambda _
@@ -481,18 +481,18 @@
     (when extract?
       (mkdir-p dir))
     (if extract?
-        (case (ustar-header-type header)
+        (let ((mtime (ustar-header-mtime header)))
-          ((regular)
+          (case (ustar-header-type header)
-           (if (file-exists? file-name) (delete-file file-name))
+            ((regular)
-           (with-output-to-file file-name thunk #:binary #t))
+             (if (file-exists? file-name) (delete-file file-name))
-          ((directory) (mkdir-p file-name))
+             (with-output-to-file file-name thunk #:binary #t)
-          ((symlink) (symlink (ustar-header-link-name header) file-name )))
+             (utime file-name mtime mtime)
-        (thunk))
+             (chmod file-name (ustar-header-mode header)))
-    (when (and extract?
+            ((directory)
-               (not (eq? (ustar-header-type header) 'symlink)))
+             (mkdir-p file-name)
-      (chmod file-name (ustar-header-mode header))
+             (utime file-name mtime mtime))
-      (let ((mtime (ustar-header-mtime header)))
+            ((symlink) (symlink (ustar-header-link-name header) file-name ))))
-        (utime file-name mtime mtime)))))
+        (thunk))))
 
 (define (ustar-header->stat header)
   (let* ((stat-size 17)
@@ -516,7 +516,8 @@
   (for-each
    (cut write-ustar-file out <>
         #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:sort-order sort-order #:verbosity verbosity)
-   files))
+   files)
+  (write-ustar-footer out))
 
 (define* (write-ustar-archive file-name files #:key group mtime numeric-owner? owner sort-order verbosity)
   (catch #t
@@ -531,13 +532,20 @@
       (exit 1))))
 
 (define* (read-ustar-port in files #:key (extract? #t) (strip 0) verbosity)
-  (let loop ((header (read-ustar-header in)))
+  (let ((dirs
-    (when (and header
+         (let loop ((header (read-ustar-header in)) (dirs '()))
-               (not (eof-object? header)))
+           (if (not (and header (not (eof-object? header)))) dirs
-      (unless (zero? verbosity)
+               (begin
-        (display-header header #:verbose? (> verbosity 1)))
+                 (unless (zero? verbosity)
-      (read-ustar-file in header #:extract? extract? #:strip strip)
+                   (display-header header #:verbose? (> verbosity 1)))
-      (loop (read-ustar-header in)))))
+                 (read-ustar-file in header #:extract? extract? #:strip strip)
+                 (loop (read-ustar-header in)
+                       (if (eq? (ustar-header-type header) 'directory) (cons header dirs)
+                           dirs)))))))
+    (define (chmod-header header)
+      (chmod (ustar-header-file-name header #:strip strip)
+             (ustar-header-mode header)))
+    (for-each chmod-header dirs)))
 
 (define* (read-ustar-archive file-name files #:key (extract? #t) (strip 0) verbosity)
   (catch #t

test/100-tar-ro.sh

@@ -0,0 +1,3 @@
+\tar -xvf test/data/ro.tar
+\chmod -R +w foo
+\rm -r foo

test/100-tar-ro.stdout

@@ -0,0 +1,3 @@
+foo/
+foo/bar/
+foo/bar/baz