diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index c728642917..2d4269daed 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1134,9 +1134,10 @@ dired-compress-file-suffixes ;; "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 @@ dired-compress-file-suffixes ("\\.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. @@ -1253,6 +1254,42 @@ dired-do-compress-to (length in-files) (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) + (when (not (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. @@ -1277,28 +1314,7 @@ dired-compress-file ((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 7f1743f88d..5888f4cd99 100644 --- a/test/lisp/dired-aux-tests.el +++ b/test/lisp/dired-aux-tests.el @@ -158,5 +158,59 @@ dired-test-highlight-metachar (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