X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/9b75c1e26efe96f0ed327ee06b0e046a9e5724ed..4b57301e7e3d5bd4701ce705a5dc7dddb37cb1e1:/lisp/dired-aux.el

diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 8661df033e..32c63aba2f 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -11,7 +11,7 @@
 
 ;; GNU Emacs is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
 ;; any later version.
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
@@ -253,9 +253,20 @@ List has a form of (file-name full-file-name (attribute-list))"
 ;;;###autoload
 (defun dired-do-chmod (&optional arg)
   "Change the mode of the marked (or next ARG) files.
-This calls chmod, thus symbolic modes like `g+w' are allowed."
+Symbolic modes like `g+w' are allowed."
   (interactive "P")
-  (dired-do-chxxx "Mode" dired-chmod-program 'chmod arg))
+  (let* ((files (dired-get-marked-files t arg))
+	 (modes (dired-mark-read-string
+		 "Change mode of %s to: " nil
+		 'chmod arg files))
+	 (num-modes (if (string-match "^[0-7]+" modes)
+			(string-to-number modes 8))))
+    (dolist (file files)
+      (set-file-modes
+       file
+       (if num-modes num-modes
+	 (file-modes-symbolic-to-number modes (file-modes file)))))
+    (dired-do-redisplay arg)))
 
 ;;;###autoload
 (defun dired-do-chgrp (&optional arg)
@@ -452,6 +463,56 @@ with a prefix argument."
 
 ;;; Shell commands
 
+(declare-function mailcap-parse-mailcaps "mailcap" (&optional path force))
+(declare-function mailcap-parse-mimetypes "mailcap" (&optional path force))
+(declare-function mailcap-extension-to-mime "mailcap" (extn))
+(declare-function mailcap-mime-info "mailcap"
+                  (string &optional request no-decode))
+
+(defun dired-read-shell-command-default (files)
+  "Return a list of default commands for `dired-read-shell-command'."
+  (require 'mailcap)
+  (mailcap-parse-mailcaps)
+  (mailcap-parse-mimetypes)
+  (let* ((all-mime-type
+	  ;; All unique MIME types from file extensions
+	  (delete-dups (mapcar (lambda (file)
+				 (mailcap-extension-to-mime
+				  (file-name-extension file t)))
+			       files)))
+	 (all-mime-info
+	  ;; All MIME info lists
+	  (delete-dups (mapcar (lambda (mime-type)
+				 (mailcap-mime-info mime-type 'all))
+			       all-mime-type)))
+	 (common-mime-info
+	  ;; Intersection of mime-infos from different mime-types;
+	  ;; or just the first MIME info for a single MIME type
+	  (if (cdr all-mime-info)
+	      (delq nil (mapcar (lambda (mi1)
+				  (unless (memq nil (mapcar
+						     (lambda (mi2)
+						       (member mi1 mi2))
+						     (cdr all-mime-info)))
+				    mi1))
+				(car all-mime-info)))
+	    (car all-mime-info)))
+	 (commands
+	  ;; Command strings from `viewer' field of the MIME info
+	  (delq nil (mapcar (lambda (mime-info)
+			      (let ((command (cdr (assoc 'viewer mime-info))))
+				(if (stringp command)
+				    (replace-regexp-in-string
+				     ;; Replace mailcap's `%s' placeholder
+				     ;; with dired's `?' placeholder
+				     "%s" "?"
+				     (replace-regexp-in-string
+				      ;; Remove the final filename placeholder
+				      "\s*\\('\\)?%s\\1?\s*\\'" "" command nil t)
+				     nil t))))
+			    common-mime-info))))
+    commands))
+
 (defun dired-read-shell-command (prompt arg files)
 ;;  "Read a dired shell command prompting with PROMPT (using read-string).
 ;;ARG is the prefix arg and may be used to indicate in the prompt which
@@ -461,7 +522,8 @@ with a prefix argument."
    nil 'shell files
    (function read-string)
    (format prompt (dired-mark-prompt arg files))
-   nil 'shell-command-history))
+   nil 'shell-command-history
+   (dired-read-shell-command-default files)))
 
 ;; The in-background argument is only needed in Emacs 18 where
 ;; shell-command doesn't understand an appended ampersand `&'.
@@ -1140,6 +1202,8 @@ Special value `always' suppresses confirmation."
   (dired-copy-file-recursive from to ok-flag dired-copy-preserve-time t
 			     dired-recursive-copies))
 
+(declare-function make-symbolic-link "fileio.c")
+
 (defun dired-copy-file-recursive (from to ok-flag &optional
 				       preserve-time top recursive)
   (let ((attrs (file-attributes from))
@@ -1149,7 +1213,8 @@ Special value `always' suppresses confirmation."
 	     (or (eq recursive 'always)
 		 (yes-or-no-p (format "Recursive copies of %s? " from))))
 	;; This is a directory.
-	(let ((files
+	(let ((mode (file-modes from))
+	      (files
 	       (condition-case err
 		   (directory-files from nil dired-re-no-dot)
 		 (file-error
@@ -1163,7 +1228,9 @@ Special value `always' suppresses confirmation."
 	    (if (file-exists-p to)
 		(or top (dired-handle-overwrite to))
 	      (condition-case err
-		  (make-directory to)
+		  (progn
+		    (make-directory to)
+		    (set-file-modes to #o700))
 		(file-error
 		 (push (dired-make-relative from)
 		       dired-create-files-failures)
@@ -1182,7 +1249,9 @@ Special value `always' suppresses confirmation."
 		(file-error
 		 (push (dired-make-relative thisfrom)
 		       dired-create-files-failures)
-		 (dired-log "Copying error for %s:\n%s\n" thisfrom err))))))
+		 (dired-log "Copying error for %s:\n%s\n" thisfrom err)))))
+	  (when (file-directory-p to)
+	    (set-file-modes to mode)))
       ;; Not a directory.
       (or top (dired-handle-overwrite to))
       (condition-case err
@@ -1319,7 +1388,7 @@ Special value `always' suppresses confirmation."
 	skipped (success-count 0) (total (length fn-list)))
     (let (to overwrite-query
 	     overwrite-backup-query)	; for dired-handle-overwrite
-      (mapcar
+      (mapc
        (function
 	(lambda (from)
 	  (setq to (funcall name-constructor from))
@@ -1517,10 +1586,16 @@ Optional arg HOW-TO is used to set the value of the into-dir variable
   "Create a directory called DIRECTORY."
   (interactive
    (list (read-file-name "Create directory: " (dired-current-directory))))
-  (let ((expanded (directory-file-name (expand-file-name directory))))
-    (make-directory expanded)
-    (dired-add-file expanded)
-    (dired-move-to-filename)))
+  (let* ((expanded (directory-file-name (expand-file-name directory)))
+	 (try expanded) new)
+    ;; Find the topmost nonexistent parent dir (variable `new')
+    (while (and try (not (file-exists-p try)) (not (equal new try)))
+      (setq new try
+	    try (directory-file-name (file-name-directory try))))
+    (make-directory expanded t)
+    (when new
+      (dired-add-file new)
+      (dired-move-to-filename))))
 
 (defun dired-into-dir-with-symlinks (target)
   (and (file-directory-p target)
@@ -1993,8 +2068,8 @@ of marked files.  If KILL-ROOT is non-nil, kill DIRNAME as well."
 
 (defun dired-tree-lessp (dir1 dir2)
   ;; Lexicographic order on file name components, like `ls -lR':
-  ;; DIR1 < DIR2 iff DIR1 comes *before* DIR2 in an `ls -lR' listing,
-  ;;   i.e., iff DIR1 is a (grand)parent dir of DIR2,
+  ;; DIR1 < DIR2 if DIR1 comes *before* DIR2 in an `ls -lR' listing,
+  ;;   i.e., if DIR1 is a (grand)parent dir of DIR2,
   ;;   or DIR1 and DIR2 are in the same parentdir and their last
   ;;   components are string-lessp.
   ;; Thus ("/usr/" "/usr/bin") and ("/usr/a/" "/usr/b/") are tree-lessp.