-;;; 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, 1994 Free Software Foundation, Inc.
;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>.
+;; Maintainer: FSF
;; This file is part of GNU Emacs.
;; 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:
(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
"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,
(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))))
(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))
(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.
output files usually are created there instead of in a subdir."
;;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))
(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.
(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")
+ ;; 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 'dired-compress-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 -2)))
+ (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"))))))))
\f
(defun dired-mark-confirm (op-symbol arg)
;; 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)))))
(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)
(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))
(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 (expand-file-name directory)))
+ (let ((buf-list (dired-buffers-for-dir (expand-file-name directory)
+ file))
(obuf (current-buffer))
buf success-list)
(while buf-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
;; 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)
(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)
(if dired-after-readin-hook;; the subdir-alist is not affected...
;;;###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
;;;###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)
\f
;;; Copy, move/rename, making hard and symbolic links
-(defvar dired-backup-overwrite nil
+(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)
+ (sexp :tag "ask" :format "%t\n" t))
+ :group 'dired)
(defvar dired-overwrite-confirmed)
;; 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 ()
+ (copy-file from to ok-flag dired-copy-preserve-time)
+ (file-date-error (message "Can't set date")
+ (sit-for 1))))
;;;###autoload
(defun dired-rename-file (from to ok-flag)
(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))
(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 ((expanded-from-dir (expand-file-name from-dir))
(dired-normalize-subdir
(dired-replace-in-string regexp newtext (car elt)))))))
\f
-;; 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))
-\f
;; 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)
;; 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
"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)
;;;###end dired-ins.el
+\f
+;; 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 (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)))
+\f
+
(provide 'dired-aux)
;;; dired-aux.el ends here
HCoop / bpt / emacs.git / blobdiff