X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/d607b96bc2824116a8fe0e5840ce49da7ce4514f..7400048f602459209e89da4680ed9cc351ace4ee:/lisp/dired-aux.el diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 764d13f5a9..8e4b3b5c6a 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1,7 +1,6 @@ ;;; dired-aux.el --- less commonly used parts of dired -;; Copyright (C) 1985, 1986, 1992, 1994, 1998, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Copyright (C) 1985-1986, 1992, 1994, 1998, 2000-2011 ;; Free Software Foundation, Inc. ;; Author: Sebastian Kremer . @@ -230,14 +229,17 @@ List has a form of (file-name full-file-name (attribute-list))." (defun dired-touch-initial (files) "Create initial input value for `touch' command." - (let (initial) - (while files - (let ((current (nth 5 (file-attributes (car files))))) - (if (and initial (not (equal initial current))) - (setq initial (current-time) files nil) - (setq initial current)) - (setq files (cdr files)))) - (format-time-string "%Y%m%d%H%M.%S" initial))) + ;; Nobody can explain what this version is supposed to do. (Bug#6887) + ;; Also, the manual says it uses "the present time". + ;;; (let (initial) + ;;; (while files + ;;; (let ((current (nth 5 (file-attributes (car files))))) + ;;; (if (and initial (not (equal initial current))) + ;;; (setq initial (current-time) files nil) + ;;; (setq initial current)) + ;;; (setq files (cdr files)))) + ;;; (format-time-string "%Y%m%d%H%M.%S" initial))) + (format-time-string "%Y%m%d%H%M.%S" (current-time))) (defun dired-do-chxxx (attribute-name program op-symbol arg) ;; Change file attributes (mode, group, owner, timestamp) of marked files and @@ -460,6 +462,8 @@ with a prefix argument." (funcall fun file)))) (forward-line 1))))) +(defvar backup-extract-version-start) ; used in backup-extract-version + (defun dired-collect-file-versions (fn) (let ((fn (file-name-sans-versions fn))) ;; Only do work if this file is not already in the alist. @@ -510,18 +514,22 @@ to the end of the list of defaults just after the default value." ;; This is an extra function so that you can redefine it, e.g., to use gmhist. (defun dired-read-shell-command (prompt arg files) - "Read a dired shell command prompting with PROMPT (using `read-shell-command'). -ARG is the prefix arg and may be used to indicate in the prompt which -FILES are affected." + "Read a dired shell command prompting with PROMPT. +Passes the prefix argument ARG to `dired-mark-prompt', so that it +can be used in the prompt to indicate which FILES are affected. +Normally reads the command with `read-shell-command', but if the +`dired-x' packages is loaded, uses `dired-guess-shell-command' to offer +a smarter default choice of shell command." (minibuffer-with-setup-hook (lambda () (set (make-local-variable 'minibuffer-default-add-function) 'minibuffer-default-add-dired-shell-commands)) - (dired-mark-pop-up - nil 'shell files - #'read-shell-command - (format prompt (dired-mark-prompt arg files)) - nil nil))) + (setq prompt (format prompt (dired-mark-prompt arg files))) + (if (featurep 'dired-x) + (dired-mark-pop-up nil 'shell files + #'dired-guess-shell-command prompt files) + (dired-mark-pop-up nil 'shell files + #'read-shell-command prompt nil nil)))) ;;;###autoload (defun dired-do-async-shell-command (command &optional arg file-list) @@ -625,7 +633,7 @@ can be produced by `dired-get-marked-files', for example." (defvar dired-mark-separator " " "Separates marked files in dired shell commands.") -(defun dired-shell-stuff-it (command file-list on-each &optional raw-arg) +(defun dired-shell-stuff-it (command file-list on-each &optional _raw-arg) ;; "Make up a shell command line from COMMAND and FILE-LIST. ;; If ON-EACH is t, COMMAND should be applied to each file, else ;; simply concat all files and apply COMMAND to this. @@ -889,55 +897,35 @@ Otherwise, the rule is a compression rule, and compression is done with gzip.") (downcase string) count total (dired-plural-s total)) failures))))) -(defvar dired-query-alist - '((?y . y) (?\040 . y) ; `y' or SPC means accept once - (?n . n) (?\177 . n) ; `n' or DEL skips once - (?! . yes) ; `!' accepts rest - (?q . no) (?\e . no) ; `q' or ESC skips rest - ;; None of these keys quit - use C-g for that. - )) - ;;;###autoload -(defun dired-query (qs-var qs-prompt &rest qs-args) - "Query user and return nil or t. -Store answer in symbol VAR (which must initially be bound to nil). -Format PROMPT with ARGS. -Binding variable `help-form' will help the user who types the help key." - (let* ((char (symbol-value qs-var)) - (action (cdr (assoc char dired-query-alist)))) - (cond ((eq 'yes action) - t) ; accept, and don't ask again - ((eq 'no action) - nil) ; skip, and don't ask again - (t;; no lasting effects from last time we asked - ask now - (let ((cursor-in-echo-area t) - (executing-kbd-macro executing-kbd-macro) - (qprompt (concat qs-prompt - (if help-form - (format " [Type yn!q or %s] " - (key-description - (char-to-string help-char))) - " [Type y, n, q or !] "))) - done result elt) - (while (not done) - (apply 'message qprompt qs-args) - (setq char (set qs-var (read-event))) - (if (numberp char) - (cond ((and executing-kbd-macro (= char -1)) - ;; read-event returns -1 if we are in a kbd - ;; macro and there are no more events in the - ;; macro. Attempt to get an event - ;; interactively. - (setq executing-kbd-macro nil)) - ((eq (key-binding (vector char)) 'keyboard-quit) - (keyboard-quit)) - (t - (setq done (setq elt (assoc char - dired-query-alist))))))) - ;; Display the question with the answer. - (message "%s" (concat (apply 'format qprompt qs-args) - (char-to-string char))) - (memq (cdr elt) '(t y yes))))))) +(defun dired-query (sym prompt &rest args) + "Format PROMPT with ARGS, query user, and store the result in SYM. +The return value is either nil or t. + +The user may type y or SPC to accept once; n or DEL to skip once; +! to accept this and subsequent queries; or q or ESC to decline +this and subsequent queries. + +If SYM is already bound to a non-nil value, this function may +return automatically without querying the user. If SYM is !, +return t; if SYM is q or ESC, return nil." + (let* ((char (symbol-value sym)) + (char-choices '(?y ?\s ?n ?\177 ?! ?q ?\e))) + (cond ((eq char ?!) + t) ; accept, and don't ask again + ((memq char '(?q ?\e)) + nil) ; skip, and don't ask again + (t ; no previous answer - ask now + (setq prompt + (concat (apply 'format prompt args) + (if help-form + (format " [Type yn!q or %s] " + (key-description + (char-to-string help-char))) + " [Type y, n, q or !] "))) + (set sym (setq char (read-char-choice prompt char-choices))) + (if (memq char '(?y ?\s ?!)) t))))) + ;;;###autoload (defun dired-do-compress (&optional arg) @@ -1019,10 +1007,14 @@ See Info node `(emacs)Subdir switches' for more details." ;; message much faster than making dired-map-over-marks show progress (dired-uncache (if (consp dired-directory) (car dired-directory) dired-directory)) - (dired-map-over-marks (let ((fname (dired-get-filename))) + (dired-map-over-marks (let ((fname (dired-get-filename)) + ;; Postphone readin hook till we map + ;; over all marked files (Bug#6810). + (dired-after-readin-hook nil)) (message "Redisplaying... %s" fname) (dired-update-file-line fname)) arg) + (run-hooks 'dired-after-readin-hook) (dired-move-to-filename) (message "Redisplaying...done"))) @@ -1038,9 +1030,9 @@ See Info node `(emacs)Subdir switches' for more details." ;; Keeps any marks that may be present in column one (doing this ;; here is faster than with dired-add-entry's optional arg). ;; Does not update other dired buffers. Use dired-relist-entry for that. - (let ((char (following-char)) - (opoint (line-beginning-position)) - (buffer-read-only)) + (let* ((opoint (line-beginning-position)) + (char (char-after opoint)) + (buffer-read-only)) (delete-region opoint (progn (forward-line 1) (point))) (if file (progn @@ -1056,92 +1048,123 @@ See Info node `(emacs)Subdir switches' for more details." (file-name-directory filename) (file-name-nondirectory filename) (function dired-add-entry) filename marker-char)) +(defvar dired-omit-mode) +(declare-function dired-omit-regexp "dired-x" ()) +(defvar dired-omit-localp) + (defun dired-add-entry (filename &optional marker-char relative) - ;; Add a new entry for FILENAME, optionally marking it - ;; with MARKER-CHAR (a character, else dired-marker-char is used). - ;; Note that this adds the entry `out of order' if files sorted by - ;; time, etc. - ;; At least this version inserts in the right subdirectory (if present). - ;; And it skips "." or ".." (see `dired-trivial-filenames'). - ;; Hidden subdirs are exposed if a file is added there. - (setq filename (directory-file-name filename)) - ;; Entry is always for files, even if they happen to also be directories - (let* ((opoint (point)) - (cur-dir (dired-current-directory)) - (orig-file-name filename) - (directory (if relative cur-dir (file-name-directory filename))) - reason) - (setq filename - (if relative - (file-relative-name filename directory) - (file-name-nondirectory filename)) - reason - (catch 'not-found - (if (string= directory cur-dir) - (progn - (skip-chars-forward "^\r\n") - (if (eq (following-char) ?\r) - (dired-unhide-subdir)) - ;; We are already where we should be, except when - ;; point is before the subdir line or its total line. - (let ((p (dired-after-subdir-garbage cur-dir))) - (if (< (point) p) - (goto-char p)))) - ;; else try to find correct place to insert - (if (dired-goto-subdir directory) - (progn ;; unhide if necessary - (if (looking-at "\r") ;; point is at end of subdir line - (dired-unhide-subdir)) - ;; found - skip subdir and `total' line - ;; and uninteresting files like . and .. - ;; This better not moves into the next subdir! - (dired-goto-next-nontrivial-file)) - ;; not found - (throw 'not-found "Subdir not found"))) - (let (buffer-read-only opoint) - (beginning-of-line) - (setq opoint (point)) - ;; Don't expand `.'. Show just the file name within directory. - (let ((default-directory directory)) - (dired-insert-directory directory - (concat dired-actual-switches " -d") - (list filename))) - (goto-char opoint) - ;; Put in desired marker char. - (when marker-char - (let ((dired-marker-char - (if (integerp marker-char) marker-char dired-marker-char))) - (dired-mark nil))) - ;; Compensate for a bug in ange-ftp. - ;; It inserts the file's absolute name, rather than - ;; the relative one. That may be hard to fix since it - ;; is probably controlled by something in ftp. - (goto-char opoint) - (let ((inserted-name (dired-get-filename 'verbatim))) - (if (file-name-directory inserted-name) - (let (props) - (end-of-line) - (forward-char (- (length inserted-name))) - (setq props (text-properties-at (point))) - (delete-char (length inserted-name)) - (let ((pt (point))) - (insert filename) - (set-text-properties pt (point) props)) - (forward-char 1)) - (forward-line 1))) - (forward-line -1) - (if dired-after-readin-hook ;; the subdir-alist is not affected... - (save-excursion ;; ...so we can run it right now: - (save-restriction - (beginning-of-line) - (narrow-to-region (point) (line-beginning-position 2)) - (run-hooks 'dired-after-readin-hook)))) - (dired-move-to-filename)) - ;; return nil if all went well - nil)) - (if reason ; don't move away on failure - (goto-char opoint)) - (not reason))) ; return t on success, nil else + "Add a new dired entry for FILENAME. +Optionally mark it with MARKER-CHAR (a character, else uses +`dired-marker-char'). Note that this adds the entry `out of order' +if files are sorted by time, etc. +Skips files that match `dired-trivial-filenames'. +Exposes hidden subdirectories if a file is added there. + +If `dired-x' is loaded and `dired-omit-mode' is enabled, skips +files matching `dired-omit-regexp'." + (if (or (not (featurep 'dired-x)) + (not dired-omit-mode) + ;; Avoid calling ls for files that are going to be omitted anyway. + (let ((omit-re (dired-omit-regexp))) + (or (string= omit-re "") + (not (string-match omit-re + (cond + ((eq 'no-dir dired-omit-localp) + filename) + ((eq t dired-omit-localp) + (dired-make-relative filename)) + (t + (dired-make-absolute + filename + (file-name-directory filename))))))))) + ;; Do it! + (progn + (setq filename (directory-file-name filename)) + ;; Entry is always for files, even if they happen to also be directories + (let* ((opoint (point)) + (cur-dir (dired-current-directory)) + (directory (if relative cur-dir (file-name-directory filename))) + reason) + (setq filename + (if relative + (file-relative-name filename directory) + (file-name-nondirectory filename)) + reason + (catch 'not-found + (if (string= directory cur-dir) + (progn + (skip-chars-forward "^\r\n") + (if (eq (following-char) ?\r) + (dired-unhide-subdir)) + ;; We are already where we should be, except when + ;; point is before the subdir line or its total line. + (let ((p (dired-after-subdir-garbage cur-dir))) + (if (< (point) p) + (goto-char p)))) + ;; else try to find correct place to insert + (if (dired-goto-subdir directory) + (progn ;; unhide if necessary + (if (looking-at "\r") + ;; Point is at end of subdir line. + (dired-unhide-subdir)) + ;; found - skip subdir and `total' line + ;; and uninteresting files like . and .. + ;; This better not move into the next subdir! + (dired-goto-next-nontrivial-file)) + ;; not found + (throw 'not-found "Subdir not found"))) + (let (buffer-read-only opoint) + (beginning-of-line) + (setq opoint (point)) + ;; Don't expand `.'. + ;; Show just the file name within directory. + (let ((default-directory directory)) + (dired-insert-directory + directory + (concat dired-actual-switches " -d") + (list filename))) + (goto-char opoint) + ;; Put in desired marker char. + (when marker-char + (let ((dired-marker-char + (if (integerp marker-char) marker-char + dired-marker-char))) + (dired-mark nil))) + ;; Compensate for a bug in ange-ftp. + ;; It inserts the file's absolute name, rather than + ;; the relative one. That may be hard to fix since it + ;; is probably controlled by something in ftp. + (goto-char opoint) + (let ((inserted-name (dired-get-filename 'verbatim))) + (if (file-name-directory inserted-name) + (let (props) + (end-of-line) + (forward-char (- (length inserted-name))) + (setq props (text-properties-at (point))) + (delete-char (length inserted-name)) + (let ((pt (point))) + (insert filename) + (set-text-properties pt (point) props)) + (forward-char 1)) + (forward-line 1))) + (forward-line -1) + (if dired-after-readin-hook + ;; The subdir-alist is not affected... + (save-excursion ; ...so we can run it right now: + (save-restriction + (beginning-of-line) + (narrow-to-region (point) + (line-beginning-position 2)) + (run-hooks 'dired-after-readin-hook)))) + (dired-move-to-filename)) + ;; return nil if all went well + nil)) + (if reason ; don't move away on failure + (goto-char opoint)) + (not reason))) ; return t on success, nil else + ;; Don't do it (dired-omit-mode). + ;; Return t for success (perhaps we should return file-exists-p). + t)) (defun dired-after-subdir-garbage (dir) ;; Return pos of first file line of DIR, skipping header and total @@ -1232,21 +1255,20 @@ Special value `always' suppresses confirmation." (defun dired-copy-file-recursive (from to ok-flag &optional preserve-time top recursive) - (let ((attrs (file-attributes from)) - dirfailed) + (let ((attrs (file-attributes from))) (if (and recursive (eq t (car attrs)) (or (eq recursive 'always) (yes-or-no-p (format "Recursive copies of %s? " from)))) ;; This is a directory. - (copy-directory from to dired-copy-preserve-time) + (copy-directory from to preserve-time) ;; Not a directory. (or top (dired-handle-overwrite to)) (condition-case err (if (stringp (car attrs)) ;; It is a symlink (make-symbolic-link (car attrs) to ok-flag) - (copy-file from to ok-flag dired-copy-preserve-time)) + (copy-file from to ok-flag preserve-time)) (file-date-error (push (dired-make-relative from) dired-create-files-failures) @@ -1341,36 +1363,35 @@ Special value `always' suppresses confirmation." (setcar elt cur-dir) (when cons (setcar cons cur-dir)))))) +;; Bound in dired-create-files +(defvar overwrite-query) +(defvar overwrite-backup-query) + ;; The basic function for half a dozen variations on cp/mv/ln/ln -s. (defun dired-create-files (file-creator operation fn-list name-constructor &optional marker-char) + "Create one or more new files from a list of existing files FN-LIST. +This function also handles querying the user, updating Dired +buffers, and displaying a success or failure message. -;; Create a new file for each from a list of existing files. The user -;; is queried, dired buffers are updated, and at the end a success or -;; failure message is displayed - -;; FILE-CREATOR must accept three args: oldfile newfile ok-if-already-exists - -;; It is called for each file and must create newfile, the entry of -;; which will be added. The user will be queried if the file already -;; exists. If oldfile is removed by FILE-CREATOR (i.e, it is a -;; rename), it is FILE-CREATOR's responsibility to update dired -;; buffers. FILE-CREATOR must abort by signaling a file-error if it -;; could not create newfile. The error is caught and logged. +FILE-CREATOR should be a function. It is called once for each +file in FN-LIST, and must create a new file, querying the user +and updating Dired buffers as necessary. It should accept three +arguments: the old file name, the new name, and an argument +OK-IF-ALREADY-EXISTS with the same meaning as in `copy-file'. -;; OPERATION (a capitalized string, e.g. `Copy') describes the -;; operation performed. It is used for error logging. +OPERATION should be a capitalized string describing the operation +performed (e.g. `Copy'). It is used for error logging. -;; FN-LIST is the list of files to copy (full absolute file names). +FN-LIST is the list of files to copy (full absolute file names). -;; NAME-CONSTRUCTOR returns a newfile for every oldfile, or nil to -;; skip. If it skips files for other reasons than a direct user -;; query, it is supposed to tell why (using dired-log). - -;; Optional MARKER-CHAR is a character with which to mark every -;; newfile's entry, or t to use the current marker character if the -;; oldfile was marked. +NAME-CONSTRUCTOR should be a function accepting a single +argument, the name of an old file, and returning either the +corresponding new file name or nil to skip. +Optional MARKER-CHAR is a character with which to mark every +newfile's entry, or t to use the current marker character if the +old file was marked." (let (dired-create-files-failures failures skipped (success-count 0) (total (length fn-list))) (let (to overwrite-query @@ -1400,6 +1421,10 @@ ESC or `q' to not overwrite any of the remaining files, (cond ((integerp marker-char) marker-char) (marker-char (dired-file-marker from)) ; slow (t nil)))) + (when (and (file-directory-p from) + (file-directory-p to) + (eq file-creator 'dired-copy-file)) + (setq to (file-name-directory to))) (condition-case err (progn (funcall file-creator from to dired-overwrite-confirmed) @@ -1528,7 +1553,7 @@ Optional arg HOW-TO determiness how to treat the target. (function (lambda (from) (expand-file-name (file-name-nondirectory from) target))) - (function (lambda (from) target))) + (function (lambda (_from) target))) marker-char)))) ;; Read arguments for a marked-files command that wants a file name, @@ -1615,11 +1640,14 @@ Optional arg HOW-TO determiness how to treat the target. ;;;###autoload (defun dired-create-directory (directory) - "Create a directory called DIRECTORY." + "Create a directory called DIRECTORY. +If DIRECTORY already exists, signal an error." (interactive (list (read-file-name "Create directory: " (dired-current-directory)))) (let* ((expanded (directory-file-name (expand-file-name directory))) (try expanded) new) + (if (file-exists-p expanded) + (error "Cannot create directory %s: file exists" expanded)) ;; Find the topmost nonexistent parent dir (variable `new') (while (and try (not (file-exists-p try)) (not (equal new try))) (setq new try @@ -1719,6 +1747,8 @@ of `dired-dwim-target', which see." ;;; 5K ;;;###begin dired-re.el +(defvar rename-regexp-query) + (defun dired-do-create-files-regexp (file-creator operation arg regexp newname &optional whole-name marker-char) ;; Create a new file for each marked file using regexps. @@ -1730,7 +1760,6 @@ of `dired-dwim-target', which see." ;; instead of only the non-directory part of the file. ;; Optional arg MARKER-CHAR as in dired-create-files. (let* ((fn-list (dired-get-marked-files nil arg)) - (fn-count (length fn-list)) (operation-prompt (concat operation " `%s' to `%s'?")) (rename-regexp-help-form (format "\ Type SPC or `y' to %s one match, DEL or `n' to skip to next, @@ -1839,6 +1868,8 @@ See function `dired-do-rename-regexp' for more info." (function make-symbolic-link) "SymLink" arg regexp newname whole-name dired-keep-marker-symlink)) +(defvar rename-non-directory-query) + (defun dired-create-files-non-directory (file-creator basename-constructor operation arg) ;; Perform FILE-CREATOR on the non-directory part of marked files @@ -2035,8 +2066,7 @@ of marked files. If KILL-ROOT is non-nil, kill DIRNAME as well." (while alist (setq elt (car alist) alist (cdr alist) - dir (car elt) - pos (dired-get-subdir-min elt)) + dir (car elt)) (if (dired-tree-lessp dir new-dir) ;; Insert NEW-DIR after DIR (setq new-pos (dired-get-subdir-max elt)