]> code.delx.au - gnu-emacs/blobdiff - lisp/dired-aux.el
Fix pr-interface-map initialization
[gnu-emacs] / lisp / dired-aux.el
index 8661df033ed6c31ebb66c6541c7e1a571f402e59..32c63aba2fef08b3275dba7ae9cd83921abd0b04 100644 (file)
@@ -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."
 \f
 ;;; 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.