X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/53a051941ff1079a1d59639785e2c79705170002..6b124390359d516800bc41ba5a9a66b1dd1e5bb9:/lisp/dired-aux.el diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index dd266ce8ae..4a2d893245 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1,8 +1,9 @@ -;;; dired-aux.el --- all of dired except what people usually use +;;; dired-aux.el --- less commonly used parts of dired -*-byte-compile-dynamic: t;-*- -;; Copyright (C) 1985, 1986, 1992 Free Software Foundation, Inc. +;; Copyright (C) 1985, 1986, 1992, 1994, 1998, 2000 Free Software Foundation, Inc. ;; Author: Sebastian Kremer . +;; Maintainer: FSF ;; This file is part of GNU Emacs. @@ -17,8 +18,9 @@ ;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: @@ -50,6 +52,7 @@ With prefix arg, prompt for second argument SWITCHES, (let ((default (if (mark t) (save-excursion (goto-char (mark t)) (dired-get-filename t t))))) + (require 'diff) (list (read-file-name (format "Diff %s with: %s" (dired-get-filename t) (if default @@ -96,7 +99,10 @@ With prefix arg, prompt for argument SWITCHES which is options for `diff'." (setq failures (dired-bunch-files 10000 (function dired-check-process) - (list operation program new-attribute) + (append + (list operation program new-attribute) + (if (string-match "gnu" system-configuration) + '("--") nil)) files)) (dired-do-redisplay arg);; moves point if ARG is an integer (if failures @@ -109,18 +115,22 @@ With prefix arg, prompt for argument SWITCHES which is options for `diff'." "Change the mode of the marked (or next ARG) files. This calls chmod, thus symbolic modes like `g+w' are allowed." (interactive "P") - (dired-do-chxxx "Mode" "chmod" 'chmod arg)) + (dired-do-chxxx "Mode" dired-chmod-program 'chmod arg)) ;;;###autoload (defun dired-do-chgrp (&optional arg) "Change the group of the marked (or next ARG) files." (interactive "P") + (if (memq system-type '(ms-dos windows-nt)) + (error "chgrp not supported on this system.")) (dired-do-chxxx "Group" "chgrp" 'chgrp arg)) ;;;###autoload (defun dired-do-chown (&optional arg) "Change the owner of the marked (or next ARG) files." (interactive "P") + (if (memq system-type '(ms-dos windows-nt)) + (error "chown not supported on this system.")) (dired-do-chxxx "Owner" dired-chown-program 'chown arg)) ;; Process all the files in FILES in batches of a convenient size, @@ -163,7 +173,12 @@ Uses the shell command coming from variables `lpr-command' and (let* ((file-list (dired-get-marked-files t arg)) (command (dired-mark-read-string "Print %s with: " - (apply 'concat lpr-command " " lpr-switches) + (mapconcat 'identity + (cons lpr-command + (if (stringp lpr-switches) + (list lpr-switches) + lpr-switches)) + " ") 'print arg file-list))) (dired-run-shell-command (dired-shell-stuff-it command file-list nil)))) @@ -230,7 +245,7 @@ with a prefix argument." (defun dired-map-dired-file-lines (fun) ;; Perform FUN with point at the end of each non-directory line. - ;; FUN takes one argument, the filename (complete pathname). + ;; FUN takes one argument, the absolute filename. (save-excursion (let (file buffer-read-only) (goto-char (point-min)) @@ -244,19 +259,24 @@ with a prefix argument." (forward-line 1))))) (defun dired-collect-file-versions (fn) - ;; "If it looks like file FN has versions, return a list of the versions. - ;;That is a list of strings which are file names. - ;;The caller may want to flag some of these files for deletion." - (let* ((base-versions - (concat (file-name-nondirectory fn) ".~")) - (bv-length (length base-versions)) - (possibilities (file-name-all-completions - base-versions - (file-name-directory fn))) - (versions (mapcar 'backup-extract-version possibilities))) - (if versions - (setq dired-file-version-alist (cons (cons fn versions) - dired-file-version-alist))))) + (let ((fn (file-name-sans-versions fn))) + ;; Only do work if this file is not already in the alist. + (if (assoc fn dired-file-version-alist) + nil + ;; If it looks like file FN has versions, return a list of the versions. + ;;That is a list of strings which are file names. + ;;The caller may want to flag some of these files for deletion. + (let* ((base-versions + (concat (file-name-nondirectory fn) ".~")) + (backup-extract-version-start (length base-versions)) + (possibilities (file-name-all-completions + base-versions + (file-name-directory fn))) + (versions (mapcar 'backup-extract-version possibilities))) + (if versions + (setq dired-file-version-alist + (cons (cons fn versions) + dired-file-version-alist))))))) (defun dired-trample-file-versions (fn) (let* ((start-vn (string-match "\\.~[0-9]+~$" fn)) @@ -272,18 +292,6 @@ with a prefix argument." (insert dired-del-marker))))) ;;; Shell commands -;;>>> install (move this function into simple.el) -(defun dired-shell-quote (filename) - "Quote a file name for inferior shell (see variable `shell-file-name')." - ;; Quote everything except POSIX filename characters. - ;; This should be safe enough even for really weird shells. - (let ((result "") (start 0) end) - (while (string-match "[^---0-9a-zA-Z_./]" filename start) - (setq end (match-beginning 0) - result (concat result (substring filename start end) - "\\" (substring filename end (1+ end))) - start (1+ end))) - (concat result (substring filename start)))) (defun dired-read-shell-command (prompt arg files) ;; "Read a dired shell command prompting with PROMPT (using read-string). @@ -293,12 +301,13 @@ with a prefix argument." (dired-mark-pop-up nil 'shell files (function read-string) - (format prompt (dired-mark-prompt arg files)))) + (format prompt (dired-mark-prompt arg files)) + nil 'shell-command-history)) ;; The in-background argument is only needed in Emacs 18 where ;; shell-command doesn't understand an appended ampersand `&'. ;;;###autoload -(defun dired-do-shell-command (command &optional arg) +(defun dired-do-shell-command (command &optional arg file-list) "Run a shell command COMMAND on the marked files. If no files are marked or a specific numeric prefix arg is given, the next ARG files are used. Just \\[universal-argument] means the current file. @@ -310,24 +319,32 @@ Normally the command is run on each file individually. However, if there is a `*' in the command then it is run just once with the entire file list substituted there. +If there is no `*', but a `?' in the command then it is still run +on each file individually but with the filename substituted there +instead of att the end of the command. + No automatic redisplay of dired buffers is attempted, as there's no telling what files the command may have changed. Type \\[dired-do-redisplay] to redisplay the marked files. The shell command has the top level directory as working directory, so -output files usually are created there instead of in a subdir." +output files usually are created there instead of in a subdir. + +In a noninteractive call (from Lisp code), you must specify +the list of file names explicitly with the FILE-LIST argument." ;;Functions dired-run-shell-command and dired-shell-stuff-it do the ;;actual work and can be redefined for customization. - (interactive (list - ;; Want to give feedback whether this file or marked files are used: - (dired-read-shell-command (concat "! on " - "%s: ") - current-prefix-arg - (dired-get-marked-files - t current-prefix-arg)) - current-prefix-arg)) - (let* ((on-each (not (string-match "\\*" command))) - (file-list (dired-get-marked-files t arg))) + (interactive + (let ((files (dired-get-marked-files t current-prefix-arg))) + (list + ;; Want to give feedback whether this file or marked files are used: + (dired-read-shell-command (concat "! on " + "%s: ") + current-prefix-arg + files) + current-prefix-arg + files))) + (let* ((on-each (not (string-match "\\*" command)))) (if on-each (dired-bunch-files (- 10000 (length command)) @@ -357,16 +374,20 @@ output files usually are created there instead of in a subdir." ;; (coming from interactive P and currently ignored) to decide what to do. ;; Smart would be a way to access basename or extension of file names. ;; See dired-trns.el for an approach to this. - ;; Bug: There is no way to quote a * - ;; On the other hand, you can never accidentally get a * into your cmd. + ;; Bug: There is no way to quote a * or a ? + ;; On the other hand, you can never accidentally get a * or a ? into + ;; your cmd. (let ((stuff-it - (if (string-match "\\*" command) - (function (lambda (x) - (dired-replace-in-string "\\*" x command))) - (function (lambda (x) (concat command " " x)))))) + (cond ((string-match "\\*" command) + (function (lambda (x) + (dired-replace-in-string "\\*" x command)))) + ((string-match "\\?" command) + (function (lambda (x) + (dired-replace-in-string "\\?" x command)))) + (t (function (lambda (x) (concat command " " x))))))) (if on-each - (mapconcat stuff-it (mapcar 'dired-shell-quote file-list) ";") - (let ((fns (mapconcat 'dired-shell-quote + (mapconcat stuff-it (mapcar 'shell-quote-argument file-list) ";") + (let ((fns (mapconcat 'shell-quote-argument file-list dired-mark-separator))) (if (> (length file-list) 1) (setq fns (concat dired-mark-prefix fns dired-mark-postfix))) @@ -374,7 +395,11 @@ output files usually are created there instead of in a subdir." ;; This is an extra function so that it can be redefined by ange-ftp. (defun dired-run-shell-command (command) - (shell-command command) + (let ((handler + (find-file-name-handler (directory-file-name default-directory) + 'shell-command))) + (if handler (apply handler 'shell-command (list command)) + (shell-command command))) ;; Return nil for sake of nconc in dired-bunch-files. nil) @@ -383,7 +408,13 @@ output files usually are created there instead of in a subdir." (defun dired-call-process (program discard &rest arguments) ; "Run PROGRAM with output to current buffer unless DISCARD is t. ;Remaining arguments are strings passed as command arguments to PROGRAM." - (apply 'call-process program nil (not discard) nil arguments)) + ;; Look for a handler for default-directory in case it is a remote file name. + (let ((handler + (find-file-name-handler (directory-file-name default-directory) + 'dired-call-process))) + (if handler (apply handler 'dired-call-process + program discard arguments) + (apply 'call-process program nil (not discard) nil arguments)))) (defun dired-check-process (msg program &rest arguments) ; "Display MSG while running PROGRAM, and check for output. @@ -491,44 +522,74 @@ and use this command with a prefix argument (the value does not matter)." (dired-log (concat "Failed to compress" from-file)) from-file))) +(defvar dired-compress-file-suffixes + '(("\\.gz\\'" "" "gunzip") + ("\\.tgz\\'" ".tar" "gunzip") + ("\\.Z\\'" "" "uncompress") + ;; For .z, try gunzip. It might be an old gzip file, + ;; or it might be from compact? pack? (which?) but gunzip handles both. + ("\\.z\\'" "" "gunzip") + ("\\.bz2\\'" "" "bunzip2") + ;; This item controls naming for compression. + ("\\.tar\\'" ".tgz" nil)) + "Control changes in file name suffixes for compression and uncompression. +Each element specifies one transformation rule, and has the form: + (REGEXP NEW-SUFFIX PROGRAM) +The rule applies when the old file name matches REGEXP. +The new file name is computed by deleting the part that matches REGEXP + (as well as anything after that), then adding NEW-SUFFIX in its place. +If PROGRAM is non-nil, the rule is an uncompression rule, +and uncompression is done by running PROGRAM. +Otherwise, the rule is a compression rule, and compression is done with gzip.") + +;;;###autoload (defun dired-compress-file (file) ;; Compress or uncompress FILE. ;; Return the name of the compressed or uncompressed file. ;; Return nil if no change in files. - (let ((handler (find-file-name-handler file))) + (let ((handler (find-file-name-handler file 'dired-compress-file)) + suffix newname + (suffixes dired-compress-file-suffixes)) + ;; See if any suffix rule matches this file name. + (while suffixes + (let (case-fold-search) + (if (string-match (car (car suffixes)) file) + (setq suffix (car suffixes) suffixes nil)) + (setq suffixes (cdr suffixes)))) + ;; If so, compute desired new name. + (if suffix + (setq newname (concat (substring file 0 (match-beginning 0)) + (nth 1 suffix)))) (cond (handler (funcall handler 'dired-compress-file file)) ((file-symlink-p file) nil) - ((let (case-fold-search) - (string-match "\\.Z$" file)) - (if (not (dired-check-process (concat "Uncompressing " file) - "uncompress" file)) - (substring file 0 -2))) - ((let (case-fold-search) - (string-match "\\.gz$" file)) - (if (not (dired-check-process (concat "Uncompressing " file) - "gunzip" file)) - (substring file 0 -3))) - ;; For .z, try gunzip. It might be an old gzip file, - ;; or it might be from compact? pack? (which?) but gunzip handles - ;; both. - ((let (case-fold-search) - (string-match "\\.z$" file)) + ((and suffix (nth 2 suffix)) + ;; We found an uncompression rule. (if (not (dired-check-process (concat "Uncompressing " file) - "gunzip" file)) - (substring file 0 -3))) + (nth 2 suffix) file)) + newname)) (t + ;;; We don't recognize the file as compressed, so compress it. ;;; Try gzip; if we don't have that, use compress. (condition-case nil (if (not (dired-check-process (concat "Compressing " file) "gzip" "-f" file)) - (cond ((file-exists-p (concat file ".gz")) - (concat file ".gz")) - (t (concat file ".z")))) + (let ((out-name + (if (file-exists-p (concat file ".gz")) + (concat file ".gz") + (concat file ".z")))) + ;; Rename the compressed file to NEWNAME + ;; if it hasn't got that name already. + (if (and newname (not (equal newname out-name))) + (progn + (rename-file out-name newname t) + newname) + out-name))) (file-error (if (not (dired-check-process (concat "Compressing " file) "compress" "-f" file)) + ;; Don't use NEWNAME with `compress'. (concat file ".Z")))))))) (defun dired-mark-confirm (op-symbol arg) @@ -537,7 +598,8 @@ and use this command with a prefix argument (the value does not matter)." ;; Confirmation consists in a y-or-n question with a file list ;; pop-up unless OP-SYMBOL is a member of `dired-no-confirm'. ;; The files used are determined by ARG (as in dired-get-marked-files). - (or (memq op-symbol dired-no-confirm) + (or (eq dired-no-confirm t) + (memq op-symbol dired-no-confirm) (let ((files (dired-get-marked-files t arg)) (string (if (eq op-symbol 'compress) "Compress or uncompress" (capitalize (symbol-name op-symbol))))) @@ -626,15 +688,14 @@ and use this command with a prefix argument (the value does not matter)." (defun dired-byte-compile () ;; Return nil for success, offending file name else. (let* ((filename (dired-get-filename)) - (elc-file - (if (eq system-type 'vax-vms) - (concat (substring filename 0 (string-match ";" filename)) "c") - (concat filename "c"))) - buffer-read-only failure) + elc-file buffer-read-only failure) (condition-case err (save-excursion (byte-compile-file filename)) (error (setq failure err))) + (setq elc-file (byte-compile-dest-file filename)) + (or (file-exists-p elc-file) + (setq failure t)) (if failure (progn (dired-log "Byte compile error for %s:\n%s\n" filename failure) @@ -680,6 +741,8 @@ a prefix arg lets you edit the `ls' switches used for the new listing." (if arg (read-string "Switches for listing: " dired-actual-switches))) (message "Redisplaying...") ;; 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))) (message "Redisplaying... %s" fname) (dired-update-file-line fname)) @@ -699,16 +762,20 @@ a prefix arg lets you edit the `ls' switches used for the new listing." (delete-region (point) (progn (forward-line 1) (point))) (if file (progn - (dired-add-entry file) + (dired-add-entry file nil t) ;; Replace space by old marker without moving point. ;; Faster than goto+insdel inside a save-excursion? (subst-char-in-region opoint (1+ opoint) ?\040 char)))) (dired-move-to-filename)) -(defun dired-fun-in-all-buffers (directory fun &rest args) +(defun dired-fun-in-all-buffers (directory file fun &rest args) ;; In all buffers dired'ing DIRECTORY, run FUN with ARGS. + ;; If the buffer has a wildcard pattern, check that it matches FILE. + ;; (FILE does not include a directory component.) + ;; FILE may be nil, in which case ignore it. ;; Return list of buffers where FUN succeeded (i.e., returned non-nil). - (let ((buf-list (dired-buffers-for-dir directory)) + (let ((buf-list (dired-buffers-for-dir (expand-file-name directory) + file)) (obuf (current-buffer)) buf success-list) (while buf-list @@ -722,12 +789,13 @@ a prefix arg lets you edit the `ls' switches used for the new listing." (set-buffer obuf))) success-list)) +;;;###autoload (defun dired-add-file (filename &optional marker-char) (dired-fun-in-all-buffers - (file-name-directory filename) + (file-name-directory filename) (file-name-nondirectory filename) (function dired-add-entry) filename marker-char)) -(defun dired-add-entry (filename &optional marker-char) +(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 @@ -737,11 +805,15 @@ a prefix arg lets you edit the `ls' switches used for the new listing." ;; 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)) + (let* ((opoint (point)) (cur-dir (dired-current-directory)) - (directory (file-name-directory filename)) + (orig-file-name filename) + (directory (if relative cur-dir (file-name-directory filename))) reason) - (setq filename (file-name-nondirectory filename) + (setq filename + (if relative + (file-relative-name filename directory) + (file-name-nondirectory filename)) reason (catch 'not-found (if (string= directory cur-dir) @@ -765,20 +837,30 @@ a prefix arg lets you edit the `ls' switches used for the new listing." (dired-goto-next-nontrivial-file)) ;; not found (throw 'not-found "Subdir not found"))) - ;; found and point is at The Right Place: - (let (buffer-read-only) + (let (buffer-read-only opoint) (beginning-of-line) + (setq opoint (point)) (dired-add-entry-do-indentation marker-char) - ;; don't expand `.' ! - (insert-directory (dired-make-absolute filename directory) - (concat dired-actual-switches "d")) + ;; don't expand `.'. Show just the file name within directory. + (let ((default-directory directory)) + (insert-directory filename + (concat dired-actual-switches "d"))) + ;; 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 'no-dir))) + (if (file-name-directory inserted-name) + (progn + (end-of-line) + (delete-char (- (length inserted-name))) + (insert filename) + (forward-char 1)) + (forward-line 1))) + ;; Give each line a text property recording info about it. + (dired-insert-set-properties opoint (point)) (forward-line -1) - ;; We want to have the non-directory part, only: - (let* ((beg (dired-move-to-filename t)) ; error for strange output - (end (dired-move-to-end-of-filename))) - (setq filename (buffer-substring beg end)) - (delete-region beg end) - (insert (file-name-nondirectory filename))) (if dired-after-readin-hook;; the subdir-alist is not affected... (save-excursion;; ...so we can run it right now: (save-restriction @@ -815,9 +897,11 @@ a prefix arg lets you edit the `ls' switches used for the new listing." (forward-line 1)) (point))) +;;;###autoload (defun dired-remove-file (file) (dired-fun-in-all-buffers - (file-name-directory file) (function dired-remove-entry) file)) + (file-name-directory file) (file-name-nondirectory file) + (function dired-remove-entry) file)) (defun dired-remove-entry (file) (save-excursion @@ -826,13 +910,15 @@ a prefix arg lets you edit the `ls' switches used for the new listing." (delete-region (progn (beginning-of-line) (point)) (save-excursion (forward-line 1) (point))))))) +;;;###autoload (defun dired-relist-file (file) (dired-fun-in-all-buffers (file-name-directory file) + (file-name-nondirectory file) (function dired-relist-entry) file)) (defun dired-relist-entry (file) ;; Relist the line for FILE, or just add it if it did not exist. - ;; FILE must be an absolute pathname. + ;; FILE must be an absolute file name. (let (buffer-read-only marker) ;; If cursor is already on FILE's line delete-region will cause ;; save-excursion to fail because of floating makers, @@ -848,9 +934,26 @@ a prefix arg lets you edit the `ls' switches used for the new listing." ;;; Copy, move/rename, making hard and symbolic links -(defvar dired-backup-overwrite nil +(defcustom dired-recursive-copies nil + "*Decide whether recursive copies are allowed. +Nil means no recursive copies. +`always' means copy recursively without asking. +`top' means ask for each directory at top level. +Anything else means ask for each directory." + :type '(choice :tag "Copy directories" + (const :tag "No recursive copies" nil) + (const :tag "Ask for each directory" t) + (const :tag "Ask for each top directory only" top) + (const :tag "Copy directories without asking" always)) + :group 'dired) + +(defcustom dired-backup-overwrite nil "*Non-nil if Dired should ask about making backups before overwriting files. -Special value `always' suppresses confirmation.") +Special value `always' suppresses confirmation." + :type '(choice (const :tag "off" nil) + (const :tag "suppress" always) + (other :tag "ask" t)) + :group 'dired) (defvar dired-overwrite-confirmed) @@ -858,29 +961,55 @@ Special value `always' suppresses confirmation.") ;; Save old version of a to be overwritten file TO. ;; `dired-overwrite-confirmed' and `overwrite-backup-query' are fluid vars ;; from dired-create-files. - (if (and dired-backup-overwrite - dired-overwrite-confirmed - (or (eq 'always dired-backup-overwrite) - (dired-query 'overwrite-backup-query - (format "Make backup for existing file `%s'? " to)))) - (let ((backup (car (find-backup-file-name to)))) - (rename-file to backup 0) ; confirm overwrite of old backup - (dired-relist-entry backup)))) + (let (backup) + (if (and dired-backup-overwrite + dired-overwrite-confirmed + (setq backup (car (find-backup-file-name to))) + (or (eq 'always dired-backup-overwrite) + (dired-query 'overwrite-backup-query + (format "Make backup for existing file `%s'? " + to)))) + (progn + (rename-file to backup 0) ; confirm overwrite of old backup + (dired-relist-entry backup))))) +;;;###autoload (defun dired-copy-file (from to ok-flag) (dired-handle-overwrite to) - (copy-file from to ok-flag dired-copy-preserve-time)) + (condition-case () + (dired-copy-file-recursive from to ok-flag dired-copy-preserve-time t + dired-recursive-copies) + (file-date-error (message "Can't set date") + (sit-for 1)))) + +(defun dired-copy-file-recursive (from to ok-flag &optional + preserve-time top recursive) + (if (and recursive + (eq t (car (file-attributes from))) ; A directory, no symbolic link. + (or (eq recursive 'always) + (yes-or-no-p (format "Recursive copies of %s " from)))) + (let ((files (directory-files from nil dired-re-no-dot))) + (if (eq recursive 'top) (setq recursive 'always)) ; Don't ask any more. + (if (file-exists-p to) + (or top (dired-handle-overwrite to)) + (make-directory to)) + (while files + (dired-copy-file-recursive + (expand-file-name (car files) from) + (expand-file-name (car files) to) + ok-flag preserve-time nil recursive) + (setq files (cdr files)))) + (or top (dired-handle-overwrite to)) ; Just a file. + (copy-file from to ok-flag dired-copy-preserve-time))) +;;;###autoload (defun dired-rename-file (from to ok-flag) (dired-handle-overwrite to) (rename-file from to ok-flag) ; error is caught in -create-files ;; Silently rename the visited file of any buffer visiting this file. (and (get-file-buffer from) - (save-excursion - (set-buffer (get-file-buffer from)) - (let ((modflag (buffer-modified-p))) - (set-visited-file-name to) - (set-buffer-modified-p modflag)))) + (with-current-buffer (get-file-buffer from) + (set-visited-file-name to nil t))) (dired-remove-file from) ;; See if it's an inserted subdir, and rename that, too. (dired-rename-subdir from to)) @@ -888,15 +1017,16 @@ Special value `always' suppresses confirmation.") (defun dired-rename-subdir (from-dir to-dir) (setq from-dir (file-name-as-directory from-dir) to-dir (file-name-as-directory to-dir)) - (dired-fun-in-all-buffers from-dir + (dired-fun-in-all-buffers from-dir nil (function dired-rename-subdir-1) from-dir to-dir) ;; Update visited file name of all affected buffers - (let ((blist (buffer-list))) + (let ((expanded-from-dir (expand-file-name from-dir)) + (blist (buffer-list))) (while blist (save-excursion - (set-buffer (car blist)) + (set-buffer (car blist)) (if (and buffer-file-name - (dired-in-this-tree buffer-file-name from-dir)) + (dired-in-this-tree buffer-file-name expanded-from-dir)) (let ((modflag (buffer-modified-p)) (to-file (dired-replace-in-string (concat "^" (regexp-quote from-dir)) @@ -909,12 +1039,13 @@ Special value `always' suppresses confirmation.") (defun dired-rename-subdir-1 (dir to) ;; Rename DIR to TO in headerlines and dired-subdir-alist, if DIR or ;; one of its subdirectories is expanded in this buffer. - (let ((alist dired-subdir-alist) + (let ((expanded-dir (expand-file-name dir)) + (alist dired-subdir-alist) (elt nil)) (while alist (setq elt (car alist) alist (cdr alist)) - (if (dired-in-this-tree (car elt) dir) + (if (dired-in-this-tree (car elt) expanded-dir) ;; ELT's subdir is affected by the rename (dired-rename-subdir-2 elt dir to))) (if (equal dir default-directory) @@ -958,69 +1089,6 @@ Special value `always' suppresses confirmation.") (dired-normalize-subdir (dired-replace-in-string regexp newtext (car elt))))))) -;; Cloning replace-match to work on strings instead of in buffer: -;; The FIXEDCASE parameter of replace-match is not implemented. -;;;###autoload -(defun dired-string-replace-match (regexp string newtext - &optional literal global) - "Replace first match of REGEXP in STRING with NEWTEXT. -If it does not match, nil is returned instead of the new string. -Optional arg LITERAL means to take NEWTEXT literally. -Optional arg GLOBAL means to replace all matches." - (if global - (let ((result "") (start 0) mb me) - (while (string-match regexp string start) - (setq mb (match-beginning 0) - me (match-end 0) - result (concat result - (substring string start mb) - (if literal - newtext - (dired-expand-newtext string newtext))) - start me)) - (if mb ; matched at least once - (concat result (substring string start)) - nil)) - ;; not GLOBAL - (if (not (string-match regexp string 0)) - nil - (concat (substring string 0 (match-beginning 0)) - (if literal newtext (dired-expand-newtext string newtext)) - (substring string (match-end 0)))))) - -(defun dired-expand-newtext (string newtext) - ;; Expand \& and \1..\9 (referring to STRING) in NEWTEXT, using match data. - ;; Note that in Emacs 18 match data are clipped to current buffer - ;; size...so the buffer should better not be smaller than STRING. - (let ((pos 0) - (len (length newtext)) - (expanded-newtext "")) - (while (< pos len) - (setq expanded-newtext - (concat expanded-newtext - (let ((c (aref newtext pos))) - (if (= ?\\ c) - (cond ((= ?\& (setq c - (aref newtext - (setq pos (1+ pos))))) - (substring string - (match-beginning 0) - (match-end 0))) - ((and (>= c ?1) (<= c ?9)) - ;; return empty string if N'th - ;; sub-regexp did not match: - (let ((n (- c ?0))) - (if (match-beginning n) - (substring string - (match-beginning n) - (match-end n)) - ""))) - (t - (char-to-string c))) - (char-to-string c))))) - (setq pos (1+ pos))) - expanded-newtext)) - ;; 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) @@ -1035,13 +1103,13 @@ Optional arg GLOBAL means to replace all matches." ;; 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 signalling a file-error if it +;; buffers. FILE-CREATOR must abort by signaling a file-error if it ;; could not create newfile. The error is caught and logged. ;; OPERATION (a capitalized string, e.g. `Copy') describes the ;; operation performed. It is used for error logging. -;; FN-LIST is the list of files to copy (full absolute pathnames). +;; 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 @@ -1127,17 +1195,28 @@ ESC or `q' to not overwrite any of the remaining files, ;; will determine whether pop-ups are appropriate for this OP-SYMBOL. ;; FILE-CREATOR and OPERATION as in dired-create-files. ;; ARG as in dired-get-marked-files. + ;; Optional arg MARKER-CHAR as in dired-create-files. ;; Optional arg OP1 is an alternate form for OPERATION if there is ;; only one file. - ;; Optional arg MARKER-CHAR as in dired-create-files. - ;; Optional arg HOW-TO determines how to treat target: - ;; If HOW-TO is not given (or nil), and target is a directory, the - ;; file(s) are created inside the target directory. If target - ;; is not a directory, there must be exactly one marked file, - ;; else error. - ;; If HOW-TO is t, then target is not modified. There must be - ;; exactly one marked file, else error. - ;; Else HOW-TO is assumed to be a function of one argument, target, + ;; Optional arg HOW-TO is used to set the value of the into-dir variable + ;; which determines how to treat target. + ;; If into-dir is set to nil then target is not regarded as a directory, + ;; there must be exactly one marked file, else error. + ;; Else if into-dir is set to a list, then target is a genearlized + ;; directory (e.g. some sort of archive). The first element of into-dir + ;; must be a function with at least four arguments: + ;; operation as OPERATION above. + ;; rfn-list a list of the relative names for the marked files. + ;; fn-list a list of the absolute names for the marked files. + ;; target. + ;; The rest of into-dir are optional arguments. + ;; Else into-dir is not a list. Target is a directory. + ;; The marked file(s) are created inside the target directory. + ;; + ;; If HOW-TO is not given (or nil), then into-dir is set to true if + ;; target is a directory and otherwise to nil. + ;; Else if HOW-TO is t, then into-dir is set to nil. + ;; Else HOW-TO is assumed to be a function of one argument, target, ;; that looks at target and returns a value for the into-dir ;; variable. The function dired-into-dir-with-symlinks is provided ;; for the case (common when creating symlinks) that symbolic @@ -1145,29 +1224,51 @@ ESC or `q' to not overwrite any of the remaining files, ;; (as file-directory-p would if HOW-TO had been nil). (or op1 (setq op1 operation)) (let* ((fn-list (dired-get-marked-files nil arg)) - (fn-count (length fn-list)) - (target (expand-file-name + (rfn-list (mapcar (function dired-make-relative) fn-list)) + (dired-one-file ; fluid variable inside dired-create-files + (and (consp fn-list) (null (cdr fn-list)) (car fn-list))) + (target (expand-file-name ; fluid variable inside dired-create-files (dired-mark-read-file-name - (concat (if (= 1 fn-count) op1 operation) " %s to: ") + (concat (if dired-one-file op1 operation) " %s to: ") (dired-dwim-target-directory) - op-symbol arg (mapcar (function dired-make-relative) fn-list)))) - (into-dir (cond ((null how-to) (file-directory-p target)) + op-symbol arg rfn-list))) + (into-dir (cond ((null how-to) + ;; Allow DOS/Windows users to change the letter + ;; case of a directory. If we don't test these + ;; conditions up front, file-directory-p below + ;; will return t because the filesystem is + ;; case-insensitive, and Emacs will try to move + ;; foo -> foo/foo, which fails. + (if (and (memq system-type '(ms-dos windows-nt)) + (eq op-symbol 'move) + dired-one-file + (string= (downcase + (expand-file-name (car fn-list))) + (downcase + (expand-file-name target))) + (not (string= + (file-name-nondirectory (car fn-list)) + (file-name-nondirectory target)))) + nil + (file-directory-p target))) ((eq how-to t) nil) (t (funcall how-to target))))) - (if (and (> fn-count 1) - (not into-dir)) - (error "Marked %s: target must be a directory: %s" operation target)) - ;; rename-file bombs when moving directories unless we do this: - (or into-dir (setq target (directory-file-name target))) - (dired-create-files - file-creator operation fn-list - (if into-dir ; target is a directory - ;; This function uses fluid vars into-dir and target when called - ;; inside dired-create-files: - (function (lambda (from) - (expand-file-name (file-name-nondirectory from) target))) - (function (lambda (from) target))) - marker-char))) + (if (and (consp into-dir) (functionp (car into-dir))) + (apply (car into-dir) operation rfn-list fn-list target (cdr into-dir)) + (if (not (or dired-one-file into-dir)) + (error "Marked %s: target must be a directory: %s" operation target)) + ;; rename-file bombs when moving directories unless we do this: + (or into-dir (setq target (directory-file-name target))) + (dired-create-files + file-creator operation fn-list + (if into-dir ; target is a directory + ;; This function uses fluid variable target when called + ;; inside dired-create-files: + (function + (lambda (from) + (expand-file-name (file-name-nondirectory from) target))) + (function (lambda (from) target))) + marker-char)))) ;; Read arguments for a marked-files command that wants a file name, ;; perhaps popping up the list of marked files. @@ -1224,18 +1325,24 @@ ESC or `q' to not overwrite any of the remaining files, ;; just have to remove that symlink by hand before making your marked ;; symlinks. +(defvar dired-copy-how-to-fn nil + "Nil or a function used by `dired-do-copy' to determine target. +See HOW-TO argument for `dired-do-create-files'.") + ;;;###autoload (defun dired-do-copy (&optional arg) "Copy all marked (or next ARG) files, or copy the current file. This normally preserves the last-modified date when copying. When operating on just the current file, you specify the new name. -When operating on multiple or marked files, you specify a directory -and new symbolic links are made in that directory +When operating on multiple or marked files, you specify a directory, +and new copies of these files are made in that directory with the same names that the files currently have." (interactive "P") - (dired-do-create-files 'copy (function dired-copy-file) + (let ((dired-recursive-copies dired-recursive-copies)) + (dired-do-create-files 'copy (function dired-copy-file) (if dired-copy-preserve-time "Copy [-p]" "Copy") - arg dired-keep-marker-copy)) + arg dired-keep-marker-copy + nil dired-copy-how-to-fn))) ;;;###autoload (defun dired-do-symlink (&optional arg) @@ -1278,7 +1385,7 @@ When renaming multiple or marked files, you specify a directory." ;; ARG as in dired-get-marked-files. ;; Matches each marked file against REGEXP and constructs the new ;; filename from NEWNAME (like in function replace-match). - ;; Optional arg WHOLE-PATH means match/replace the whole pathname + ;; Optional arg WHOLE-PATH means match/replace the whole file name ;; 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)) @@ -1349,9 +1456,9 @@ As each match is found, the user must type a character saying what to do with it. For directions, type \\[help-command] at that time. NEWNAME may contain \\=\\ or \\& as in `query-replace-regexp'. REGEXP defaults to the last regexp used. -With a zero prefix arg, renaming by regexp affects the complete - pathname - usually only the non-directory part of file names is used - and changed." + +With a zero prefix arg, renaming by regexp affects the absolute file name. +Normally, only the non-directory part of the file name is used and changed." (interactive (dired-mark-read-regexp "Rename")) (dired-do-create-files-regexp (function dired-rename-file) @@ -1360,17 +1467,18 @@ With a zero prefix arg, renaming by regexp affects the complete ;;;###autoload (defun dired-do-copy-regexp (regexp newname &optional arg whole-path) "Copy all marked files containing REGEXP to NEWNAME. -See function `dired-rename-regexp' for more info." +See function `dired-do-rename-regexp' for more info." (interactive (dired-mark-read-regexp "Copy")) - (dired-do-create-files-regexp - (function dired-copy-file) - (if dired-copy-preserve-time "Copy [-p]" "Copy") - arg regexp newname whole-path dired-keep-marker-copy)) + (let ((dired-recursive-copies nil)) ; No recursive copies. + (dired-do-create-files-regexp + (function dired-copy-file) + (if dired-copy-preserve-time "Copy [-p]" "Copy") + arg regexp newname whole-path dired-keep-marker-copy))) ;;;###autoload (defun dired-do-hardlink-regexp (regexp newname &optional arg whole-path) "Hardlink all marked files containing REGEXP to NEWNAME. -See function `dired-rename-regexp' for more info." +See function `dired-do-rename-regexp' for more info." (interactive (dired-mark-read-regexp "HardLink")) (dired-do-create-files-regexp (function add-name-to-file) @@ -1379,7 +1487,7 @@ See function `dired-rename-regexp' for more info." ;;;###autoload (defun dired-do-symlink-regexp (regexp newname &optional arg whole-path) "Symlink all marked files containing REGEXP to NEWNAME. -See function `dired-rename-regexp' for more info." +See function `dired-do-rename-regexp' for more info." (interactive (dired-mark-read-regexp "SymLink")) (dired-do-create-files-regexp (function make-symbolic-link) @@ -1459,6 +1567,7 @@ This function takes some pains to conform to `ls -lR' output." ;; insert message so that the user sees the `Mark set' message. (push-mark opoint))) +;;;###autoload (defun dired-insert-subdir (dirname &optional switches no-error-if-not-dir-p) "Insert this subdirectory into the same dired buffer. If it is already present, overwrites previous entry, @@ -1499,7 +1608,7 @@ This function takes some pains to conform to `ls -lR' output." (defun dired-insert-subdir-validate (dirname &optional switches) ;; Check that it is valid to insert DIRNAME with SWITCHES. ;; Signal an error if invalid (e.g. user typed `i' on `..'). - (or (dired-in-this-tree dirname default-directory) + (or (dired-in-this-tree dirname (expand-file-name default-directory)) (error "%s: not in this directory tree" dirname)) (if switches (let (case-fold-search) @@ -1530,6 +1639,7 @@ This function takes some pains to conform to `ls -lR' output." ;;"Kill all proper subdirs of DIRNAME, excluding DIRNAME itself. ;; With optional arg REMEMBER-MARKS, return an alist of marked files." (interactive "DKill tree below directory: ") + (setq dirname (expand-file-name dirname)) (let ((s-alist dired-subdir-alist) dir m-alist) (while s-alist (setq dir (car (car s-alist)) @@ -1585,7 +1695,9 @@ This function takes some pains to conform to `ls -lR' output." (if (equal dirname (car (car (reverse dired-subdir-alist)))) ;; top level directory may contain wildcards: (dired-readin-insert dired-directory) - (insert-directory dirname dired-actual-switches nil t))) + (let ((opoint (point))) + (insert-directory dirname dired-actual-switches nil t) + (dired-insert-set-properties opoint (point))))) (message "Reading directory %s...done" dirname) (setq end (point-marker)) (indent-rigidly begin end 2) @@ -1594,7 +1706,8 @@ This function takes some pains to conform to `ls -lR' output." ;; moves point. ;; Need a marker for END as this inserts text. (goto-char begin) - (dired-insert-headerline dirname) + (if (not (looking-at "^ /.*:$")) + (dired-insert-headerline dirname)) ;; point is now like in dired-build-subdir-alist (prog1 (list begin (marker-position end)) @@ -1621,7 +1734,7 @@ This function takes some pains to conform to `ls -lR' output." (run-hooks 'dired-after-readin-hook)))))) (defun dired-tree-lessp (dir1 dir2) - ;; Lexicographic order on pathname components, like `ls -lR': + ;; 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, ;; or DIR1 and DIR2 are in the same parentdir and their last @@ -1727,8 +1840,10 @@ The next char is either \\n, or \\r if DIR is hidden." ;;;###autoload (defun dired-mark-subdir-files () - "Mark all files except `.' and `..'." - (interactive "P") + "Mark all files except `.' and `..' in current subdirectory. +If the Dired buffer shows multiple directories, this command +marks the files listed in the subdirectory that point is in." + (interactive) (let ((p-min (dired-subdir-min))) (dired-mark-files-in-region p-min (dired-subdir-max)))) @@ -1851,4 +1966,41 @@ Use \\[dired-hide-subdir] to (un)hide a particular subdirectory." ;;;###end dired-ins.el + +;; Functions for searching in tags style among marked files. + +;;;###autoload +(defun dired-do-search (regexp) + "Search through all marked files for a match for REGEXP. +Stops when a match is found. +To continue searching for next match, use command \\[tags-loop-continue]." + (interactive "sSearch marked files (regexp): ") + (tags-search regexp '(dired-get-marked-files))) + +;;;###autoload +(defun dired-do-query-replace-regexp (from to &optional delimited) + "Do `query-replace-regexp' of FROM with TO, on all marked files. +Third arg DELIMITED (prefix arg) means replace only word-delimited matches. +If you exit (\\[keyboard-quit] or ESC), you can resume the query replace +with the command \\[tags-loop-continue]." + (interactive + "sQuery replace in marked files (regexp): \nsQuery replace %s by: \nP") + (tags-query-replace from to delimited '(dired-get-marked-files))) + +;;;###autoload +(defun dired-show-file-type (file &optional deref-symlinks) + "Print the type of FILE, according to the `file' command. +If FILE is a symbolic link and the optional argument DEREF-SYMLINKS is +true then the type of the file linked to by FILE is printed instead." + (interactive (list (dired-get-filename t) current-prefix-arg)) + (with-temp-buffer + (if deref-symlinks + (call-process "file" nil t t "-L" file) + (call-process "file" nil t t file)) + (when (bolp) + (backward-delete-char 1)) + (message (buffer-string)))) + +(provide 'dired-aux) + ;;; dired-aux.el ends here