X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/0f0c86fc73f3864a68b25ad94d9da561603aae3b..0b22a5e17ba44f559664af2d59c4828bfe56baaa:/lisp/dired.el diff --git a/lisp/dired.el b/lisp/dired.el index 5d0e41fee7..d53a6831b1 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1,7 +1,7 @@ ;;; dired.el --- directory-browsing commands ;; Copyright (C) 1985, 1986, 1992, 1993, 1994, 1995, 1996, 1997, 2000, -;; 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. +;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Sebastian Kremer ;; Maintainer: FSF @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -20,9 +20,7 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -35,6 +33,8 @@ ;;; Code: +(eval-when-compile (require 'cl)) + ;;; Customizable variables (defgroup dired nil @@ -70,7 +70,7 @@ If nil, `dired-listing-switches' is used.") ;;;###autoload (defvar dired-chown-program - (if (memq system-type '(hpux dgux usg-unix-v irix linux gnu/linux cygwin)) + (if (memq system-type '(hpux usg-unix-v irix linux gnu/linux cygwin)) "chown" (if (file-exists-p "/usr/sbin/chown") "/usr/sbin/chown" @@ -344,6 +344,17 @@ Subexpression 2 must end right before the \\n or \\r.") (defvar dired-warning-face 'dired-warning "Face name used for a part of a buffer that needs user attention.") +(defface dired-perm-write + '((((type w32 pc)) :inherit default) ;; These default to rw-rw-rw. + ;; Inherit from font-lock-comment-delimiter-face since with min-colors 8 + ;; font-lock-comment-face is not colored any more. + (t (:inherit font-lock-comment-delimiter-face))) + "Face used to highlight permissions of group- and world-writable files." + :group 'dired-faces + :version "22.2") +(defvar dired-perm-write-face 'dired-perm-write + "Face name used for permissions of group- and world-writable files.") + (defface dired-directory '((t (:inherit font-lock-function-name-face))) "Face used for subdirectories." @@ -405,10 +416,10 @@ Subexpression 2 must end right before the \\n or \\r.") ;; fields with keymaps to frob the permissions, somewhat a la XEmacs. (list (concat dired-re-maybe-mark dired-re-inode-size "[-d]....\\(w\\)....") ; group writable - '(1 dired-warning-face)) + '(1 dired-perm-write-face)) (list (concat dired-re-maybe-mark dired-re-inode-size "[-d].......\\(w\\).") ; world writable - '(1 dired-warning-face)) + '(1 dired-perm-write-face)) ;; ;; Subdirectories. (list dired-re-dir @@ -453,7 +464,7 @@ PREDICATE is evaluated on each line, with point at beginning of line. MSG is a noun phrase for the type of files being marked. It should end with a noun that can be pluralized by adding `s'. Return value is the number of files marked, or nil if none were marked." - `(let (buffer-read-only count) + `(let ((inhibit-read-only t) count) (save-excursion (setq count 0) (if ,msg (message "Marking %ss..." ,msg)) @@ -499,7 +510,7 @@ return (t FILENAME) instead of (FILENAME)." ;;endless loop. ;;This warning should not apply any longer, sk 2-Sep-1991 14:10. `(prog1 - (let (buffer-read-only case-fold-search found results) + (let ((inhibit-read-only t) case-fold-search found results) (if ,arg (if (integerp ,arg) (progn ;; no save-excursion, want to move point. @@ -576,18 +587,52 @@ Don't use that together with FILTER." (defun dired-read-dir-and-switches (str) ;; For use in interactive. - (reverse (list - (if current-prefix-arg - (read-string "Dired listing switches: " - dired-listing-switches)) - ;; If a dialog is about to be used, call read-directory-name so - ;; the dialog code knows we want directories. Some dialogs can - ;; only select directories or files when popped up, not both. - (if (next-read-file-uses-dialog-p) - (read-directory-name (format "Dired %s(directory): " str) - nil default-directory nil) - (read-file-name (format "Dired %s(directory): " str) - nil default-directory nil))))) + (reverse + (list + (if current-prefix-arg + (read-string "Dired listing switches: " + dired-listing-switches)) + ;; If a dialog is about to be used, call read-directory-name so + ;; the dialog code knows we want directories. Some dialogs can + ;; only select directories or files when popped up, not both. + (if (next-read-file-uses-dialog-p) + (read-directory-name (format "Dired %s(directory): " str) + nil default-directory nil) + (let ((cie ())) + (dolist (ext completion-ignored-extensions) + (if (eq ?/ (aref ext (1- (length ext)))) (push ext cie))) + (setq cie (concat (regexp-opt cie "\\(?:") "\\'")) + (lexical-let* ((default (and buffer-file-name + (abbreviate-file-name buffer-file-name))) + (cie cie) + (completion-table + ;; We need a mix of read-file-name and + ;; read-directory-name so that completion to directories + ;; is preferred, but if the user wants to enter a global + ;; pattern, he can still use completion on filenames to + ;; help him write the pattern. + ;; Essentially, we want to use + ;; (completion-table-with-predicate + ;; 'read-file-name-internal 'file-directory-p nil) + ;; but that doesn't work because read-file-name-internal + ;; does not obey its `predicate' argument. + (completion-table-in-turn + (lambda (str pred action) + (let ((read-file-name-predicate + (lambda (f) + (and (not (member f '("./" "../"))) + ;; Hack! Faster than file-directory-p! + (eq (aref f (1- (length f))) ?/) + (not (string-match cie f)))))) + (complete-with-action + action 'read-file-name-internal str nil))) + 'read-file-name-internal))) + (minibuffer-with-setup-hook + (lambda () + (setq minibuffer-default default) + (setq minibuffer-completion-table completion-table)) + (read-file-name (format "Dired %s(directory): " str) + nil default-directory nil)))))))) ;;;###autoload (define-key ctl-x-map "d" 'dired) ;;;###autoload @@ -796,7 +841,7 @@ wildcards, erases the buffer, and builds the subdir-alist anew (make-local-variable 'file-name-coding-system) (setq file-name-coding-system (or coding-system-for-read file-name-coding-system)) - (let (buffer-read-only + (let ((inhibit-read-only t) ;; Don't make undo entries for readin. (buffer-undo-list t)) (widen) @@ -999,7 +1044,9 @@ If HDR is non-nil, insert a header line with the directory name." ;; Insert text at the beginning to standardize things. (save-excursion (goto-char opoint) - (if (and (or hdr wildcard) (not (looking-at "^ /.*:$"))) + (if (and (or hdr wildcard) + (not (and (looking-at "^ \\(.*\\):$") + (file-name-absolute-p (match-string 1))))) ;; Note that dired-build-subdir-alist will replace the name ;; by its expansion, so it does not matter whether what we insert ;; here is fully expanded, but it should be absolute. @@ -1040,7 +1087,7 @@ Preserves old cursor, marks/flags, hidden-p." (hidden-subdirs (dired-remember-hidden)) (old-subdir-alist (cdr (reverse dired-subdir-alist))) ; except pwd (case-fold-search nil) ; we check for upper case ls flags - buffer-read-only) + (inhibit-read-only t)) (goto-char (point-min)) (setq mark-alist;; only after dired-remember-hidden since this unhides: (dired-remember-marks (point-min) (point-max))) @@ -1074,7 +1121,7 @@ Preserves old cursor, marks/flags, hidden-p." (defun dired-remember-marks (beg end) "Return alist of files and their marks, from BEG to END." (if selective-display ; must unhide to make this work. - (let (buffer-read-only) + (let ((inhibit-read-only t)) (subst-char-in-region beg end ?\r ?\n))) (let (fil chr alist) (save-excursion @@ -1249,6 +1296,7 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." (define-key map "$" 'dired-hide-subdir) (define-key map "\M-$" 'dired-hide-all) ;; misc + (define-key map "\C-x\C-q" 'dired-toggle-read-only) (define-key map "?" 'dired-summary) (define-key map "\177" 'dired-unmark-backward) (define-key map [remap undo] 'dired-undo) @@ -1266,6 +1314,11 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." (define-key map "\C-tf" 'image-dired-mark-tagged-files) (define-key map "\C-t\C-t" 'image-dired-dired-insert-marked-thumbs) (define-key map "\C-te" 'image-dired-dired-edit-comment-and-tags) + ;; encryption and decryption (epa-dired) + (define-key map ":d" 'epa-dired-do-decrypt) + (define-key map ":v" 'epa-dired-do-verify) + (define-key map ":s" 'epa-dired-do-sign) + (define-key map ":e" 'epa-dired-do-encrypt) ;; Make menu bar items. @@ -1311,6 +1364,29 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." (define-key map [menu-bar immediate] (cons "Immediate" (make-sparse-keymap "Immediate"))) + (define-key map + [menu-bar immediate epa-dired-do-decrypt] + '(menu-item "Decrypt" epa-dired-do-decrypt + :help "Decrypt file at cursor")) + + (define-key map + [menu-bar immediate epa-dired-do-verify] + '(menu-item "Verify" epa-dired-do-verify + :help "Verify digital signature of file at cursor")) + + (define-key map + [menu-bar immediate epa-dired-do-sign] + '(menu-item "Sign" epa-dired-do-sign + :help "Create digital signature of file at cursor")) + + (define-key map + [menu-bar immediate epa-dired-do-encrypt] + '(menu-item "Encrypt" epa-dired-do-encrypt + :help "Encrypt file at cursor")) + + (define-key map [menu-bar immediate dashes-4] + '("--")) + (define-key map [menu-bar immediate image-dired-dired-display-external] '(menu-item "Display Image Externally" image-dired-dired-display-external @@ -1352,9 +1428,12 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." '(menu-item "Find This File" dired-find-file :help "Edit file at cursor")) (define-key map [menu-bar immediate create-directory] - '(menu-item "Create Directory..." dired-create-directory)) + '(menu-item "Create Directory..." dired-create-directory + :help "Create a directory")) (define-key map [menu-bar immediate wdired-mode] - '(menu-item "Edit File Names" wdired-change-to-wdired-mode)) + '(menu-item "Edit File Names" wdired-change-to-wdired-mode + :help "Put a dired buffer in a mode in which filenames are editable" + :filter (lambda (x) (if (eq major-mode 'dired-mode) x)))) (define-key map [menu-bar regexp] (cons "Regexp" (make-sparse-keymap "Regexp"))) @@ -1453,6 +1532,7 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." (define-key map [menu-bar operate] (cons "Operate" (make-sparse-keymap "Operate"))) + (define-key map [menu-bar operate image-dired-delete-tag] '(menu-item "Delete Image Tag..." image-dired-delete-tag @@ -1650,24 +1730,34 @@ Keybindings: This doesn't recover lost files, it just undoes changes in the buffer itself. You can use it to recover marks, killed lines or subdirs." (interactive) - (let (buffer-read-only) + (let ((inhibit-read-only t)) (undo)) (dired-build-subdir-alist) (message "Change in dired buffer undone. Actual changes in files cannot be undone by Emacs.")) +(defun dired-toggle-read-only () + "Edit dired buffer with Wdired, or set it read-only. +Call `wdired-change-to-wdired-mode' in dired buffers whose editing is +supported by Wdired (the major mode of the dired buffer is `dired-mode'). +Otherwise, for buffers inheriting from dired-mode, call `toggle-read-only'." + (interactive) + (if (eq major-mode 'dired-mode) + (wdired-change-to-wdired-mode) + (toggle-read-only))) + (defun dired-next-line (arg) "Move down lines then position at filename. Optional prefix ARG says how many lines to move; default is one line." (interactive "p") - (next-line arg) + (forward-line arg) (dired-move-to-filename)) (defun dired-previous-line (arg) "Move up lines then position at filename. Optional prefix ARG says how many lines to move; default is one line." (interactive "p") - (previous-line arg) + (forward-line (- arg)) (dired-move-to-filename)) (defun dired-next-dirline (arg &optional opoint) @@ -1983,7 +2073,7 @@ Return the position of the beginning of the filename, or nil if none found." (forward-char -1)))) (or no-error (not (eq opoint (point))) - (error (if hidden + (error "%s" (if hidden (substitute-command-keys "File line is hidden, type \\[dired-hide-subdir] to unhide") "No file on this line"))) @@ -2193,7 +2283,7 @@ instead of `dired-actual-switches'." (dired-clear-alist) (save-excursion (let* ((count 0) - (buffer-read-only nil) + (inhibit-read-only t) (buffer-undo-list t) (switches (or switches dired-actual-switches)) new-dir-name @@ -2409,8 +2499,8 @@ Anything else, ask for each sub-directory." "In Dired, delete the files flagged for deletion. If NOMESSAGE is non-nil, we don't display any message if there are no flagged files. -`dired-recursive-deletes' controls whether -deletion of non-empty directories is allowed." +`dired-recursive-deletes' controls whether deletion of +non-empty directories is allowed." (interactive) (let* ((dired-marker-char dired-del-marker) (regexp (dired-marker-regexp)) @@ -2427,8 +2517,8 @@ deletion of non-empty directories is allowed." (defun dired-do-delete (&optional arg) "Delete all marked (or next ARG) files. -`dired-recursive-deletes' controls whether -deletion of non-empty directories is allowed." +`dired-recursive-deletes' controls whether deletion of +non-empty directories is allowed." ;; This is more consistent with the file marking feature than ;; dired-do-flagged-delete. (interactive "P") @@ -2461,7 +2551,7 @@ deletion of non-empty directories is allowed." (let (failures);; files better be in reverse order for this loop! (while l (goto-char (cdr (car l))) - (let (buffer-read-only) + (let ((inhibit-read-only t)) (condition-case err (let ((fn (car (car l)))) (dired-delete-file fn dired-recursive-deletes) @@ -2503,7 +2593,7 @@ deletion of non-empty directories is allowed." (defun dired-delete-entry (file) (save-excursion (and (dired-goto-file file) - (let (buffer-read-only) + (let ((inhibit-read-only t)) (delete-region (progn (beginning-of-line) (point)) (save-excursion (forward-line 1) (point)))))) (dired-clean-up-after-deletion file)) @@ -2524,8 +2614,10 @@ deletion of non-empty directories is allowed." (if (= 1 count) "" "s")) (defun dired-mark-prompt (arg files) - ;; Return a string for use in a prompt, either the current file - ;; name, or the marker and a count of marked files. + "Return a string for use in a prompt, either the current file +name, or the marker and a count of marked files." + ;; distinguish-one-marked can cause the first element to be just t. + (if (eq (car files) t) (setq files (cdr files))) (let ((count (length files))) (if (= count 1) (car files) @@ -2624,31 +2716,9 @@ just the current file." (apply function args)))) (defun dired-format-columns-of-files (files) - ;; Files should be in forward order for this loop. - ;; i.e., (car files) = first file in buffer. - ;; Returns the number of lines used. - (let* ((maxlen (+ 2 (apply 'max (mapcar 'length files)))) - (width (- (window-width (selected-window)) 2)) - (columns (max 1 (/ width maxlen))) - (nfiles (length files)) - (rows (+ (/ nfiles columns) - (if (zerop (% nfiles columns)) 0 1))) - (i 0) - (j 0)) - (setq files (nconc (copy-sequence files) ; fill up with empty fns - (make-list (- (* columns rows) nfiles) ""))) - (setcdr (nthcdr (1- (length files)) files) files) ; make circular - (while (< j rows) - (while (< i columns) - (indent-to (* i maxlen)) - (insert (car files)) - (setq files (nthcdr rows files) - i (1+ i))) - (insert "\n") - (setq i 0 - j (1+ j) - files (cdr files))) - rows)) + (let ((beg (point))) + (completion--insert-strings files) + (put-text-property beg (point) 'mouse-face nil))) ;; Commands to mark or flag file(s) at or near current line. @@ -2714,7 +2784,7 @@ just the current file." (following-char)))))) (defun dired-mark-files-in-region (start end) - (let (buffer-read-only) + (let ((inhibit-read-only t)) (if (> start end) (error "start > end")) (goto-char start) ; assumed at beginning of line @@ -2739,7 +2809,7 @@ this subdir." (interactive "P") (if (dired-get-subdir) (save-excursion (dired-mark-subdir-files)) - (let (buffer-read-only) + (let ((inhibit-read-only t)) (dired-repeat-over-lines (prefix-numeric-value arg) (function (lambda () (delete-char 1) (insert dired-marker-char))))))) @@ -2774,7 +2844,7 @@ As always, hidden subdirs are not affected." (interactive) (save-excursion (goto-char (point-min)) - (let (buffer-read-only) + (let ((inhibit-read-only t)) (while (not (eobp)) (or (dired-between-files) (looking-at dired-re-dot) @@ -2954,7 +3024,7 @@ OLD and NEW are both characters used to mark files." (if (or (eq old ?\r) (eq new ?\r)) (ding) (let ((string (format "\n%c" old)) - (buffer-read-only)) + (inhibit-read-only t)) (save-excursion (goto-char (point-min)) (while (search-forward string nil t) @@ -2979,7 +3049,7 @@ Type \\[help-command] at that time for help." (interactive "cRemove marks (RET means all): \nP") (save-excursion (let* ((count 0) - buffer-read-only case-fold-search query + (inhibit-read-only t) case-fold-search query (string (format "\n%c" mark)) (help-form "\ Type SPC or `y' to unmark one file, DEL or `n' to skip to next, @@ -3223,7 +3293,7 @@ Anything else means ask for each directory." (defun dired-dnd-popup-notice () (message-box - "Recursive copies not enabled.\nSee variable dired-recursive-copies.")) + "Dired recursive copies are currently disabled.\nSee the variable `dired-recursive-copies'.")) (defun dired-dnd-do-ask-action (uri) @@ -3242,43 +3312,59 @@ Anything else means ask for each directory." (dired-dnd-handle-local-file uri action) nil))) +(declare-function dired-relist-entry "dired-aux" (file)) +(declare-function make-symbolic-link "fileio.c") + +;; Only used when (featurep 'dnd). +(declare-function dnd-get-local-file-name "dnd" (uri &optional must-exist)) +(declare-function dnd-get-local-file-uri "dnd" (uri)) + (defun dired-dnd-handle-local-file (uri action) "Copy, move or link a file to the dired directory. URI is the file to handle, ACTION is one of copy, move, link or ask. Ask means pop up a menu for the user to select one of copy, move or link." (require 'dired-aux) (let* ((from (dnd-get-local-file-name uri t)) - (to (if from (concat (dired-current-directory) - (file-name-nondirectory from)) - nil))) - (if from - (cond ((or (eq action 'copy) - (eq action 'private)) ; Treat private as copy. - - ;; If copying a directory and dired-recursive-copies is nil, - ;; dired-copy-file silently fails. Pop up a notice. - (if (and (file-directory-p from) - (not dired-recursive-copies)) - (dired-dnd-popup-notice) - (progn - (dired-copy-file from to 1) - (dired-relist-entry to) - action))) - - ((eq action 'move) - (dired-rename-file from to 1) - (dired-relist-entry to) - action) - - ((eq action 'link) - (make-symbolic-link from to 1) - (dired-relist-entry to) - action) - - ((eq action 'ask) - (dired-dnd-do-ask-action uri)) - - (t nil))))) + (to (when from + (concat (dired-current-directory) + (file-name-nondirectory from))))) + (when from + (cond ((eq action 'ask) + (dired-dnd-do-ask-action uri)) + ;; If copying a directory and dired-recursive-copies is + ;; nil, dired-copy-file fails. Pop up a notice. + ((and (memq action '(copy private)) + (file-directory-p from) + (not dired-recursive-copies)) + (dired-dnd-popup-notice)) + ((memq action '(copy private move link)) + (let ((overwrite (and (file-exists-p to) + (y-or-n-p + (format "Overwrite existing file `%s'? " to)))) + ;; Binding dired-overwrite-confirmed to nil makes + ;; dired-handle-overwrite a no-op. We instead use + ;; y-or-n-p, which pops a graphical menu. + dired-overwrite-confirmed backup-file) + (when (and overwrite + ;; d-b-o is defined in dired-aux. + (boundp 'dired-backup-overwrite) + dired-backup-overwrite + (setq backup-file + (car (find-backup-file-name to))) + (or (eq dired-backup-overwrite 'always) + (y-or-n-p + (format + "Make backup for existing file `%s'? " to)))) + (rename-file to backup-file 0) + (dired-relist-entry backup-file)) + (cond ((memq action '(copy private)) + (dired-copy-file from to overwrite)) + ((eq action 'move) + (dired-rename-file from to overwrite)) + ((eq action 'link) + (make-symbolic-link from to overwrite))) + (dired-relist-entry to) + action)))))) (defun dired-dnd-handle-file (uri action) "Copy, move or link a file to the dired directory if it is a local file. @@ -3325,7 +3411,7 @@ Ask means pop up a menu for the user to select one of copy, move or link." (dired dired-dir) ;; The following elements of `desktop-buffer-misc' are the keys ;; from `dired-subdir-alist'. - (mapcar 'dired-maybe-insert-subdir (cdr desktop-buffer-misc)) + (mapc 'dired-maybe-insert-subdir (cdr desktop-buffer-misc)) (current-buffer)) (message "Desktop: Directory %s no longer exists." dir) (when desktop-missing-file-warning (sit-for 1))