;;; dired-aux.el --- less commonly used parts of dired -*-byte-compile-dynamic: t;-*-
-;; Copyright (C) 1985, 1986, 1992, 1994 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1992, 1994, 1998, 2000, 2001, 2002, 2003,
+;; 2004, 2005 Free Software Foundation, Inc.
;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>.
+;; Maintainer: FSF
+;; Keywords: files
;; 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., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;;###begin dired-cmd.el
;; Diffing and compressing
+(defconst dired-star-subst-regexp "\\(^\\|[ \t]\\)\\*\\([ \t]\\|$\\)")
+(defconst dired-quark-subst-regexp "\\(^\\|[ \t]\\)\\?\\([ \t]\\|$\\)")
+
;;;###autoload
(defun dired-diff (file &optional switches)
"Compare file at point with file FILE using `diff'.
-FILE defaults to the file at the mark.
+FILE defaults to the file at the mark. (That's the mark set by
+\\[set-mark-command], not by Dired's \\[dired-mark] command.)
The prompted-for file is the first file given to `diff'.
With prefix arg, prompt for second argument SWITCHES,
which is options for `diff'."
(if default
(concat "(default " default ") ")
""))
- (dired-current-directory) default t)
+ (if default
+ (dired-current-directory)
+ (dired-dwim-target-directory))
+ default t)
(if current-prefix-arg
(read-string "Options for diff: "
(if (stringp diff-switches)
nil))
(diff-backup (dired-get-filename) switches))
+;;;###autoload
+(defun dired-compare-directories (dir2 predicate)
+ "Mark files with different file attributes in two dired buffers.
+Compare file attributes of files in the current directory
+with file attributes in directory DIR2 using PREDICATE on pairs of files
+with the same name. Mark files for which PREDICATE returns non-nil.
+Mark files with different names if PREDICATE is nil (or interactively
+with empty input at the predicate prompt).
+
+PREDICATE is a Lisp expression that can refer to the following variables:
+
+ size1, size2 - file size in bytes
+ mtime1, mtime2 - last modification time in seconds, as a float
+ fa1, fa2 - list of file attributes
+ returned by function `file-attributes'
+
+ where 1 refers to attribute of file in the current dired buffer
+ and 2 to attribute of file in second dired buffer.
+
+Examples of PREDICATE:
+
+ (> mtime1 mtime2) - mark newer files
+ (not (= size1 size2)) - mark files with different sizes
+ (not (string= (nth 8 fa1) (nth 8 fa2))) - mark files with different modes
+ (not (and (= (nth 2 fa1) (nth 2 fa2)) - mark files with different UID
+ (= (nth 3 fa1) (nth 3 fa2)))) and GID."
+ (interactive
+ (list (read-directory-name (format "Compare %s with: "
+ (dired-current-directory))
+ (dired-dwim-target-directory)
+ (dired-dwim-target-directory))
+ (read-from-minibuffer "Mark if (lisp expr or RET): " nil nil t nil "nil")))
+ (let* ((dir1 (dired-current-directory))
+ (file-alist1 (dired-files-attributes dir1))
+ (file-alist2 (dired-files-attributes dir2))
+ file-list1 file-list2)
+ (setq file-alist1 (delq (assoc "." file-alist1) file-alist1))
+ (setq file-alist1 (delq (assoc ".." file-alist1) file-alist1))
+ (setq file-alist2 (delq (assoc "." file-alist2) file-alist2))
+ (setq file-alist2 (delq (assoc ".." file-alist2) file-alist2))
+ (setq file-list1 (mapcar
+ 'cadr
+ (dired-file-set-difference
+ file-alist1 file-alist2
+ predicate))
+ file-list2 (mapcar
+ 'cadr
+ (dired-file-set-difference
+ file-alist2 file-alist1
+ predicate)))
+ (dired-fun-in-all-buffers
+ dir1 nil
+ (lambda ()
+ (dired-mark-if
+ (member (dired-get-filename nil t) file-list1) nil)))
+ (dired-fun-in-all-buffers
+ dir2 nil
+ (lambda ()
+ (dired-mark-if
+ (member (dired-get-filename nil t) file-list2) nil)))
+ (message "Marked in dir1: %s files, in dir2: %s files"
+ (length file-list1)
+ (length file-list2))))
+
+(defun dired-file-set-difference (list1 list2 predicate)
+ "Combine LIST1 and LIST2 using a set-difference operation.
+The result list contains all file items that appear in LIST1 but not LIST2.
+This is a non-destructive function; it makes a copy of the data if necessary
+to avoid corrupting the original LIST1 and LIST2.
+PREDICATE (see `dired-compare-directories') is an additional match
+condition. Two file items are considered to match if they are equal
+*and* PREDICATE evaluates to t."
+ (if (or (null list1) (null list2))
+ list1
+ (let (res)
+ (dolist (file1 list1)
+ (unless (let ((list list2))
+ (while (and list
+ (not (let* ((file2 (car list))
+ (fa1 (car (cddr file1)))
+ (fa2 (car (cddr file2)))
+ (size1 (nth 7 fa1))
+ (size2 (nth 7 fa2))
+ (mtime1 (float-time (nth 5 fa1)))
+ (mtime2 (float-time (nth 5 fa2))))
+ (and
+ (equal (car file1) (car file2))
+ (not (eval predicate))))))
+ (setq list (cdr list)))
+ list)
+ (setq res (cons file1 res))))
+ (nreverse res))))
+
+(defun dired-files-attributes (dir)
+ "Return a list of all file names and attributes from DIR.
+List has a form of (file-name full-file-name (attribute-list))"
+ (mapcar
+ (lambda (file-name)
+ (let ((full-file-name (expand-file-name file-name dir)))
+ (list file-name
+ full-file-name
+ (file-attributes full-file-name))))
+ (directory-files dir)))
+\f
+
+(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)))
+
(defun dired-do-chxxx (attribute-name program op-symbol arg)
- ;; Change file attributes (mode, group, owner) of marked files and
+ ;; Change file attributes (mode, group, owner, timestamp) of marked files and
;; refresh their file lines.
;; ATTRIBUTE-NAME is a string describing the attribute to the user.
;; PROGRAM is the program used to change the attribute.
(new-attribute
(dired-mark-read-string
(concat "Change " attribute-name " of %s to: ")
- nil op-symbol arg files))
+ (if (eq op-symbol 'touch) (dired-touch-initial files))
+ op-symbol arg files))
(operation (concat program " " new-attribute))
failures)
(setq failures
(dired-bunch-files 10000
(function dired-check-process)
- (list operation program new-attribute)
+ (append
+ (list operation program)
+ (if (eq op-symbol 'touch)
+ '("-t") nil)
+ (list 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))
+;;;###autoload
+(defun dired-do-touch (&optional arg)
+ "Change the timestamp of the marked (or next ARG) files.
+This calls touch."
+ (interactive "P")
+ (dired-do-chxxx "Timestamp" dired-touch-program 'touch arg))
+
;; Process all the files in FILES in batches of a convenient size,
;; by means of (FUNCALL FUNCTION ARGS... SOME-FILES...).
;; Batches are chosen to need less than MAX chars for the file names,
;; allowing 3 extra characters of separator per file name.
(defun dired-bunch-files (max function args files)
(let (pending
+ past
(pending-length 0)
failures)
;; Accumulate files as long as they fit in MAX chars,
;; If we have at least 1 pending file
;; and this file won't fit in the length limit, process now.
(if (and pending (> (+ thislength pending-length) max))
- (setq failures
- (nconc (apply function (append args pending))
- failures)
+ (setq pending (nreverse pending)
+ ;; The elements of PENDING are now in forward order.
+ ;; Do the operation and record failures.
+ failures (nconc (apply function (append args pending))
+ failures)
+ ;; Transfer the elemens of PENDING onto PAST
+ ;; and clear it out. Now PAST contains the first N files
+ ;; specified (for some N), and FILES contains the rest.
+ past (nconc past pending)
pending nil
pending-length 0))
;; Do (setq pending (cons thisfile pending))
(setq pending files)
(setq pending-length (+ thislength pending-length))
(setq files rest)))
- (nconc (apply function (append args pending))
- failures)))
+ (setq pending (nreverse pending))
+ (prog1
+ (nconc (apply function (append args pending))
+ failures)
+ ;; Now the original list FILES has been put back as it was.
+ (nconc past pending))))
;;;###autoload
(defun dired-do-print (&optional arg)
(let* ((file-list (dired-get-marked-files t arg))
(command (dired-mark-read-string
"Print %s with: "
- (mapconcat 'concat (append (list 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))))
(defvar dired-file-version-alist)
+;;;###autoload
(defun dired-clean-directory (keep)
"Flag numerical backups for deletion.
Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest.
(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))
;;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))
+ (backup-extract-version-start (length base-versions))
(possibilities (file-name-all-completions
base-versions
(file-name-directory fn)))
(setq base-version-list ; there was a base version to which
(assoc (substring fn 0 start-vn) ; this looks like a
dired-file-version-alist)) ; subversion
- (not (memq (string-to-int (substring fn (+ 2 start-vn)))
+ (not (memq (string-to-number (substring fn (+ 2 start-vn)))
base-version-list)) ; this one doesn't make the cut
(progn (beginning-of-line)
(delete-char 1)
(insert dired-del-marker)))))
\f
;;; 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).
(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.
The prompt mentions the file(s) or the marker, as appropriate.
-If there is output, it goes to a separate buffer.
+If there is a `*' in COMMAND, surrounded by whitespace, this runs
+COMMAND just once with the entire file list substituted there.
+
+If there is no `*', but there is a `?' in COMMAND, surrounded by
+whitespace, this runs COMMAND on each file individually with the
+file name substituted for `?'.
+
+Otherwise, this runs COMMAND on each file individually with the
+file name added at the end of COMMAND (separated by a space).
-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.
+`*' and `?' when not surrounded by whitespace have no special
+significance for `dired-do-shell-command', and are passed through
+normally to the shell, but you must confirm first. To pass `*' by
+itself to the shell as a wildcard, type `*\"\"'.
-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.
+If COMMAND produces output, it goes to a separate buffer.
-The shell command has the top level directory as working directory, so
-output files usually are created there instead of in a subdir."
+This feature does not try to redisplay Dired buffers afterward, as
+there's no telling what files COMMAND may have changed.
+Type \\[dired-do-redisplay] to redisplay the marked files.
+
+When COMMAND runs, its working directory is the top-level directory of
+the Dired buffer, so 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)))
- (if on-each
- (dired-bunch-files
- (- 10000 (length command))
- (function (lambda (&rest files)
- (dired-run-shell-command
- (dired-shell-stuff-it command files t arg))))
- nil
- file-list)
- ;; execute the shell command
- (dired-run-shell-command
- (dired-shell-stuff-it command file-list nil 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 dired-star-subst-regexp command)))
+ (subst (not (string-match dired-quark-subst-regexp command)))
+ (star (not (string-match "\\*" command)))
+ (qmark (not (string-match "\\?" command))))
+ ;; Get confirmation for wildcards that may have been meant
+ ;; to control substitution of a file name or the file name list.
+ (if (cond ((not (or on-each subst))
+ (error "You can not combine `*' and `?' substitution marks"))
+ ((and star (not on-each))
+ (y-or-n-p "Confirm--do you mean to use `*' as a wildcard? "))
+ ((and qmark (not subst))
+ (y-or-n-p "Confirm--do you mean to use `?' as a wildcard? "))
+ (t))
+ (if on-each
+ (dired-bunch-files
+ (- 10000 (length command))
+ (function (lambda (&rest files)
+ (dired-run-shell-command
+ (dired-shell-stuff-it command files t arg))))
+ nil
+ file-list)
+ ;; execute the shell command
+ (dired-run-shell-command
+ (dired-shell-stuff-it command file-list nil arg))))))
;; Might use {,} for bash or csh:
(defvar dired-mark-prefix ""
;; Might be redefined for smarter things and could then use RAW-ARG
;; (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.
(let ((stuff-it
- (if (string-match "\\*" command)
- (function (lambda (x)
- (dired-replace-in-string "\\*" x command)))
- (function (lambda (x) (concat command " " x))))))
+ (if (or (string-match dired-star-subst-regexp command)
+ (string-match dired-quark-subst-regexp command))
+ (lambda (x)
+ (let ((retval command))
+ (while (string-match
+ "\\(^\\|[ \t]\\)\\([*?]\\)\\([ \t]\\|$\\)" retval)
+ (setq retval (replace-match x t t retval 2)))
+ retval))
+ (lambda (x) (concat command dired-mark-separator x)))))
(if on-each
- (mapconcat stuff-it (mapcar 'dired-shell-quote file-list) ";")
- (let ((fns (mapconcat 'dired-shell-quote
- file-list dired-mark-separator)))
+ (mapconcat stuff-it (mapcar 'shell-quote-argument file-list) ";")
+ (let ((files (mapconcat 'shell-quote-argument
+ file-list dired-mark-separator)))
(if (> (length file-list) 1)
- (setq fns (concat dired-mark-prefix fns dired-mark-postfix)))
- (funcall stuff-it fns)))))
+ (setq files (concat dired-mark-prefix files dired-mark-postfix)))
+ (funcall stuff-it files)))))
;; This is an extra function so that it can be redefined by ange-ftp.
+;;;###autoload
(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)
\f
(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.
(set-buffer err-buffer)
(erase-buffer)
(setq default-directory dir ; caller's default-directory
- err (/= 0
- (apply (function dired-call-process) program nil arguments)))
+ err (not (eq 0
+ (apply (function dired-call-process) program nil arguments))))
(if err
(progn
(dired-log (concat program " " (prin1-to-string arguments) "\n"))
(while (/= 0 arg)
(setq file (dired-get-filename nil t))
(if (not file)
- (error "Can only kill file lines.")
+ (error "Can only kill file lines")
(save-excursion (and file
(dired-goto-subdir file)
(dired-kill-subdir)))
(defun dired-do-kill-lines (&optional arg fmt)
"Kill all marked lines (not the files).
With a prefix argument, kill that many lines starting with the current line.
-\(A negative argument kills lines before the current line.)
-To kill an entire subdirectory, go to its directory header line
-and use this command with a prefix argument (the value does not matter)."
+\(A negative argument kills backward.)
+If you use this command with a prefix argument to kill the line
+for a file that is a directory, which you have inserted in the
+Dired buffer as a subdirectory, then it deletes that subdirectory
+from the buffer as well.
+To kill an entire subdirectory \(without killing its line in the
+parent directory), go to its directory header line and use this
+command with a prefix argument (the value does not matter)."
;; Returns count of killed lines. FMT="" suppresses message.
(interactive "P")
(if arg
(dired-kill-line arg))
(save-excursion
(goto-char (point-min))
- (let (buffer-read-only (count 0))
- (if (not arg) ; kill marked lines
- (let ((regexp (dired-marker-regexp)))
- (while (and (not (eobp))
- (re-search-forward regexp nil t))
- (setq count (1+ count))
- (delete-region (progn (beginning-of-line) (point))
- (progn (forward-line 1) (point)))))
- ;; else kill unmarked lines
- (while (not (eobp))
- (if (or (dired-between-files)
- (not (looking-at "^ ")))
- (forward-line 1)
- (setq count (1+ count))
- (delete-region (point) (save-excursion
- (forward-line 1)
- (point))))))
+ (let (buffer-read-only
+ (count 0)
+ (regexp (dired-marker-regexp)))
+ (while (and (not (eobp))
+ (re-search-forward regexp nil t))
+ (setq count (1+ count))
+ (delete-region (progn (beginning-of-line) (point))
+ (progn (forward-line 1) (point))))
(or (equal "" fmt)
(message (or fmt "Killed %d line%s.") count (dired-plural-s count)))
count))))
(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")
+ ("\\.dz\\'" "" "dictunzip")
+ ("\\.tbz\\'" ".tar" "bunzip2")
+ ("\\.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 '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))
+ ((and suffix (nth 2 suffix))
+ ;; We found an uncompression rule.
(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))
- (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)
- (let ((files (dired-get-marked-files t arg))
+ (or (eq dired-no-confirm t)
+ (memq op-symbol dired-no-confirm)
+ ;; Pass t for DISTINGUISH-ONE-MARKED so that a single file which
+ ;; is marked pops up a window. That will help the user see
+ ;; it isn't the current line file.
+ (let ((files (dired-get-marked-files t arg nil t))
(string (if (eq op-symbol 'compress) "Compress or uncompress"
(capitalize (symbol-name op-symbol)))))
(dired-mark-pop-up nil op-symbol files (function y-or-n-p)
'((?\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
+ (?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).
(sit-for 1)
(apply 'message qprompt qs-args)
(setq char (set qs-var (read-char))))
+ ;; Display the question with the answer.
+ (message (concat (apply 'format qprompt qs-args)
+ (char-to-string char)))
(memq (cdr elt) '(t y yes)))))))
\f
;;;###autoload
(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)
(defun dired-do-redisplay (&optional arg test-for-subdir)
"Redisplay all marked (or next ARG) files.
If on a subdir line, redisplay that subdirectory. In that case,
-a prefix arg lets you edit the `ls' switches used for the new listing."
+a prefix arg lets you edit the `ls' switches used for the new listing.
+
+Dired remembers switches specified with a prefix arg, so that reverting
+the buffer will not reset them. However, using `dired-undo' to re-insert
+or delete subdirectories can bypass this machinery. Hence, you sometimes
+may have to reset some subdirectory switches after a `dired-undo'.
+You can reset all subdirectory switches to the default using
+\\<dired-mode-map>\\[dired-reset-subdir-switches].
+See Info node `(emacs-xtra)Subdir switches' for more details."
;; Moves point if the next ARG files are redisplayed.
(interactive "P\np")
(if (and test-for-subdir (dired-get-subdir))
- (dired-insert-subdir
- (dired-get-subdir)
- (if arg (read-string "Switches for listing: " dired-actual-switches)))
+ (let* ((dir (dired-get-subdir))
+ (switches (cdr (assoc-string dir dired-switches-alist))))
+ (dired-insert-subdir
+ dir
+ (when arg
+ (read-string "Switches for listing: "
+ (or switches
+ dired-subdir-switches
+ 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))
arg)
(dired-move-to-filename)
(message "Redisplaying...done")))
+
+(defun dired-reset-subdir-switches ()
+ "Set `dired-switches-alist' to nil and revert dired buffer."
+ (interactive)
+ (setq dired-switches-alist nil)
+ (revert-buffer))
\f
(defun dired-update-file-line (file)
;; Delete the current line, and insert an entry for FILE.
(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)
- ;; In all buffers dired'ing DIRECTORY, run FUN with ARGS.
- ;; Return list of buffers where FUN succeeded (i.e., returned non-nil).
- (let ((buf-list (dired-buffers-for-dir (expand-file-name directory)))
- (obuf (current-buffer))
- buf success-list)
- (while buf-list
- (setq buf (car buf-list)
- buf-list (cdr buf-list))
- (unwind-protect
- (progn
- (set-buffer buf)
- (if (apply fun args)
- (setq success-list (cons (buffer-name buf) success-list))))
- (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
;; 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))
- (directory (file-name-directory filename))
- reason)
- (setq filename (file-name-nondirectory filename)
+ (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)
(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
+ (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 ..
(let (buffer-read-only opoint)
(beginning-of-line)
(setq opoint (point))
- (dired-add-entry-do-indentation marker-char)
- ;; don't expand `.'. Show just the file name within directory.
+ ;; Don't expand `.'. Show just the file name within directory.
(let ((default-directory directory))
- (insert-directory filename
- (concat dired-actual-switches "d")))
- (dired-insert-set-properties opoint (point))
+ (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:
+ (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) (save-excursion
(dired-move-to-filename))
;; return nil if all went well
nil))
- (if reason ; don't move away on failure
+ (if reason ; don't move away on failure
(goto-char opoint))
- (not reason))) ; return t on success, nil else
-
-;; This is a separate function for the sake of nested dired format.
-(defun dired-add-entry-do-indentation (marker-char)
- ;; two spaces or a marker plus a space:
- (insert (if marker-char
- (if (integerp marker-char) marker-char dired-marker-char)
- ?\040)
- ?\040))
+ (not reason))) ; return t on success, nil else
(defun dired-after-subdir-garbage (dir)
;; Return pos of first file line of DIR, skipping header and total
;;;###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)
+ "Create or update the line for FILE in all Dired buffers it would belong in."
(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,
\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)
+ (other :tag "ask" t))
+ :group 'dired)
(defvar dired-overwrite-confirmed)
(defun dired-handle-overwrite (to)
- ;; Save old version of a to be overwritten file TO.
+ ;; Save old version of file TO that is to be overwritten.
;; `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)
+ (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.
+ (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))))
+ ;; Not a directory.
+ (or top (dired-handle-overwrite to))
+ (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)))))
;;;###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
+(defun dired-rename-file (file newname ok-if-already-exists)
+ (dired-handle-overwrite newname)
+ (rename-file file newname ok-if-already-exists) ; 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))))
- (dired-remove-file from)
+ (and (get-file-buffer file)
+ (with-current-buffer (get-file-buffer file)
+ (set-visited-file-name newname nil t)))
+ (dired-remove-file file)
;; See if it's an inserted subdir, and rename that, too.
- (dired-rename-subdir from to))
+ (dired-rename-subdir file newname))
(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-advertise)))))
(defun dired-rename-subdir-2 (elt dir to)
- ;; Update the headerline and dired-subdir-alist element of directory
- ;; described by alist-element ELT to reflect the moving of DIR to TO.
- ;; Thus, ELT describes either DIR itself or a subdir of DIR.
+ ;; Update the headerline and dired-subdir-alist element, as well as
+ ;; dired-switches-alist element, of directory described by
+ ;; alist-element ELT to reflect the moving of DIR to TO. Thus, ELT
+ ;; describes either DIR itself or a subdir of DIR.
(save-excursion
(let ((regexp (regexp-quote (directory-file-name dir)))
(newtext (directory-file-name to))
(if (re-search-forward regexp (match-end 1) t)
(replace-match newtext t t)
(error "Expected to find `%s' in headerline of %s" dir (car elt))))
- ;; Update buffer-local dired-subdir-alist
- (setcar elt
- (dired-normalize-subdir
- (dired-replace-in-string regexp newtext (car elt)))))))
-\f
-(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))
+ ;; Update buffer-local dired-subdir-alist and dired-switches-alist
+ (let ((cons (assoc-string (car elt) dired-switches-alist))
+ (cur-dir (dired-normalize-subdir
+ (dired-replace-in-string regexp newtext (car elt)))))
+ (setcar elt cur-dir)
+ (when cons (setcar cons cur-dir))))))
\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
;; 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
(dired-move-to-filename))
\f
(defun dired-do-create-files (op-symbol file-creator operation arg
- &optional marker-char op1
- how-to)
- ;; Create a new file for each marked file.
- ;; Prompts user for target, which is a directory in which to create
- ;; the new files. Target may be a plain file if only one marked
- ;; file exists.
- ;; OP-SYMBOL is the symbol for the operation. Function `dired-mark-pop-up'
- ;; 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 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,
- ;; 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
- ;; links to directories are not to be considered as directories
- ;; (as file-directory-p would if HOW-TO had been nil).
+ &optional marker-char op1
+ how-to)
+ "Create a new file for each marked file.
+Prompts user for target, which is a directory in which to create
+ the new files. Target may be a plain file if only one marked
+ file exists. The way the default for the target directory is
+ computed depends on the value of `dired-dwim-target-directory'.
+OP-SYMBOL is the symbol for the operation. Function `dired-mark-pop-up'
+ 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 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 generalized
+ 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
+ links to directories are not to be considered as directories
+ (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-dir (dired-dwim-target-directory))
+ (default (and dired-one-file
+ (expand-file-name (file-name-nondirectory (car fn-list))
+ target-dir)))
+ (target (expand-file-name ; fluid variable inside dired-create-files
(dired-mark-read-file-name
- (concat (if (= 1 fn-count) 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))
+ (concat (if dired-one-file op1 operation) " %s to: ")
+ target-dir op-symbol arg rfn-list default)))
+ (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 cygwin))
+ (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.
;; marks (ARG=nil) or a repeat factor (integerp ARG).
;; If the current file was used, the list has but one element and ARG
;; does not matter. (It is non-nil, non-integer in that case, namely '(4)).
+;; DEFAULT is the default value to return if the user just hits RET;
+;; if it is omitted or nil, then the name of the directory is used.
-(defun dired-mark-read-file-name (prompt dir op-symbol arg files)
+(defun dired-mark-read-file-name (prompt dir op-symbol arg files
+ &optional default)
(dired-mark-pop-up
nil op-symbol files
(function read-file-name)
- (format prompt (dired-mark-prompt arg files)) dir))
+ (format prompt (dired-mark-prompt arg files)) dir default))
(defun dired-dwim-target-directory ()
;; Try to guess which target directory the user may want.
;; 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
-with the same names that the files currently have."
+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. The default
+suggested for the target directory depends on the value of
+`dired-dwim-target', which see."
(interactive "P")
- (dired-do-create-files 'copy (function dired-copy-file)
- (if dired-copy-preserve-time "Copy [-p]" "Copy")
- arg dired-keep-marker-copy))
+ (let ((dired-recursive-copies dired-recursive-copies))
+ (dired-do-create-files 'copy (function dired-copy-file)
+ "Copy"
+ arg dired-keep-marker-copy
+ nil dired-copy-how-to-fn)))
;;;###autoload
(defun dired-do-symlink (&optional arg)
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
-with the same names that the files currently have."
+with the same names that the files currently have. The default
+suggested for the target directory depends on the value of
+`dired-dwim-target', which see."
(interactive "P")
(dired-do-create-files 'symlink (function make-symbolic-link)
"Symlink" arg dired-keep-marker-symlink))
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 hard links are made in that directory
-with the same names that the files currently have."
+with the same names that the files currently have. The default
+suggested for the target directory depends on the value of
+`dired-dwim-target', which see."
(interactive "P")
- (dired-do-create-files 'hardlink (function add-name-to-file)
+ (dired-do-create-files 'hardlink (function dired-hardlink)
"Hardlink" arg dired-keep-marker-hardlink))
+(defun dired-hardlink (file newname &optional ok-if-already-exists)
+ (dired-handle-overwrite newname)
+ ;; error is caught in -create-files
+ (add-name-to-file file newname ok-if-already-exists)
+ ;; Update the link count
+ (dired-relist-file file))
+
;;;###autoload
(defun dired-do-rename (&optional arg)
"Rename current file or all marked (or next ARG) files.
When renaming just the current file, you specify the new name.
-When renaming multiple or marked files, you specify a directory."
+When renaming multiple or marked files, you specify a directory.
+This command also renames any buffers that are visiting the files.
+The default suggested for the target directory depends on the value
+of `dired-dwim-target', which see."
(interactive "P")
(dired-do-create-files 'move (function dired-rename-file)
"Move" arg dired-keep-marker-rename "Rename"))
;;; 5K
;;;###begin dired-re.el
(defun dired-do-create-files-regexp
- (file-creator operation arg regexp newname &optional whole-path marker-char)
+ (file-creator operation arg regexp newname &optional whole-name marker-char)
;; Create a new file for each marked file using regexps.
;; FILE-CREATOR and OPERATION as in dired-create-files.
;; 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-NAME 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))
(downcase operation)))
(regexp-name-constructor
;; Function to construct new filename using REGEXP and NEWNAME:
- (if whole-path ; easy (but rare) case
+ (if whole-name ; easy (but rare) case
(function
(lambda (from)
(let ((to (dired-string-replace-match regexp from newname))
to)
(dired-log "%s: %s did not match regexp %s\n"
operation from regexp)))))
- ;; not whole-path, replace non-directory part only
+ ;; not whole-name, replace non-directory part only
(function
(lambda (from)
(let* ((new (dired-string-replace-match
(defun dired-mark-read-regexp (operation)
;; Prompt user about performing OPERATION.
- ;; Read and return list of: regexp newname arg whole-path.
- (let* ((whole-path
+ ;; Read and return list of: regexp newname arg whole-name.
+ (let* ((whole-name
(equal 0 (prefix-numeric-value current-prefix-arg)))
(arg
- (if whole-path nil current-prefix-arg))
+ (if whole-name nil current-prefix-arg))
(regexp
(dired-read-regexp
- (concat (if whole-path "Path " "") operation " from (regexp): ")))
+ (concat (if whole-name "Abs. " "") operation " from (regexp): ")))
(newname
(read-string
- (concat (if whole-path "Path " "") operation " " regexp " to: "))))
- (list regexp newname arg whole-path)))
+ (concat (if whole-name "Abs. " "") operation " " regexp " to: "))))
+ (list regexp newname arg whole-name)))
;;;###autoload
-(defun dired-do-rename-regexp (regexp newname &optional arg whole-path)
- "Rename marked files containing REGEXP to NEWNAME.
+(defun dired-do-rename-regexp (regexp newname &optional arg whole-name)
+ "Rename selected files whose names match REGEXP to NEWNAME.
+
+With non-zero prefix argument ARG, the command operates on the next ARG
+files. Otherwise, it operates on all the marked files, or the current
+file if none are marked.
+
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 \\=\\<n> 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)
- "Rename" arg regexp newname whole-path dired-keep-marker-rename))
+ "Rename" arg regexp newname whole-name dired-keep-marker-rename))
;;;###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."
+(defun dired-do-copy-regexp (regexp newname &optional arg whole-name)
+ "Copy selected files whose names match REGEXP to NEWNAME.
+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-name 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."
+(defun dired-do-hardlink-regexp (regexp newname &optional arg whole-name)
+ "Hardlink selected files whose names match REGEXP to NEWNAME.
+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)
- "HardLink" arg regexp newname whole-path dired-keep-marker-hardlink))
+ "HardLink" arg regexp newname whole-name dired-keep-marker-hardlink))
;;;###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."
+(defun dired-do-symlink-regexp (regexp newname &optional arg whole-name)
+ "Symlink selected files whose names match REGEXP to NEWNAME.
+See function `dired-do-rename-regexp' for more info."
(interactive (dired-mark-read-regexp "SymLink"))
(dired-do-create-files-regexp
(function make-symbolic-link)
- "SymLink" arg regexp newname whole-path dired-keep-marker-symlink))
+ "SymLink" arg regexp newname whole-name dired-keep-marker-symlink))
(defun dired-create-files-non-directory
(file-creator basename-constructor operation arg)
With a prefix arg, you may edit the ls switches used for this listing.
You can add `R' to the switches to expand the whole tree starting at
this subdirectory.
-This function takes some pains to conform to `ls -lR' output."
+This function takes some pains to conform to `ls -lR' output.
+
+Dired remembers switches specified with a prefix arg, so that reverting
+the buffer will not reset them. However, using `dired-undo' to re-insert
+or delete subdirectories can bypass this machinery. Hence, you sometimes
+may have to reset some subdirectory switches after a `dired-undo'.
+You can reset all subdirectory switches to the default using
+\\<dired-mode-map>\\[dired-reset-subdir-switches].
+See Info node `(emacs-xtra)Subdir switches' for more details."
(interactive
(list (dired-get-filename)
(if current-prefix-arg
- (read-string "Switches for listing: " dired-actual-switches))))
+ (read-string "Switches for listing: "
+ (or dired-subdir-switches dired-actual-switches)))))
(let ((opoint (point)))
;; We don't need a marker for opoint as the subdir is always
;; inserted *after* opoint.
;; 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,
(interactive
(list (dired-get-filename)
(if current-prefix-arg
- (read-string "Switches for listing: " dired-actual-switches))))
+ (read-string "Switches for listing: "
+ (or dired-subdir-switches dired-actual-switches)))))
(setq dirname (file-name-as-directory (expand-file-name dirname)))
- (dired-insert-subdir-validate dirname switches)
(or no-error-if-not-dir-p
(file-directory-p dirname)
(error "Attempt to insert a non-directory: %s" dirname))
(let ((elt (assoc dirname dired-subdir-alist))
- switches-have-R mark-alist case-fold-search buffer-read-only)
+ (cons (assoc-string dirname dired-switches-alist))
+ (modflag (buffer-modified-p))
+ (old-switches switches)
+ switches-have-R mark-alist case-fold-search buffer-read-only)
+ (and (not switches) cons (setq switches (cdr cons)))
+ (dired-insert-subdir-validate dirname switches)
;; case-fold-search is nil now, so we can test for capital `R':
(if (setq switches-have-R (and switches (string-match "R" switches)))
;; avoid duplicated subdirs
(dired-insert-subdir-newpos dirname)) ; else compute new position
(dired-insert-subdir-doupdate
dirname elt (dired-insert-subdir-doinsert dirname switches))
- (if switches-have-R (dired-build-subdir-alist))
+ (when old-switches
+ (if cons
+ (setcdr cons switches)
+ (push (cons dirname switches) dired-switches-alist)))
+ (when switches-have-R
+ (dired-build-subdir-alist switches)
+ (setq switches (dired-replace-in-string "R" "" switches))
+ (dolist (cur-ass dired-subdir-alist)
+ (let ((cur-dir (car cur-ass)))
+ (and (dired-in-this-tree cur-dir dirname)
+ (let ((cur-cons (assoc-string cur-dir dired-switches-alist)))
+ (if cur-cons
+ (setcdr cur-cons switches)
+ (push (cons cur-dir switches) dired-switches-alist)))))))
(dired-initial-position dirname)
- (save-excursion (dired-mark-remembered mark-alist))))
+ (save-excursion (dired-mark-remembered mark-alist))
+ (restore-buffer-modified-p modflag)))
;; This is a separate function for dired-vms.
(defun dired-insert-subdir-validate (dirname &optional switches)
;; Signal an error if invalid (e.g. user typed `i' on `..').
(or (dired-in-this-tree dirname (expand-file-name default-directory))
(error "%s: not in this directory tree" dirname))
- (if switches
+ (let ((real-switches (or switches dired-subdir-switches)))
+ (when real-switches
(let (case-fold-search)
(mapcar
(function
(lambda (x)
- (or (eq (null (string-match x switches))
+ (or (eq (null (string-match x real-switches))
(null (string-match x dired-actual-switches)))
- (error "Can't have dirs with and without -%s switches together"
- x))))
+ (error
+ "Can't have dirs with and without -%s switches together" x))))
;; all switches that make a difference to dired-get-filename:
- '("F" "b")))))
+ '("F" "b"))))))
(defun dired-alist-add (dir new-marker)
;; Add new DIR at NEW-MARKER. Sort alist.
(> (dired-get-subdir-min elt1)
(dired-get-subdir-min elt2)))))))
-(defun dired-kill-tree (dirname &optional remember-marks)
- ;;"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))
+(defun dired-kill-tree (dirname &optional remember-marks kill-root)
+ "Kill all proper subdirs of DIRNAME, excluding DIRNAME itself.
+Interactively, you can kill DIRNAME as well by using a prefix argument.
+In interactive use, the command prompts for DIRNAME.
+
+When called from Lisp, if REMEMBER-MARKS is non-nil, return an alist
+of marked files. If KILL-ROOT is non-nil, kill DIRNAME as well."
+ (interactive "DKill tree below directory: \ni\nP")
+ (setq dirname (file-name-as-directory (expand-file-name dirname)))
(let ((s-alist dired-subdir-alist) dir m-alist)
(while s-alist
(setq dir (car (car s-alist))
s-alist (cdr s-alist))
- (if (and (not (string-equal dir dirname))
- (dired-in-this-tree dir dirname)
- (dired-goto-subdir dir))
- (setq m-alist (nconc (dired-kill-subdir remember-marks) m-alist))))
+ (and (or kill-root (not (string-equal dir dirname)))
+ (dired-in-this-tree dir dirname)
+ (dired-goto-subdir dir)
+ (setq m-alist (nconc (dired-kill-subdir remember-marks) m-alist))))
m-alist))
(defun dired-insert-subdir-newpos (new-dir)
(delete-region begin-marker (point)))))
(defun dired-insert-subdir-doinsert (dirname switches)
- ;; Insert ls output after point and put point on the correct
- ;; position for the subdir alist.
+ ;; Insert ls output after point.
;; Return the boundary of the inserted text (as list of BEG and END).
- (let ((begin (point)) end)
- (message "Reading directory %s..." dirname)
- (let ((dired-actual-switches
- (or switches
- (dired-replace-in-string "R" "" dired-actual-switches))))
- (if (equal dirname (car (car (reverse dired-subdir-alist))))
- ;; top level directory may contain wildcards:
- (dired-readin-insert dired-directory)
- (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)
- ;; call dired-insert-headerline afterwards, as under VMS dired-ls
- ;; does insert the headerline itself and the insert function just
- ;; moves point.
- ;; Need a marker for END as this inserts text.
- (goto-char begin)
- (dired-insert-headerline dirname)
- ;; point is now like in dired-build-subdir-alist
- (prog1
- (list begin (marker-position end))
- (set-marker end nil))))
+ (save-excursion
+ (let ((begin (point)))
+ (let ((dired-actual-switches
+ (or switches
+ dired-subdir-switches
+ (dired-replace-in-string "R" "" dired-actual-switches))))
+ (if (equal dirname (car (car (last dired-subdir-alist))))
+ ;; If doing the top level directory of the buffer,
+ ;; redo it as specified in dired-directory.
+ (dired-readin-insert)
+ (dired-insert-directory dirname dired-actual-switches nil nil t)))
+ (list begin (point)))))
(defun dired-insert-subdir-doupdate (dirname elt beg-end)
;; Point is at the correct subdir alist position for ELT,
(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
\f
;;;###autoload
(defun dired-mark-subdir-files ()
- "Mark all files except `.' and `..'."
+ "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))))
Lower levels are unaffected."
;; With optional REMEMBER-MARKS, return a mark-alist.
(interactive)
- (let ((beg (dired-subdir-min))
- (end (dired-subdir-max))
- buffer-read-only cur-dir)
- (setq cur-dir (dired-current-directory))
+ (let* ((beg (dired-subdir-min))
+ (end (dired-subdir-max))
+ (modflag (buffer-modified-p))
+ (cur-dir (dired-current-directory))
+ (cons (assoc-string cur-dir dired-switches-alist))
+ buffer-read-only)
(if (equal cur-dir default-directory)
(error "Attempt to kill top level directory"))
(prog1
(delete-region beg end)
(if (eobp) ; don't leave final blank line
(delete-char -1))
- (dired-unsubdir cur-dir))))
+ (dired-unsubdir cur-dir)
+ (when cons
+ (setq dired-switches-alist (delete cons dired-switches-alist)))
+ (restore-buffer-modified-p modflag))))
(defun dired-unsubdir (dir)
;; Remove DIR from the alist
dir (file-name-directory (directory-file-name dir))))
;;(setq dir (expand-file-name dir))
(or (dired-goto-subdir dir)
- (error "Cannot go up to %s - not in this tree." dir))))
+ (error "Cannot go up to %s - not in this tree" dir))))
;;;###autoload
(defun dired-tree-down ()
Use \\[dired-hide-all] to (un)hide all directories."
(interactive "p")
(dired-hide-check)
- (while (>= (setq arg (1- arg)) 0)
- (let* ((cur-dir (dired-current-directory))
- (hidden-p (dired-subdir-hidden-p cur-dir))
- (elt (assoc cur-dir dired-subdir-alist))
- (end-pos (1- (dired-get-subdir-max elt)))
- buffer-read-only)
- ;; keep header line visible, hide rest
- (goto-char (dired-get-subdir-min elt))
- (skip-chars-forward "^\n\r")
- (if hidden-p
- (subst-char-in-region (point) end-pos ?\r ?\n)
- (subst-char-in-region (point) end-pos ?\n ?\r)))
- (dired-next-subdir 1 t)))
+ (let ((modflag (buffer-modified-p)))
+ (while (>= (setq arg (1- arg)) 0)
+ (let* ((cur-dir (dired-current-directory))
+ (hidden-p (dired-subdir-hidden-p cur-dir))
+ (elt (assoc cur-dir dired-subdir-alist))
+ (end-pos (1- (dired-get-subdir-max elt)))
+ buffer-read-only)
+ ;; keep header line visible, hide rest
+ (goto-char (dired-get-subdir-min elt))
+ (skip-chars-forward "^\n\r")
+ (if hidden-p
+ (subst-char-in-region (point) end-pos ?\r ?\n)
+ (subst-char-in-region (point) end-pos ?\n ?\r)))
+ (dired-next-subdir 1 t))
+ (restore-buffer-modified-p modflag)))
;;;###autoload
(defun dired-hide-all (arg)
Use \\[dired-hide-subdir] to (un)hide a particular subdirectory."
(interactive "P")
(dired-hide-check)
- (let (buffer-read-only)
+ (let ((modflag (buffer-modified-p))
+ buffer-read-only)
(if (save-excursion
(goto-char (point-min))
(search-forward "\r" nil t))
;; hide
(let ((pos (point-max)) ; pos of end of last directory
(alist dired-subdir-alist))
- (while alist ; while there are dirs before pos
+ (while alist ; while there are dirs before pos
(subst-char-in-region (dired-get-subdir-min (car alist)) ; pos of prev dir
(save-excursion
(goto-char pos) ; current dir
(point))
?\n ?\r)
(setq pos (dired-get-subdir-min (car alist))) ; prev dir gets current dir
- (setq alist (cdr alist)))))))
+ (setq alist (cdr alist)))))
+ (restore-buffer-modified-p modflag)))
;;;###end dired-ins.el
;; Functions for searching in tags style among marked files.
;;;###autoload
-(defun dired-do-tags-search (regexp)
+(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)))
+ (tags-search regexp '(dired-get-marked-files nil nil 'dired-nondirectory-p)))
;;;###autoload
-(defun dired-do-tags-query-replace (from to &optional delimited)
- "Query-replace-regexp FROM with TO through all marked files.
+(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
+If you exit (\\[keyboard-quit], RET or q), 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)))
+ (let ((common
+ (query-replace-read-args
+ "Query replace regexp in marked files" t t)))
+ (list (nth 0 common) (nth 1 common) (nth 2 common))))
+ (dolist (file (dired-get-marked-files nil nil 'dired-nondirectory-p))
+ (let ((buffer (get-file-buffer file)))
+ (if (and buffer (with-current-buffer buffer
+ buffer-read-only))
+ (error "File `%s' is visited read-only" file))))
+ (tags-query-replace from to delimited
+ '(dired-get-marked-files nil nil 'dired-nondirectory-p)))
+
+(defun dired-nondirectory-p (file)
+ (not (file-directory-p file)))
\f
+;;;###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 "%s" (buffer-string))))
(provide 'dired-aux)
+;;; arch-tag: 4b508de9-a153-423d-8d3f-a1bbd86f4f60
;;; dired-aux.el ends here