master 7e395a5: Make dired-compress-file query for a directory to uncompress to

[Lars Ingebrigtsen]

branch: master
commit 7e395a59b025c7f4be49294ad806addf5b1a25c9
Author: Michalis V <mvar.40k@gmail.com>
Commit: Lars Ingebrigtsen <larsi@gnus.org>

    Make dired-compress-file query for a directory to uncompress to
    
    * lisp/dired-aux.el (dired-compress-file-suffixes): Specify the
    directory in the tar targets.
    (dired-uncompress-file): New function (bug#47058).  This asks what
    directory to uncompress to.
    (dired-compress-file): Use it.
---
 etc/NEWS                     |  3 ++
 lisp/dired-aux.el            | 70 +++++++++++++++++++++++++++-----------------
 test/lisp/dired-aux-tests.el | 54 ++++++++++++++++++++++++++++++++++
 3 files changed, 100 insertions(+), 27 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index cbbb6b0..2bdcb64 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1191,6 +1191,9 @@ keys, add the following to your init file:
 Using it instead of 'read-char-choice' allows using 'C-x o'
 to switch to the help window displayed after typing 'C-h'.
 
+---
+*** 'dired-compress-file' now queries for a directory to uncompress to.
+
 +++
 ** New user option 'isearch-allow-motion'.
 When 'isearch-allow-motion' is set, the commands 'beginning-of-buffer',
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 53fbcfb..f2cb745 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -1134,9 +1134,10 @@ present.  A FMT of \"\" will suppress the messaging."
     ;; "tar -zxf" isn't used because it's not available on the
     ;; Solaris 10 version of tar (obsolete in 2024?).
     ;; Same thing on AIX 7.1 (obsolete 2023?) and 7.2 (obsolete 2022?).
-    ("\\.tar\\.gz\\'" "" "gzip -dc %i | tar -xf -")
-    ("\\.tar\\.xz\\'" "" "xz -dc %i | tar -xf -")
-    ("\\.tgz\\'" "" "gzip -dc %i | tar -xf -")
+    ("\\.tar\\.gz\\'" "" "gzip -dc %i | tar -xf - -C %c")
+    ("\\.tar\\.xz\\'" "" "xz -dc %i | tar -xf - -C %c")
+    ("\\.tgz\\'" "" "gzip -dc %i | tar -xf - -C %c")
+    ("\\.tar\\.bz2\\'" "" "bunzip2 -c %i | tar -xf - -C %c")
     ("\\.gz\\'" "" "gzip -d")
     ("\\.lz\\'" "" "lzip -d")
     ("\\.Z\\'" "" "uncompress")
@@ -1148,8 +1149,8 @@ present.  A FMT of \"\" will suppress the messaging."
     ("\\.bz2\\'" "" "bunzip2")
     ("\\.xz\\'" "" "unxz")
     ("\\.zip\\'" "" "unzip -o -d %o %i")
-    ("\\.tar\\.zst\\'" "" "unzstd -c %i | tar -xf -")
-    ("\\.tzst\\'" "" "unzstd -c %i | tar -xf -")
+    ("\\.tar\\.zst\\'" "" "unzstd -c %i | tar -xf - -C %c")
+    ("\\.tzst\\'" "" "unzstd -c %i | tar -xf - -C %c")
     ("\\.zst\\'" "" "unzstd --rm")
     ("\\.7z\\'" "" "7z x -aoa -o%o %i")
     ;; This item controls naming for compression.
@@ -1254,6 +1255,42 @@ and `dired-compress-files-alist'."
                       (file-name-nondirectory out-file)))))))
 
 ;;;###autoload
+(defun dired-uncompress-file (file dirname command)
+  "Uncompress FILE using COMMAND.
+If file is a tar archive or some other format that supports
+output directory in its parameters, ask user the target directory
+to extract it (defaults to DIRNAME).  Returns the directory or
+filename produced after the uncompress operation."
+  (if (string-match "%[ioc]" command)
+      (let ((extractdir (expand-file-name
+                         (read-file-name
+                          (format "Extract file to (default %s): " dirname)
+                          dirname))))
+        (prog1
+            (file-name-as-directory extractdir)
+          (unless (file-directory-p extractdir)
+            (dired-create-directory extractdir))
+          (dired-shell-command
+           (replace-regexp-in-string
+            "%[oc]" (shell-quote-argument extractdir)
+            (replace-regexp-in-string
+             "%i" (shell-quote-argument file)
+             command
+             nil t)
+            nil t))))
+    ;; We found an uncompression rule without output dir argument
+    (let ((match (string-search " " command))
+          (msg (concat "Uncompressing " file)))
+      (unless (if match
+                  (dired-check-process
+                   msg
+                   (substring command 0 match)
+                   (substring command (1+ match))
+                   file)
+                (dired-check-process msg command file))
+        dirname))))
+
+;;;###autoload
 (defun dired-compress-file (file)
   "Compress or uncompress FILE.
 Return the name of the compressed or uncompressed file.
@@ -1277,28 +1314,7 @@ Return nil if no change in files."
           ((file-symlink-p file)
            nil)
           ((and suffix (setq command (nth 2 suffix)))
-           (if (string-match "%[io]" command)
-               (prog1 (setq newname (file-name-as-directory newname))
-                 (dired-shell-command
-                  (replace-regexp-in-string
-                   "%o" (shell-quote-argument newname)
-                   (replace-regexp-in-string
-                    "%i" (shell-quote-argument file)
-                    command
-                    nil t)
-                   nil t)))
-             ;; We found an uncompression rule.
-             (let ((match (string-search " " command))
-                   (msg (concat "Uncompressing " file)))
-               (unless (if match
-                           (dired-check-process msg
-                                                (substring command 0 match)
-                                                (substring command (1+ match))
-                                                file)
-                         (dired-check-process msg
-                                              command
-                                              file))
-                 newname))))
+           (dired-uncompress-file file newname command))
           (t
            ;; We don't recognize the file as compressed, so compress it.
            ;; Try gzip; if we don't have that, use compress.
diff --git a/test/lisp/dired-aux-tests.el b/test/lisp/dired-aux-tests.el
index 7f1743f..5888f4c 100644
--- a/test/lisp/dired-aux-tests.el
+++ b/test/lisp/dired-aux-tests.el
@@ -158,5 +158,59 @@
     (should (string-match (regexp-quote command) (nth 0 lines)))
     (dired-test--check-highlighting (nth 0 lines) '(8))))
 
+(ert-deftest dired-test-bug47058-tar ()
+  "test for https://debbugs.gnu.org/47058 ."
+  (dired-test-bug47058-fn "tar -cf - %i | gzip -c9 > %o"
+                           "gzip -dc %i | tar -xf - -C %c"
+                           ".tar.gz"))
+
+(ert-deftest dired-test-bug47058-zip ()
+  "test for https://debbugs.gnu.org/47058 ."
+  (dired-test-bug47058-fn "zip %o -r --filesync %i"
+                           "unzip -o -d %o %i"
+                           ".zip"))
+
+(defun dired-test-bug47058-fn (compress-cmd uncompress-cmd extension)
+  "helper fn for testing https://debbugs.gnu.org/47058 ."
+  (let* ((base-file (make-temp-file "dired-test-47058-"))
+         (archive-file (concat base-file extension))
+         (file1 (make-temp-file "a"))
+         (file2 (make-temp-file "b"))
+         (file3 (make-temp-file "c"))
+         (filelist (list file1 file2 file3))
+         (comprcmd (replace-regexp-in-string
+                  "%c" (shell-quote-argument temporary-file-directory)
+                  (replace-regexp-in-string
+                   "%i" (mapconcat 'identity filelist " ")
+                   (replace-regexp-in-string
+                    "%o" (shell-quote-argument archive-file)
+                    compress-cmd)))))
+    (cl-letf (((symbol-function 'read-file-name)
+               (lambda (&rest _) base-file)))
+      (dired-delete-file base-file)
+      (should-not (file-exists-p base-file))
+      (should-not (file-exists-p archive-file))
+      (dired-shell-command comprcmd)
+      (should (file-exists-p archive-file))
+      (mapcar (lambda (f) (should (file-exists-p f)))
+              filelist)
+      (mapcar (lambda (f) (delete-file f))
+              filelist)
+      (mapcar (lambda (f) (should-not (file-exists-p f)))
+              filelist)
+      (should (string-equal
+               (dired-uncompress-file archive-file
+                                      base-file
+                                      uncompress-cmd)
+               (file-name-as-directory base-file)))
+      (mapcar (lambda (f)
+                (should (file-exists-p
+                         (concat (file-name-as-directory base-file) f))))
+              filelist)
+      (dired-delete-file base-file 'always' nil)
+      (dired-delete-file archive-file 'always' nil)
+      (should-not (file-exists-p base-file))
+      (should-not (file-exists-p archive-file)))))
+
 (provide 'dired-aux-tests)
 ;; dired-aux-tests.el ends here