[Emacs-diffs] master f6ece24: Add dired-do-compress-to command bound to "c"

[Oleh Krehel]

branch: master
commit f6ece2420c3dc6f3dde06c7f8722f5b0b7e1ef4a
Author: Oleh Krehel <address@hidden>
Commit: Oleh Krehel <address@hidden>

    Add dired-do-compress-to command bound to "c"
    
    * lisp/dired-aux.el (dired-shell-command): Use the caller's
      `default-directory', return the result of `process-file'.
    (dired-compress-file-suffixes): Add comment on why "tar -zxf" isn't
    used by default.
    (dired-compress-files-alist): New defvar.
    (dired-do-compress-to): New command.
    
    * lisp/dired.el (dired-mode-map): Bind `dired-do-compress-to' to "c".
    (dired-do-compress-to): Add an autoload entry.
    
    * etc/NEWS: Add two entries.
---
 etc/NEWS          |    6 ++++
 lisp/dired-aux.el |   76 +++++++++++++++++++++++++++++++++++++++++++++-------
 lisp/dired.el     |   11 +++++++-
 3 files changed, 81 insertions(+), 12 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index ef90268..0cb814b 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -275,6 +275,12 @@ header.
 ** `tabulated-list-print' takes a second optional argument, update,
 which specifies an alternative printing method which is faster when
 few or no entries have changed.
+** The command `dired-do-compress' bound to `Z' now can compress
+directories and decompress zip files.
+** New command `dired-do-compress-to' bound to `c' can be used to compress
+many marked files into a single named archive.  The compression
+command is determined from the new `dired-compress-files-alist'
+variable.
 
 
 * Editing Changes in Emacs 25.1
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 98a974a..5cece27 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -788,19 +788,23 @@ Else returns nil for success."
 
 (defun dired-shell-command (cmd)
   "Run CMD, and check for output.
-On error, pop up the log buffer."
-  (let ((out-buffer " *dired-check-process output*"))
+On error, pop up the log buffer.
+Return the result of `process-file' - zero for success."
+  (let ((out-buffer " *dired-check-process output*")
+        (dir default-directory))
     (with-current-buffer (get-buffer-create out-buffer)
       (erase-buffer)
-      (let ((res (process-file
-                  shell-file-name
-                  nil
-                  t
-                  nil
-                  shell-command-switch
-                  cmd)))
+      (let* ((default-directory dir)
+             (res (process-file
+                   shell-file-name
+                   nil
+                   t
+                   nil
+                   shell-command-switch
+                   cmd)))
         (unless (zerop res)
-          (pop-to-buffer out-buffer))))))
+          (pop-to-buffer out-buffer))
+        res))))
 
 ;; Commands that delete or redisplay part of the dired buffer.
 
@@ -880,7 +884,11 @@ command with a prefix argument (the value does not 
matter)."
       from-file)))
 
 (defvar dired-compress-file-suffixes
-  '(("\\.tar\\.gz\\'" "" "gzip -dc %i | tar -xv")
+  '(
+    ;; "tar -zxf" isn't used because it's not available the on
+    ;; Solaris10 version of tar. Solaris10 becomes obsolete in 2021.
+    ;; Same thing on AIX 7.1.
+    ("\\.tar\\.gz\\'" "" "gzip -dc %i | tar -xv")
     ("\\.gz\\'" "" "gunzip")
     ("\\.tgz\\'" ".tar" "gunzip")
     ("\\.Z\\'" "" "uncompress")
@@ -911,6 +919,52 @@ output file.
 Otherwise, the rule is a compression rule, and compression is done with gzip.
 ARGS are command switches passed to PROGRAM.")
 
+(defvar dired-compress-files-alist
+  '(("\\.tar\\.gz\\'" . "tar -c %i | gzip -c9 > %o")
+    ("\\.zip\\'" . "zip %o -r --filesync %i"))
+  "Control the compression shell command for `dired-do-compress-to'.
+
+Each element is (REGEXP . CMD), where REGEXP is the name of the
+archive to which you want to compress, and CMD the the
+corresponding command.
+
+Within CMD, %i denotes the input file(s), and %o denotes the
+output file. %i path(s) are relative, while %o is absolute.")
+
+;;;###autoload
+(defun dired-do-compress-to ()
+  "Compress selected files and directories to an archive.
+You are prompted for the archive name.
+The archiving command is chosen based on the archive name extension and
+`dired-compress-files-alist'."
+  (interactive)
+  (let* ((in-files (dired-get-marked-files))
+         (out-file (read-file-name "Compress to: "))
+         (rule (cl-find-if
+                (lambda (x)
+                  (string-match (car x) out-file))
+                dired-compress-files-alist)))
+    (cond ((not rule)
+           (error
+            "No compression rule found for %s, see 
`dired-compress-files-alist'"
+            out-file))
+          ((and (file-exists-p out-file)
+                (not (y-or-n-p
+                      (format "%s exists, overwrite?"
+                              (abbreviate-file-name out-file)))))
+           (message "Compression aborted"))
+          (t
+           (when (zerop
+                  (dired-shell-command
+                   (replace-regexp-in-string
+                    "%o" out-file
+                    (replace-regexp-in-string
+                     "%i" (mapconcat #'file-name-nondirectory in-files " ")
+                     (cdr rule)))))
+             (message "Compressed %d file(s) to %s"
+                      (length in-files)
+                      (file-name-nondirectory out-file)))))))
+
 ;;;###autoload
 (defun dired-compress-file (file)
   "Compress or uncompress FILE.
diff --git a/lisp/dired.el b/lisp/dired.el
index e8791f8..bc0139f 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -1466,6 +1466,7 @@ Do so according to the former subdir alist 
OLD-SUBDIR-ALIST."
     (define-key map "T" 'dired-do-touch)
     (define-key map "X" 'dired-do-shell-command)
     (define-key map "Z" 'dired-do-compress)
+    (define-key map "c" 'dired-do-compress-to)
     (define-key map "!" 'dired-do-shell-command)
     (define-key map "&" 'dired-do-async-shell-command)
     ;; Comparison commands
@@ -3896,7 +3897,7 @@ Ask means pop up a menu for the user to select one of 
copy, move or link."
 
 ;;; Start of automatically extracted autoloads.
 
-;;;### (autoloads nil "dired-aux" "dired-aux.el" 
"c4ed2cda4c70d4b38ab52ad03fa9dfda")
+;;;### (autoloads nil "dired-aux" "dired-aux.el" 
"b946c1770b736ddc39eeef00c39425e7")
 ;;; Generated autoloads from dired-aux.el
 
 (autoload 'dired-diff "dired-aux" "\
@@ -4088,6 +4089,14 @@ command with a prefix argument (the value does not 
matter).
 
 \(fn &optional ARG FMT)" t nil)
 
+(autoload 'dired-do-compress-to "dired-aux" "\
+Compress selected files and directories to an archive.
+You are prompted for the archive name.
+The archiving command is chosen based on the archive name extension and
+`dired-compress-files-alist'.
+
+\(fn)" t nil)
+
 (autoload 'dired-compress-file "dired-aux" "\
 Compress or uncompress FILE.
 Return the name of the compressed or uncompressed file.