From 42d52d1a70da4e7ecbdf710e154102c2085713b7 Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Tue, 4 Dec 2018 07:03:31 +0100
Subject: [PATCH] tar: Support extracting of read-only archives.

---
 check.sh               |   1 +
 gash/ustar.scm         |  64 +++++++++++++++++++++++------------------
 test/100-tar-ro.sh     |   3 ++
 test/100-tar-ro.stdout |   3 ++
 test/data/ro.tar       | Bin 0 -> 10240 bytes
 5 files changed, 43 insertions(+), 28 deletions(-)
 create mode 100644 test/100-tar-ro.sh
 create mode 100644 test/100-tar-ro.stdout
 create mode 100644 test/data/ro.tar

diff --git a/check.sh b/check.sh
index 275f9e0..ce67ba8 100755
--- a/check.sh
+++ b/check.sh
@@ -143,6 +143,7 @@ tests='
 100-tar-Z
 100-tar-Z-old
 100-tar-Z-pipe
+100-tar-ro
 
 100-tr
 '
diff --git a/gash/ustar.scm b/gash/ustar.scm
index b8c7bb5..a590a9d 100644
--- a/gash/ustar.scm
+++ b/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)
-  (let ((name (ustar-header-name header))
-        (prefix (ustar-header-prefix header)))
-    (if (string-null? prefix) name
-        (string-append prefix "/" name))))
+(define* (ustar-header-file-name header #:key (strip 0))
+  (let* ((name (ustar-header-name header))
+         (prefix (ustar-header-prefix header))
+         (file-name (if (string-null? 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 (if (zero? strip) file-name
-                        (string-join (list-tail (string-split file-name #\/) strip) "/")))
+         (file-name (ustar-header-file-name header #:strip 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)
-          ((regular)
-           (if (file-exists? file-name) (delete-file file-name))
-           (with-output-to-file file-name thunk #:binary #t))
-          ((directory) (mkdir-p file-name))
-          ((symlink) (symlink (ustar-header-link-name header) file-name )))
-        (thunk))
-    (when (and extract?
-               (not (eq? (ustar-header-type header) 'symlink)))
-      (chmod file-name (ustar-header-mode header))
-      (let ((mtime (ustar-header-mtime header)))
-        (utime file-name mtime mtime)))))
+        (let ((mtime (ustar-header-mtime header)))
+          (case (ustar-header-type header)
+            ((regular)
+             (if (file-exists? file-name) (delete-file file-name))
+             (with-output-to-file file-name thunk #:binary #t)
+             (utime file-name mtime mtime)
+             (chmod file-name (ustar-header-mode header)))
+            ((directory)
+             (mkdir-p file-name)
+             (utime file-name mtime mtime))
+            ((symlink) (symlink (ustar-header-link-name header) file-name ))))
+        (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)))
-    (when (and header
-               (not (eof-object? header)))
-      (unless (zero? verbosity)
-        (display-header header #:verbose? (> verbosity 1)))
-      (read-ustar-file in header #:extract? extract? #:strip strip)
-      (loop (read-ustar-header in)))))
+  (let ((dirs
+         (let loop ((header (read-ustar-header in)) (dirs '()))
+           (if (not (and header (not (eof-object? header)))) dirs
+               (begin
+                 (unless (zero? verbosity)
+                   (display-header header #:verbose? (> verbosity 1)))
+                 (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
diff --git a/test/100-tar-ro.sh b/test/100-tar-ro.sh
new file mode 100644
index 0000000..dde8b10
--- /dev/null
+++ b/test/100-tar-ro.sh
@@ -0,0 +1,3 @@
+\tar -xvf test/data/ro.tar
+\chmod -R +w foo
+\rm -r foo
diff --git a/test/100-tar-ro.stdout b/test/100-tar-ro.stdout
new file mode 100644
index 0000000..3d84aa0
--- /dev/null
+++ b/test/100-tar-ro.stdout
@@ -0,0 +1,3 @@
+foo/
+foo/bar/
+foo/bar/baz
diff --git a/test/data/ro.tar b/test/data/ro.tar
new file mode 100644
index 0000000000000000000000000000000000000000..82ff88a829899354efa04988afa26ebed280b00d
GIT binary patch
literal 10240
zcmeIxO$x#=5QgD7N^W2#Kh1ekXcr1CRNZ)blY-Dqv73nEJDU`SCgJ%q<2;|FaoJKa
zMk$M?Xt!%^)e`l=YH+G9h*b?fiHVKxwQhgE-tuCMobxmdmtptFcm3TTzq>J({QJB#
zeFHV%<N2qOzjL-D|4+P}SN?r|G&`>5A3~YyL-W7p-z6``HoMVg<3FGOjRc<vAb<b@
q2q1s}0tg_000IagfB*srAb<b@2q1s}0tg_000IagfB*tNDDVWu%05p3

literal 0
HcmV?d00001