comparison lisp/dired/dired.el @ 70:131b0175ea99 r20-0b30

Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents
children 6a378aca36af
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; dired.el --- directory-browsing commands
2 ;; Keywords: dired extensions
3
4 ;; Copyright (C) 1985, 1986, 1991, 1992 Free Software Foundation, Inc.
5
6 ;; This file is part of XEmacs.
7
8 ;; XEmacs is free software; you can redistribute it and/or modify it
9 ;; under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2, or (at your option)
11 ;; any later version.
12
13 ;; XEmacs is distributed in the hope that it will be useful, but
14 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;; General Public License for more details.
17
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with XEmacs; see the file COPYING. If not, write to the
20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;; Boston, MA 02111-1307, USA.
22
23 ;; Rewritten in 1990/1991 to add tree features, file marking and
24 ;; sorting by Sebastian Kremer <sk@thp.uni-koeln.de>.
25
26 (provide 'dired)
27
28 (defconst dired-version (substring "!Revision: 6.0 !" 11 -2)
29 "The revision number of Tree Dired (as string). The complete RCS id is:
30
31 !Id: dired.el,v 6.0 1992/05/15 14:25:45 sk RelBeta !
32
33 Don't forget to mention this when reporting bugs to:
34
35 Sebastian Kremer <sk@thp.uni-koeln.de>
36
37 Tree dired is available for anonymous ftp in USA in:
38
39 ftp.cs.buffalo.edu:pub/Emacs/diredall.tar.Z
40
41 and in Europe at my own site in Germany:
42
43 ftp.uni-koeln.de:/pub/gnu/emacs/diredall.tar.Z")
44 ;; Should perhaps later give bug-gnu-emacs@prep.gnu.ai.mit.edu instead.
45
46 ;; compatibility package when using Emacs 18.55
47 ;; XEmacs fix:
48 (defvar dired-emacs-19-p (not (equal (substring emacs-version 0 2) "18")))
49 ;;;#### install (is there a better way to test for Emacs 19?)
50 (or dired-emacs-19-p
51 (require 'emacs-19))
52
53 ;;; Customizable variables
54
55 ;;; The funny comments are for autoload.el, to automagically update
56 ;;; loaddefs.
57
58 (defvar dired-use-gzip-instead-of-compress t
59 "*If non-nil, use gzip instead of compress as the standard compress
60 program")
61
62 (defvar dired-make-gzip-quiet t
63 "*If non-nil, pass -q to shell commands involving gzip this will override
64 GZIP environment variable.")
65
66 (defvar dired-znew-switches nil
67 "*If non-nil, a string of switches that will be passed to `znew'
68 example: \"-K\"")
69
70 (defvar dired-gzip-file-extension ".gz"
71 "*A string representing the suffix created by gzip. This should probably
72 match the value of --suffix or -S in the GZIP environment variable if it
73 exists and \".gz\" if it does not.")
74
75 ;;;###autoload
76 (defvar dired-listing-switches (purecopy "-al")
77 "*Switches passed to ls for dired. MUST contain the `l' option.
78 Can contain even `F', `b', `i' and `s'.")
79
80 ; Don't use absolute paths as /bin should be in any PATH and people
81 ; may prefer /usr/local/gnu/bin or whatever. However, chown is
82 ; usually not in PATH.
83
84 ;;;###autoload
85 (defvar dired-chown-program
86 (purecopy
87 (if (memq system-type '(dgux-unix hpux usg-unix-v silicon-graphics-unix irix))
88 "chown" "/etc/chown"))
89 "*Name of chown command (usully `chown' or `/etc/chown').")
90
91 ;;;###autoload
92 (defvar dired-ls-program (purecopy "ls")
93 "*Absolute or relative name of the ls program used by dired.")
94
95 ;;;###autoload
96 (defvar dired-ls-F-marks-symlinks t
97 "*Informs dired about how ls -lF marks symbolic links.
98 Set this to t if `dired-ls-program' with -lF marks the symbolic link
99 itself with a trailing @ (usually the case under Ultrix).
100
101 Example: if `ln -s foo bar; ls -F bar' gives `bar -> foo', set it to
102 nil, if it gives `bar@ -> foo', set it to t.
103
104 Dired checks if there is really a @ appended. Thus, if you have a
105 marking ls program on one host and a non-marking on another host, and
106 don't care about symbolic links which really end in a @, you can
107 always set this variable to t.")
108
109 ;;;###autoload
110 (defvar dired-trivial-filenames (purecopy "^\\.\\.?$\\|^#")
111 "*Regexp of files to skip when moving point to the first file of a new directory listing.
112 Nil means move to the subdir line, t means move to first file.")
113
114 ;;;###autoload
115 (defvar dired-keep-marker-move t
116 ;; Use t as default so that moved files `take their markers with them'
117 "If t, moved marked files are marked if their originals were.
118 If a character, those files (marked or not) are marked with that character.")
119
120 ;;;###autoload
121 (defvar dired-keep-marker-copy ?C
122 "If t, copied files are marked if their source files were.
123 If a character, those files are always marked with that character.")
124
125 ;;;###autoload
126 (defvar dired-keep-marker-hardlink ?H
127 "If t, hard-linked files are marked if the linked-to files were.
128 If a character, those files are always marked with that character.")
129
130 ;;;###autoload
131 (defvar dired-keep-marker-symlink ?Y
132 "If t, symlinked marked files are marked if the linked-to files were.
133 If a character, those files are always marked with that character.")
134
135 ;;;###autoload
136 (defvar dired-dwim-target nil
137 "*If non-nil, dired tries to guess a default target directory:
138 If there is a dired buffer displayed in the next window, use
139 its current subdir, instead of the current subdir of this dired
140 buffer.
141
142 The target is used in the prompt for file copy, move etc.")
143
144 ;;;###autoload
145 (defvar dired-copy-preserve-time nil
146 "*If non-nil, Dired preserves the last-modified time in a file copy.
147 \(This works on only some systems.)\\<dired-mode-map>
148 Use `\\[dired-do-copy]' with a zero prefix argument to toggle its value.")
149
150 ;;; Hook variables
151
152 (defvar dired-load-hook nil
153 "Run after loading dired.
154 You can customize key bindings or load extensions with this.")
155
156 (defvar dired-mode-hook nil
157 "Run at the very end of dired-mode.")
158
159 (defvar dired-before-readin-hook nil
160 "This hook is run before a dired buffer is newly read in (created or reverted).")
161
162 (defvar dired-after-readin-hook nil
163 "After each listing of a file or directory, this hook is run
164 with the buffer narrowed to the listing.")
165 ;; Note this can't simply be run inside function dired-ls as the hook
166 ;; functions probably depend on the dired-subdir-alist to be OK.
167
168 ;;; Internal variables
169
170 (defvar dired-marker-char ?* ; the answer is 42
171 ;; so that you can write things like
172 ;; (let ((dired-marker-char ?X))
173 ;; ;; great code using X markers ...
174 ;; )
175 ;; For example, commands operating on two sets of files, A and B.
176 ;; Or marking files with digits 0-9. This could implicate
177 ;; concentric sets or an order for the marked files.
178 ;; The code depends on dynamic scoping on the marker char.
179 "In dired, character used to mark files for later commands.")
180
181 (defvar dired-del-marker ?D
182 "Character used to flag files for deletion.")
183
184 (defvar dired-shrink-to-fit
185 (if (fboundp 'baud-rate) (> (baud-rate) search-slow-speed) t)
186 "Whether dired shrinks the display buffer to fit the marked files.")
187
188 (defvar dired-flagging-regexp nil);; Last regexp used to flag files.
189
190 (defvar dired-directory nil
191 "The directory name or shell wildcard passed as argument to ls.
192 Local to each dired buffer.")
193
194 (defvar dired-actual-switches nil
195 "The actual (buffer-local) value of `dired-listing-switches'.")
196
197 (defvar dired-re-inode-size "[0-9 \t]*"
198 "Regexp for optional initial inode and file size as produced by ls' -i and -s flags.")
199
200 ;; These regexps must be tested at beginning-of-line, but are also
201 ;; used to search for next matches, so neither omitting "^" nor
202 ;; replacing "^" by "\n" (to make it slightly faster) will work.
203
204 (defvar dired-re-mark "^[^ \n]")
205 ;; "Regexp matching a marked line.
206 ;; Important: the match ends just after the marker."
207 (defvar dired-re-maybe-mark "^. ")
208 ;; Note that dired-re-inode-size allows for an arbitray amount of
209 ;; whitespace, making nested indentation in dired-nstd.el work.
210 (defvar dired-re-dir (concat dired-re-maybe-mark dired-re-inode-size "d"))
211 (defvar dired-re-sym (concat dired-re-maybe-mark dired-re-inode-size "l"))
212 (defvar dired-re-exe;; match ls permission string of an executable file
213 (mapconcat (function
214 (lambda (x)
215 (concat dired-re-maybe-mark dired-re-inode-size x)))
216 '("-[-r][-w][xs][-r][-w].[-r][-w]."
217 "-[-r][-w].[-r][-w][xs][-r][-w]."
218 "-[-r][-w].[-r][-w].[-r][-w][xst]")
219 "\\|"))
220 (defvar dired-re-dot "^.* \\.\\.?/?$") ; with -F, might end in `/'
221
222 (defvar dired-subdir-alist nil
223 "Association list of subdirectories and their buffer positions:
224
225 \((LASTDIR . LASTMARKER) ... (DEFAULT-DIRECTORY . FIRSTMARKER)).")
226
227 (defvar dired-subdir-regexp "^. \\([^ \n\r]+\\)\\(:\\)[\n\r]"
228 "Regexp matching a maybe hidden subdirectory line in ls -lR output.
229 Subexpression 1 is the subdirectory proper, no trailing colon.
230 The match starts at the beginning of the line and ends after the end
231 of the line (\\n or \\r).
232 Subexpression 2 must end right before the \\n or \\r.")
233
234
235 ;;; Macros must be defined before they are used - for the byte compiler.
236
237 ;; Returns the count if any work was done, nil otherwise.
238 (defmacro dired-mark-if (predicate msg)
239 (` (let (buffer-read-only count)
240 (save-excursion
241 (setq count 0)
242 (if (, msg) (message "Marking %ss..." (, msg)))
243 (goto-char (point-min))
244 (while (not (eobp))
245 (if (, predicate)
246 (progn
247 (delete-char 1)
248 (insert dired-marker-char)
249 (setq count (1+ count))))
250 (forward-line 1))
251 (if (, msg) (message "%s %s%s %s%s."
252 count
253 (, msg)
254 (dired-plural-s count)
255 (if (eq dired-marker-char ?\040) "un" "")
256 (if (eq dired-marker-char dired-del-marker)
257 "flagged" "marked"))))
258 (and (> count 0) count))))
259
260 (defmacro dired-mark-map (body arg &optional show-progress)
261 ;; "Macro: Perform BODY with point somewhere on each marked line
262 ;;and return a list of BODY's results.
263 ;;If no marked file could be found, execute BODY on the current line.
264 ;; If ARG is an integer, use the next ARG (or previous -ARG, if ARG<0)
265 ;; files instead of the marked files.
266 ;; In that case point is dragged along. This is so that commands on
267 ;; the next ARG (instead of the marked) files can be chained easily.
268 ;; If ARG is otherwise non-nil, use current file instead.
269 ;;If optional third arg SHOW-PROGRESS evaluates to non-nil,
270 ;; redisplay the dired buffer after each file is processed.
271 ;;No guarantee is made about the position on the marked line.
272 ;; BODY must ensure this itself if it depends on this.
273 ;;Search starts at the beginning of the buffer, thus the car of the list
274 ;; corresponds to the line nearest to the buffer's bottom. This
275 ;; is also true for (positive and negative) integer values of ARG.
276 ;;BODY should not be too long as it is expanded four times."
277 ;;
278 ;;Warning: BODY must not add new lines before point - this may cause an
279 ;;endless loop.
280 ;;This warning should not apply any longer, sk 2-Sep-1991 14:10.
281 (` (prog1
282 (let (buffer-read-only case-fold-search found results)
283 (if (, arg)
284 (if (integerp (, arg))
285 (progn;; no save-excursion, want to move point.
286 (dired-repeat-over-lines
287 (, arg)
288 (function (lambda ()
289 (if (, show-progress) (sit-for 0))
290 (setq results (cons (, body) results)))))
291 (if (< (, arg) 0)
292 (nreverse results)
293 results))
294 ;; non-nil, non-integer ARG means use current file:
295 (list (, body)))
296 (let ((regexp (dired-marker-regexp)) next-position)
297 (save-excursion
298 (goto-char (point-min))
299 ;; remember position of next marked file before BODY
300 ;; can insert lines before the just found file,
301 ;; confusing us by finding the same marked file again
302 ;; and again and...
303 (setq next-position (and (re-search-forward regexp nil t)
304 (point-marker))
305 found (not (null next-position)))
306 (while next-position
307 (goto-char next-position)
308 (if (, show-progress) (sit-for 0))
309 (setq results (cons (, body) results))
310 ;; move after last match
311 (goto-char next-position)
312 (forward-line 1)
313 (set-marker next-position nil)
314 (setq next-position (and (re-search-forward regexp nil t)
315 (point-marker)))))
316 (if found
317 results
318 (list (, body))))))
319 ;; save-excursion loses, again
320 (dired-move-to-filename))))
321
322 (defun dired-mark-get-files (&optional localp arg)
323 "Return the marked files as list of strings.
324 The list is in the same order as the buffer, that is, the car is the
325 first marked file.
326 Values returned are normally absolute pathnames.
327 Optional arg LOCALP as in `dired-get-filename'.
328 Optional second argument ARG forces to use other files. If ARG is an
329 integer, use the next ARG files. If ARG is otherwise non-nil, use
330 current file. Usually ARG comes from the current prefix arg."
331 (nreverse (save-excursion (dired-mark-map (dired-get-filename localp) arg))))
332
333
334 ;; Function dired-ls is redefinable for VMS, ange-ftp, Prospero or
335 ;; other special applications.
336
337 ;; dired-ls
338 ;; - must insert _exactly_one_line_ describing FILE if WILDCARD and
339 ;; FULL-DIRECTORY-P is nil.
340 ;; The single line of output must display FILE's name as it was
341 ;; given, namely, an absolute path name.
342 ;; - must insert exactly one line for each file if WILDCARD or
343 ;; FULL-DIRECTORY-P is t, plus one optional "total" line
344 ;; before the file lines, plus optional text after the file lines.
345 ;; Lines are delimited by "\n", so filenames containing "\n" are not
346 ;; allowed.
347 ;; File lines should display the basename, not a path name.
348 ;; - must drag point after inserted text
349 ;; - must be consistent with
350 ;; - functions dired-move-to-filename, (these two define what a file line is)
351 ;; dired-move-to-end-of-filename,
352 ;; dired-between-files, (shortcut for (not (dired-move-to-filename)))
353 ;; dired-insert-headerline
354 ;; dired-after-subdir-garbage (defines what a "total" line is)
355 ;; - variables dired-subdir-regexp
356 (defun dired-ls (file switches &optional wildcard full-directory-p)
357 ; "Insert ls output of FILE, formatted according to SWITCHES.
358 ;Optional third arg WILDCARD means treat FILE as shell wildcard.
359 ;Optional fourth arg FULL-DIRECTORY-P means file is a directory and
360 ;switches do not contain `d', so that a full listing is expected.
361 ;
362 ;Uses dired-ls-program (and shell-file-name if WILDCARD) to do the work."
363 (if wildcard
364 (let ((default-directory (file-name-directory file)))
365 (call-process shell-file-name nil t nil
366 "-c" (concat dired-ls-program " -d " switches " "
367 (file-name-nondirectory file))))
368 (call-process dired-ls-program nil t nil switches file)))
369
370 ;; The dired command
371
372 (defun dired-read-dir-and-switches (str)
373 ;; For use in interactive.
374 (reverse (list
375 (if current-prefix-arg
376 (read-string "Dired listing switches: "
377 dired-listing-switches))
378 (read-file-name (format "Dired %s(directory): " str)
379 nil default-directory nil))))
380
381 ;;;###autoload (define-key ctl-x-map "d" 'dired)
382 ;;;###autoload
383 (defun dired (dirname &optional switches)
384 "\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it.
385 With an optional prefix argument you can specify the ls SWITCHES that are used.
386 Dired displays a list of files in DIRNAME (which may also have
387 shell wildcards appended to select certain files).
388 You can move around in it with the usual commands.
389 You can flag files for deletion with \\<dired-mode-map>\\[dired-flag-file-deleted] and then delete them by
390 typing \\[dired-do-deletions].
391 Type \\[describe-mode] after entering dired for more info.
392
393 If DIRNAME is already in a dired buffer, that buffer is used without refresh."
394 ;; Cannot use (interactive "D") because of wildcards.
395 (interactive (dired-read-dir-and-switches ""))
396 (switch-to-buffer (dired-noselect dirname switches)))
397
398 ;;;###autoload (define-key ctl-x-4-map "d" 'dired-other-window)
399 ;;;###autoload
400 (defun dired-other-window (dirname &optional switches)
401 "\"Edit\" directory DIRNAME. Like `dired' but selects in another window."
402 (interactive (dired-read-dir-and-switches "in other window "))
403 (switch-to-buffer-other-window (dired-noselect dirname switches)))
404
405 ;;;###autoload (define-key ctl-x-5-map "d" 'dired-other-frame)
406 ;;;###autoload
407 (defun dired-other-frame (dirname &optional switches)
408 "\"Edit\" directory DIRNAME. Like `dired' but makes a new frame."
409 (interactive (dired-read-dir-and-switches "in other frame "))
410 (switch-to-buffer-other-frame (dired-noselect dirname switches)))
411
412 ;;;###autoload
413 (defun dired-noselect (dirname &optional switches)
414 "Like `dired' but returns the dired buffer as value, does not select it."
415 (or dirname (setq dirname default-directory))
416 ;; This loses the distinction between "/foo/*/" and "/foo/*" that
417 ;; some shells make:
418 (setq dirname (expand-file-name (directory-file-name dirname)))
419 (if (file-directory-p dirname)
420 (setq dirname (file-name-as-directory dirname)))
421 (dired-internal-noselect dirname switches))
422
423 ;; Separate function from dired-noselect for the sake of dired-vms.el.
424 (defun dired-internal-noselect (dirname &optional switches)
425 ;; If there is an existing dired buffer for DIRNAME, just leave
426 ;; buffer as it is (don't even call dired-revert).
427 ;; This saves time especially for deep trees or with ange-ftp.
428 ;; The user can type `g'easily, and it is more consistent with find-file.
429 ;; But if SWITCHES are given they are probably different from the
430 ;; buffer's old value, so call dired-sort-other, which does
431 ;; revert the buffer.
432 ;; A pity we can't possibly do "Directory has changed - refresh? "
433 ;; like find-file does...maybe in the GNU OS.
434 (let* ((buffer (dired-find-buffer-nocreate dirname))
435 ;; note that buffer already is in dired-mode, if found
436 (new-buffer-p (not buffer))
437 (old-buf (current-buffer)))
438 (or buffer
439 (let ((default-major-mode 'fundamental-mode))
440 ;; We don't want default-major-mode to run hooks and set auto-fill
441 ;; or whatever, now that dired-mode does not
442 ;; kill-all-local-variables any longer.
443 (setq buffer (create-file-buffer (directory-file-name dirname)))))
444 (set-buffer buffer)
445 (if (not new-buffer-p) ; existing buffer ...
446 (if switches ; ... but new switches
447 (dired-sort-other switches)) ; this calls dired-revert
448 ;; Else a new buffer
449 (setq default-directory (if (file-directory-p dirname)
450 dirname
451 (file-name-directory dirname)))
452 (or switches (setq switches dired-listing-switches))
453 (dired-mode dirname switches)
454 ;; default-directory and dired-actual-switches are set now
455 ;; (buffer-local), so we can call dired-readin:
456 (let ((failed t))
457 (unwind-protect
458 (progn (dired-readin dirname buffer)
459 (setq failed nil))
460 ;; dired-readin can fail if parent directories are inaccessible.
461 ;; Don't leave an empty buffer around in that case.
462 (if failed (kill-buffer buffer))))
463 ;; No need to narrow since the whole buffer contains just
464 ;; dired-readin's output, nothing else. The hook can
465 ;; successfully use dired functions (e.g. dired-get-filename)
466 ;; as the subdir-alist has been built in dired-readin.
467 (let ((buffer-read-only nil))
468 (run-hooks 'dired-after-readin-hook))
469 (goto-char (point-min))
470 (dired-initial-position dirname))
471 (set-buffer old-buf)
472 buffer))
473
474 ;; This differs from dired-buffers-for-dir in that it does not consider
475 ;; subdirs of default-directory and searches for the first match only
476 (defun dired-find-buffer-nocreate (dirname)
477 (let (found (blist (buffer-list)))
478 (while blist
479 (save-excursion
480 (set-buffer (car blist))
481 (if (and (eq major-mode 'dired-mode)
482 (equal dired-directory dirname))
483 (setq found (car blist)
484 blist nil)
485 (setq blist (cdr blist)))))
486 found))
487
488
489 ;; Read in a new dired buffer
490
491 ;; dired-readin differs from dired-insert-subdir in that it accepts
492 ;; wildcards, erases the buffer, and builds the subdir-alist anew
493 ;; (including making it buffer-local and clearing it first).
494 (defun dired-readin (dirname buffer)
495 ;; default-directory and dired-actual-switches must be buffer-local
496 ;; and initialized by now.
497 ;; Thus we can test (equal default-directory dirname) instead of
498 ;; (file-directory-p dirname) and save a filesystem transaction.
499 ;; Also, we can run this hook which may want to modify the switches
500 ;; based on default-directory, e.g. with ange-ftp to a SysV host
501 ;; where ls won't understand -Al switches.
502 (setq dirname (expand-file-name dirname))
503 (run-hooks 'dired-before-readin-hook)
504 (save-excursion
505 (message "Reading directory %s..." dirname)
506 (set-buffer buffer)
507 (let (buffer-read-only)
508 (widen)
509 (erase-buffer)
510 (dired-readin-insert dirname)
511 (dired-indent-rigidly (point-min) (point-max) 2)
512 ;; We need this to make the root dir have a header line as all
513 ;; other subdirs have:
514 (goto-char (point-min))
515 (dired-insert-headerline default-directory)
516 ;; can't run dired-after-readin-hook here, it may depend on the subdir
517 ;; alist to be OK.
518 )
519 (message "Reading directory %s...done" dirname)
520 (set-buffer-modified-p nil)
521 ;; Must first make alist buffer local and set it to nil because
522 ;; dired-build-subdir-alist will call dired-clear-alist first
523 (set (make-local-variable 'dired-subdir-alist) nil)
524 (let (case-fold-search)
525 (if (string-match "R" dired-actual-switches)
526 (dired-build-subdir-alist)
527 ;; no need to parse the buffer if listing is not recursive
528 (dired-simple-subdir-alist)))))
529
530 ;; Subroutines of dired-readin
531
532 (defun dired-readin-insert (dirname)
533 ;; Just insert listing for DIRNAME, assuming a clean buffer.
534 (let ((font-lock-mode nil))
535 (if (equal default-directory dirname);; i.e., (file-directory-p dirname)
536 (dired-ls (if (or (let (case-fold-search)
537 (string-match "R" dired-actual-switches))
538 (eq system-type 'vax-vms))
539 dirname
540 ;; On SysV derived system, symbolic links to
541 ;; directories are not resolved, while on BSD
542 ;; derived it suffices to let DIRNAME end in slash.
543 ;; We always let it end in "/." since it does no
544 ;; harm on BSD and makes Dired work on such links on
545 ;; SysV.
546 ;; Cannot do this with -R since "dir/./subdir"
547 ;; headerlines would result, utterly confusing dired.
548 (concat dirname "."))
549 dired-actual-switches nil t)
550 (if (not (file-readable-p
551 (directory-file-name (file-name-directory dirname))))
552 (error "Directory %s inaccessible or nonexistent" dirname)
553 ;; else assume it contains wildcards:
554 (dired-ls dirname dired-actual-switches t)
555 (save-excursion;; insert wildcard instead of total line:
556 (goto-char (point-min))
557 (insert "wildcard " (file-name-nondirectory dirname) "\n"))))))
558
559 (defun dired-insert-headerline (dir);; also used by dired-insert-subdir
560 ;; Insert DIR's headerline with no trailing slash, exactly like ls
561 ;; would, and put cursor where dired-build-subdir-alist puts subdir
562 ;; boundaries.
563 (save-excursion (insert " " (directory-file-name dir) ":\n")))
564
565 ;; Make the file names highlight when the mouse is on them.
566 ;; from FSF 19.30.
567 (defun dired-insert-set-properties (beg end)
568 (save-excursion
569 (goto-char beg)
570 (while (< (point) end)
571 (condition-case nil
572 (if (dired-move-to-filename)
573 (put-text-property (point)
574 (save-excursion
575 (dired-move-to-end-of-filename)
576 (point))
577 'highlight t))
578 (error nil))
579 (forward-line 1))))
580
581
582 ;; Reverting a dired buffer
583
584 (defun dired-revert (&optional arg noconfirm)
585 ;; Reread the dired buffer. Must also be called after
586 ;; dired-actual-switches have changed.
587 ;; Should not fail even on completely garbaged buffers.
588 ;; Preserves old cursor, marks/flags, hidden-p.
589 (widen) ; just in case user narrowed
590 (let ((opoint (point))
591 (ofile (dired-get-filename nil t))
592 (mark-alist nil) ; save marked files
593 (hidden-subdirs (dired-remember-hidden))
594 (old-subdir-alist (cdr (reverse dired-subdir-alist))) ; except pwd
595 case-fold-search ; we check for upper case ls flags
596 buffer-read-only)
597 (goto-char (point-min))
598 (setq mark-alist;; only after dired-remember-hidden since this unhides:
599 (dired-remember-marks (point-min) (point-max)))
600 ;; treat top level dir extra (it may contain wildcards)
601 (dired-readin dired-directory (current-buffer))
602 (let ((dired-after-readin-hook nil))
603 ;; don't run that hook for each subdir...
604 (dired-insert-old-subdirs old-subdir-alist))
605 (dired-mark-remembered mark-alist) ; mark files that were marked
606 ;; ... run the hook for the whole buffer, and only after markers
607 ;; have been reinserted (else omitting in dired-x would omit marked files)
608 (run-hooks 'dired-after-readin-hook) ; no need to narrow
609 (or (and ofile (dired-goto-file ofile)) ; move cursor to where it
610 (goto-char opoint)) ; was before
611 (dired-move-to-filename)
612 (save-excursion ; hide subdirs that were hidden
613 (mapcar (function (lambda (dir)
614 (if (dired-goto-subdir dir)
615 (dired-hide-subdir 1))))
616 hidden-subdirs)))
617 ;; outside of the let scope
618 (setq buffer-read-only t))
619
620 ;; Subroutines of dired-revert
621 ;; Some of these are also used when inserting subdirs.
622
623 (defun dired-remember-marks (beg end)
624 ;; Return alist of files and their marks, from BEG to END.
625 (if selective-display ; must unhide to make this work.
626 (let (buffer-read-only)
627 (subst-char-in-region beg end ?\r ?\n)))
628 (let (fil chr alist)
629 (save-excursion
630 (goto-char beg)
631 (while (re-search-forward dired-re-mark end t)
632 (if (setq fil (dired-get-filename nil t))
633 (setq chr (preceding-char)
634 alist (cons (cons fil chr) alist)))))
635 alist))
636
637 (defun dired-mark-remembered (alist)
638 ;; Mark all files remembered in ALIST.
639 (let (elt fil chr)
640 (while alist
641 (setq elt (car alist)
642 alist (cdr alist)
643 fil (car elt)
644 chr (cdr elt))
645 (if (dired-goto-file fil)
646 (save-excursion
647 (beginning-of-line)
648 (delete-char 1)
649 (insert chr))))))
650
651 (defun dired-remember-hidden ()
652 (let ((l dired-subdir-alist) dir result)
653 (while l
654 (setq dir (car (car l))
655 l (cdr l))
656 (if (dired-subdir-hidden-p dir)
657 (setq result (cons dir result))))
658 result))
659
660 (defun dired-insert-old-subdirs (old-subdir-alist)
661 ;; Try to insert all subdirs that were displayed before
662 (or (string-match "R" dired-actual-switches)
663 (let (elt dir)
664 (while old-subdir-alist
665 (setq elt (car old-subdir-alist)
666 old-subdir-alist (cdr old-subdir-alist)
667 dir (car elt))
668 (condition-case ()
669 (dired-insert-subdir dir)
670 (error nil))))))
671
672
673 ;; dired mode key bindings and initialization
674
675 (defvar dired-mode-map nil "Local keymap for dired-mode buffers.")
676 (if dired-mode-map
677 nil
678 ;; Force `f' rather than `e' in the mode doc:
679 (fset 'dired-advertised-find-file 'dired-find-file)
680 ;; This looks ugly when substitute-command-keys uses C-d instead d:
681 ;; (define-key dired-mode-map "\C-d" 'dired-flag-file-deleted)
682
683 (setq dired-mode-map (make-keymap))
684 (suppress-keymap dired-mode-map)
685 ;; Commands to mark certain categories of files
686 (define-key dired-mode-map "#" 'dired-flag-auto-save-files)
687 (define-key dired-mode-map "*" 'dired-mark-executables)
688 (define-key dired-mode-map "." 'dired-clean-directory)
689 (define-key dired-mode-map "/" 'dired-mark-directories)
690 (define-key dired-mode-map "@" 'dired-mark-symlinks)
691 ;; Upper case keys (except !, c, r) for operating on the marked files
692 (define-key dired-mode-map "c" 'dired-do-copy)
693 (define-key dired-mode-map "r" 'dired-do-move)
694 (define-key dired-mode-map "!" 'dired-do-shell-command)
695 (define-key dired-mode-map "B" 'dired-do-byte-compile)
696 (define-key dired-mode-map "C" 'dired-do-compress)
697 (define-key dired-mode-map "G" 'dired-do-chgrp)
698 (define-key dired-mode-map "H" 'dired-do-hardlink)
699 (define-key dired-mode-map "L" 'dired-do-load)
700 (define-key dired-mode-map "M" 'dired-do-chmod)
701 (define-key dired-mode-map "O" 'dired-do-chown)
702 (define-key dired-mode-map "P" 'dired-do-print)
703 (define-key dired-mode-map "U" 'dired-do-uncompress)
704 (define-key dired-mode-map "X" 'dired-do-delete)
705 (define-key dired-mode-map "Y" 'dired-do-symlink)
706 ;; exceptions to the upper key rule
707 (define-key dired-mode-map "D" 'dired-diff)
708 (define-key dired-mode-map "W" 'dired-why)
709 ;; Tree Dired commands
710 (define-key dired-mode-map "\M-\C-?" 'dired-unflag-all-files)
711 (define-key dired-mode-map "\M-\C-d" 'dired-tree-down)
712 (define-key dired-mode-map "\M-\C-u" 'dired-tree-up)
713 (define-key dired-mode-map "\M-\C-n" 'dired-next-subdir)
714 (define-key dired-mode-map "\M-\C-p" 'dired-prev-subdir)
715 ;; move to marked files
716 (define-key dired-mode-map "\M-{" 'dired-prev-marked-file)
717 (define-key dired-mode-map "\M-}" 'dired-next-marked-file)
718 ;; kill marked files
719 (define-key dired-mode-map "\M-k" 'dired-do-kill)
720 ;; Make all regexp commands share a `%' prefix:
721 (fset 'dired-regexp-prefix (make-sparse-keymap))
722 (define-key dired-mode-map "%" 'dired-regexp-prefix)
723 (define-key dired-mode-map "%u" 'dired-upcase)
724 (define-key dired-mode-map "%l" 'dired-downcase)
725 (define-key dired-mode-map "%d" 'dired-flag-regexp-files)
726 (define-key dired-mode-map "%m" 'dired-mark-files-regexp)
727 (define-key dired-mode-map "%r" 'dired-do-rename-regexp)
728 (define-key dired-mode-map "%c" 'dired-do-copy-regexp)
729 (define-key dired-mode-map "%H" 'dired-do-hardlink-regexp)
730 (define-key dired-mode-map "%Y" 'dired-do-symlink-regexp)
731 ;; Lower keys for commands not operating on all the marked files
732 (define-key dired-mode-map "d" 'dired-flag-file-deleted)
733 (define-key dired-mode-map "e" 'dired-find-file)
734 (define-key dired-mode-map "f" 'dired-advertised-find-file)
735 (define-key dired-mode-map "g" 'revert-buffer)
736 (define-key dired-mode-map "h" 'describe-mode)
737 (define-key dired-mode-map "i" 'dired-maybe-insert-subdir)
738 (define-key dired-mode-map "k" 'dired-kill-line-or-subdir)
739 (define-key dired-mode-map "l" 'dired-do-redisplay)
740 (define-key dired-mode-map "m" 'dired-mark-subdir-or-file)
741 (define-key dired-mode-map "n" 'dired-next-line)
742 (define-key dired-mode-map "o" 'dired-find-file-other-window)
743 (define-key dired-mode-map "p" 'dired-previous-line)
744 (define-key dired-mode-map "q" 'dired-quit)
745 (define-key dired-mode-map "s" 'dired-sort-toggle-or-edit)
746 (define-key dired-mode-map "u" 'dired-unmark-subdir-or-file)
747 (define-key dired-mode-map "v" 'dired-view-file)
748 (define-key dired-mode-map "x" 'dired-do-deletions)
749 (define-key dired-mode-map "~" 'dired-flag-backup-files)
750 (define-key dired-mode-map "\M-~" 'dired-backup-diff)
751 (define-key dired-mode-map "+" 'dired-create-directory)
752 ;; moving
753 (define-key dired-mode-map "<" 'dired-prev-dirline)
754 (define-key dired-mode-map ">" 'dired-next-dirline)
755 (define-key dired-mode-map "^" 'dired-up-directory)
756 (define-key dired-mode-map " " 'dired-next-line)
757 (define-key dired-mode-map "\C-n" 'dired-next-line)
758 (define-key dired-mode-map "\C-p" 'dired-previous-line)
759 ;; hiding
760 (define-key dired-mode-map "$" 'dired-hide-subdir)
761 (define-key dired-mode-map "=" 'dired-hide-all)
762 ;; misc
763 (define-key dired-mode-map "?" 'dired-summary)
764 (define-key dired-mode-map "\177" 'dired-backup-unflag)
765 (define-key dired-mode-map "\C-_" 'dired-undo)
766 (define-key dired-mode-map "\C-xu" 'dired-undo)
767 )
768
769 (or (equal (assq 'dired-sort-mode minor-mode-alist)
770 '(dired-sort-mode dired-sort-mode))
771 ;; Test whether this has already been done in case dired is reloaded
772 ;; There may be several elements with dired-sort-mode as car.
773 (setq minor-mode-alist
774 (cons '(dired-sort-mode dired-sort-mode)
775 ;; dired-sort-mode is nil outside dired
776 minor-mode-alist)))
777
778 ;; Dired mode is suitable only for specially formatted data.
779 (put 'dired-mode 'mode-class 'special)
780
781 (defun dired-mode (&optional dirname switches)
782 "\
783 Mode for \"editing\" directory listings.
784 In dired, you are \"editing\" a list of the files in a directory and
785 \(optionally) its subdirectories, in the format of `ls -lR'.
786 Each directory is a page: use \\[backward-page] and \\[forward-page] to move pagewise.
787 \"Editing\" means that you can run shell commands on files, visit,
788 compress, load or byte-compile them, change their file attributes
789 and insert subdirectories into the same buffer. You can \"mark\"
790 files for later commands or \"flag\" them for deletion, either file
791 by file or all files matching certain criteria.
792 You can move using the usual cursor motion commands.\\<dired-mode-map>
793 Letters no longer insert themselves. Digits are prefix arguments.
794 Instead, type \\[dired-flag-file-deleted] to flag a file for Deletion.
795 Type \\[dired-mark-subdir-or-file] to Mark a file or subdirectory for later commands.
796 Most commands operate on the marked files and use the current file
797 if no files are marked. Use a numeric prefix argument to operate on
798 the next ARG (or previous -ARG if ARG<0) files, or just `1'
799 to operate on the current file only. Prefix arguments override marks.
800 Mark-using commands display a list of failures afterwards. Type \\[dired-why] to see
801 why something went wrong.
802 Type \\[dired-unmark-subdir-or-file] to Unmark a file or all files of a subdirectory.
803 Type \\[dired-backup-unflag] to back up one line and unflag.
804 Type \\[dired-do-deletions] to eXecute the deletions requested.
805 Type \\[dired-advertised-find-file] to Find the current line's file
806 (or dired it in another buffer, if it is a directory).
807 Type \\[dired-find-file-other-window] to find file or dired directory in Other window.
808 Type \\[dired-maybe-insert-subdir] to Insert a subdirectory in this buffer.
809 Type \\[dired-do-move] to Rename a file or move the marked files to another directory.
810 Type \\[dired-do-copy] to Copy files.
811 Type \\[dired-sort-toggle-or-edit] to toggle sorting by name/date or change the ls switches.
812 Type \\[revert-buffer] to read all currently expanded directories again.
813 This retains all marks and hides subdirs again that were hidden before.
814 SPC and DEL can be used to move down and up by lines.
815
816 If dired ever gets confused, you can either type \\[revert-buffer] \
817 to read the
818 directories again, type \\[dired-do-redisplay] \
819 to relist a single or the marked files or a
820 subdirectory, or type \\[dired-build-subdir-alist] to parse the buffer
821 again for the directory tree.
822
823 Customization variables (rename this buffer and type \\[describe-variable] on each line
824 for more info):
825
826 dired-listing-switches
827 dired-trivial-filenames
828 dired-shrink-to-fit
829 dired-marker-char
830 dired-del-marker
831 dired-keep-marker-move
832 dired-keep-marker-copy
833 dired-keep-marker-hardlink
834 dired-keep-marker-symlink
835
836 Hooks (use \\[describe-variable] to see their documentation):
837
838 dired-before-readin-hook
839 dired-after-readin-hook
840 dired-mode-hook
841 dired-load-hook
842
843 Keybindings:
844 \\{dired-mode-map}"
845 ;; Not to be called interactively (e.g. dired-directory will be set
846 ;; to default-directory, which is wrong with wildcards).
847 (kill-all-local-variables)
848 (use-local-map dired-mode-map)
849 (dired-advertise) ; default-directory is already set
850 (setq major-mode 'dired-mode
851 mode-name "Dired"
852 case-fold-search nil
853 buffer-read-only t
854 selective-display t ; for subdirectory hiding
855 modeline-buffer-identification '("Dired: %17b"))
856 (set (make-local-variable 'revert-buffer-function)
857 (function dired-revert))
858 (set (make-local-variable 'page-delimiter)
859 "\n\n")
860 (set (make-local-variable 'dired-directory)
861 (or dirname default-directory))
862 (set (make-local-variable 'list-buffers-directory)
863 dired-directory)
864 (set (make-local-variable 'dired-actual-switches)
865 (or switches dired-listing-switches))
866 (make-local-variable 'dired-sort-mode)
867 (dired-sort-other dired-actual-switches t)
868 (run-hooks 'dired-mode-hook))
869
870
871 (defun dired-check-ls-l ()
872 (let (case-fold-search)
873 (or (string-match "l" dired-actual-switches)
874 (error "Dired needs -l in ls switches"))))
875
876 (defun dired-repeat-over-lines (arg function)
877 ;; This version skips non-file lines.
878 (beginning-of-line)
879 (while (and (> arg 0) (not (eobp)))
880 (setq arg (1- arg))
881 (beginning-of-line)
882 (while (and (not (eobp)) (dired-between-files)) (forward-line 1))
883 (save-excursion (funcall function))
884 (forward-line 1))
885 (while (and (< arg 0) (not (bobp)))
886 (setq arg (1+ arg))
887 (forward-line -1)
888 (while (and (not (bobp)) (dired-between-files)) (forward-line -1))
889 (beginning-of-line)
890 (save-excursion (funcall function))
891 (dired-move-to-filename))
892 (dired-move-to-filename))
893
894 (defun dired-flag-file-deleted (arg)
895 "In dired, flag the current line's file for deletion.
896 With prefix arg, repeat over several lines.
897
898 If on a subdir headerline, mark all its files except `.' and `..'."
899 (interactive "P")
900 (let ((dired-marker-char dired-del-marker))
901 (dired-mark-subdir-or-file arg)))
902
903 (defun dired-quit ()
904 "Bury the current dired buffer."
905 (interactive)
906 (bury-buffer))
907
908 (defun dired-summary ()
909 (interactive)
910 ;>> this should check the key-bindings and use substitute-command-keys if non-standard
911 (message
912 "d-elete, u-ndelete, x-punge, f-ind, o-ther window, r-ename, c-opy, h-elp"))
913
914 (defun dired-create-directory (directory)
915 "Create a directory called DIRECTORY."
916 (interactive
917 (list (read-file-name "Create directory: " (dired-current-directory))))
918 (let ((expanded (directory-file-name (expand-file-name directory))))
919 (make-directory expanded)
920 (dired-add-file expanded)
921 (dired-move-to-filename)))
922
923 (defun dired-undo ()
924 "Undo in a dired buffer.
925 This doesn't recover lost files, it is just normal undo with temporarily
926 writeable buffer. You can use it to recover marks, killed lines or subdirs.
927 In the latter case, you have to do \\[dired-build-subdir-alist] to
928 parse the buffer again."
929 (interactive)
930 (let (buffer-read-only)
931 (undo)))
932
933 (defun dired-unflag (arg)
934 "In dired, remove the current line's delete flag then move to next line.
935 Optional prefix ARG says how many lines to unflag."
936 (interactive "p")
937 (dired-repeat-over-lines arg
938 '(lambda ()
939 (let (buffer-read-only)
940 (delete-char 1)
941 (insert " ")
942 (forward-char -1)
943 nil))))
944
945 (defun dired-backup-unflag (arg)
946 "In dired, move up lines and remove deletion flag there.
947 Optional prefix ARG says how many lines to unflag; default is one line."
948 (interactive "p")
949 (dired-unflag (- arg)))
950
951 (defun dired-next-line (arg)
952 "Move down lines then position at filename.
953 Optional prefix ARG says how many lines to move; default is one line."
954 (interactive "_p")
955 (next-line arg)
956 (dired-move-to-filename))
957
958 (defun dired-previous-line (arg)
959 "Move up lines then position at filename.
960 Optional prefix ARG says how many lines to move; default is one line."
961 (interactive "_p")
962 (previous-line arg)
963 (dired-move-to-filename))
964
965 (defun dired-up-directory ()
966 "Run dired on parent directory of current directory.
967 Find the parent directory either in this buffer or another buffer.
968 Creates a buffer if necessary."
969 (interactive)
970 (let* ((dir (dired-current-directory))
971 (up (file-name-directory (directory-file-name dir))))
972 (or (dired-goto-file (directory-file-name dir))
973 (dired-goto-subdir up)
974 (progn
975 (dired up)
976 (dired-goto-file dir)))))
977
978 (defun dired-find-file ()
979 "In dired, visit the file or directory named on this line."
980 (interactive)
981 (let ((find-file-run-dired t))
982 (find-file (dired-get-filename))))
983
984 (defun dired-view-file ()
985 "In dired, examine a file in view mode, returning to dired when done.
986 When file is a directory, show it in this buffer if it is inserted;
987 otherwise, display it in another buffer."
988 (interactive)
989 (if (file-directory-p (dired-get-filename))
990 (or (dired-goto-subdir (dired-get-filename))
991 (dired (dired-get-filename)))
992 (view-file (dired-get-filename))))
993
994 (defun dired-find-file-other-window ()
995 "In dired, visit this file or directory in another window."
996 (interactive)
997 (let ((find-file-run-dired t)) ;; XEmacs
998 (find-file-other-window (dired-get-filename))))
999
1000 (defun dired-get-filename (&optional localp no-error-if-not-filep)
1001 "In dired, return name of file mentioned on this line.
1002 Value returned normally includes the directory name.
1003 Optional arg LOCALP with value `no-dir' means don't include directory
1004 name in result. A value of t means use path name relative to
1005 `default-directory', which still may contain slashes if in a subdirectory.
1006 Optional arg NO-ERROR-IF-NOT-FILEP means return nil if no filename on
1007 this line, otherwise an error occurs."
1008 (let (case-fold-search file p1 p2)
1009 (save-excursion
1010 (if (setq p1 (dired-move-to-filename (not no-error-if-not-filep)))
1011 (setq p2 (dired-move-to-end-of-filename no-error-if-not-filep))))
1012 ;; nil if no file on this line, but no-error-if-not-filep is t:
1013 (if (setq file (and p1 p2 (buffer-substring p1 p2)))
1014 ;; Check if ls quoted the names, and unquote them.
1015 ;; Using read to unquote is much faster than substituting
1016 ;; \007 (4 chars) -> ^G (1 char) etc. in a lisp loop.
1017 (cond ((string-match "b" dired-actual-switches) ; System V ls
1018 ;; This case is about 20% slower than without -b.
1019 (setq file
1020 (read
1021 (concat "\""
1022 ;; some ls -b don't escape quotes, argh!
1023 ;; This is not needed for GNU ls, though.
1024 (or (dired-string-replace-match
1025 "\\([^\\]\\)\"" file "\\1\\\\\"")
1026 file)
1027 "\""))))
1028 ;; If you do this, update dired-insert-subdir-validate too
1029 ;; ((string-match "Q" dired-actual-switches) ; GNU ls
1030 ;; (setq file (read file)))
1031 ))
1032 (if (eq localp 'no-dir)
1033 file
1034 (and file (concat (dired-current-directory localp) file)))))
1035
1036 (defun dired-move-to-filename (&optional raise-error eol)
1037 "In dired, move to first char of filename on this line.
1038 Returns position (point) or nil if no filename on this line."
1039 ;; This is the UNIX version.
1040 (or eol (setq eol (progn (end-of-line) (point))))
1041 (beginning-of-line)
1042 (if (string-match "l" dired-actual-switches)
1043 (if (re-search-forward
1044 "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)[ ]+[0-9]+"
1045 eol t)
1046 (progn
1047 (skip-chars-forward " ") ; there is one SPC after day of month
1048 (skip-chars-forward "^ " eol) ; move after time of day (or year)
1049 (skip-chars-forward " " eol) ; there is space before the file name
1050 ;; Actually, if the year instead of clock time is displayed,
1051 ;; there are (only for some ls programs?) two spaces instead
1052 ;; of one before the name.
1053 ;; If we could depend on ls inserting exactly one SPC we
1054 ;; would not bomb on names _starting_ with SPC.
1055 (point))
1056 (if raise-error
1057 (error "No file on this line")
1058 nil))
1059 ;; else ls switches don't contain -l.
1060 ;; Note that even if we make dired-move-to-filename and
1061 ;; dired-move-to-end-of-filename (and thus dired-get-filename)
1062 ;; work, all commands that gleaned information from the permission
1063 ;; bits (like dired-mark-directories) will cease to work properly.
1064 (if (eolp)
1065 (if raise-error
1066 (error "No file on this line")
1067 nil)
1068 ;; skip marker, if any
1069 (forward-char))
1070 (skip-chars-forward " ")
1071 (point)))
1072
1073 (defun dired-move-to-end-of-filename (&optional no-error)
1074 ;; Assumes point is at beginning of filename,
1075 ;; thus the rwx bit re-search-backward below will succeed in *this*
1076 ;; line if at all. So, it should be called only after
1077 ;; (dired-move-to-filename t).
1078 ;; On failure, signals an error (with non-nil NO-ERROR just returns nil).
1079 ;; This is the UNIX version.
1080 (let (opoint file-type executable symlink hidden case-fold-search used-F eol)
1081 ;; case-fold-search is nil now, so we can test for capital F:
1082 (setq used-F (string-match "F" dired-actual-switches)
1083 opoint (point)
1084 eol (save-excursion (end-of-line) (point))
1085 hidden (and selective-display
1086 (save-excursion (search-forward "\r" eol t))))
1087 (if hidden
1088 nil
1089 (save-excursion;; Find out what kind of file this is:
1090 ;; Restrict perm bits to be non-blank,
1091 ;; otherwise this matches one char to early (looking backward):
1092 ;; "l---------" (some systems make symlinks that way)
1093 ;; "----------" (plain file with zero perms)
1094 (if (re-search-backward
1095 "\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)"
1096 nil t)
1097 (setq file-type (char-after (match-beginning 1))
1098 symlink (eq file-type ?l)
1099 ;; Only with -F we need to know whether it's an executable
1100 executable (and
1101 used-F
1102 (string-match
1103 "[xst]";; execute bit set anywhere?
1104 (concat
1105 (buffer-substring (match-beginning 2)
1106 (match-end 2))
1107 (buffer-substring (match-beginning 3)
1108 (match-end 3))
1109 (buffer-substring (match-beginning 4)
1110 (match-end 4))))))
1111 (or no-error
1112 (not (string-match "l" dired-actual-switches))
1113 (error "No file on this line"))))
1114 ;; Move point to end of name:
1115 (if symlink
1116 (if (search-forward " ->" eol t)
1117 (progn
1118 (forward-char -3)
1119 (and used-F
1120 dired-ls-F-marks-symlinks
1121 (eq (preceding-char) ?@);; did ls really mark the link?
1122 (forward-char -1))))
1123 (goto-char eol);; else not a symbolic link
1124 ;; ls -lF marks dirs, sockets and executables with exactly one
1125 ;; trailing character. (Executable bits on symlinks ain't mean
1126 ;; a thing, even to ls, but we know it's not a symlink.)
1127 (and used-F
1128 ;; -F may not actually be honored, e.g. by an FTP ls in ange-ftp
1129 (let ((char (preceding-char)))
1130 (or (and (eq file-type ?d) (eq char ?/))
1131 (and executable (eq char ?*))
1132 (and (eq file-type ?s) (eq char ?=))))
1133 (forward-char -1))))
1134 (or no-error
1135 (not (eq opoint (point)))
1136 (error (if hidden
1137 (substitute-command-keys
1138 "File line is hidden, type \\[dired-hide-subdir] to unhide")
1139 "No file on this line")))
1140 (if (eq opoint (point))
1141 nil
1142 (point))))
1143
1144
1145 ;; Perhaps something could be done to handle VMS' own backups.
1146
1147 (defun dired-clean-directory (keep)
1148 "Flag numerical backups for deletion.
1149 Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest.
1150 Positive prefix arg KEEP overrides `dired-kept-versions';
1151 Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive.
1152
1153 To clear the flags on these files, you can use \\[dired-flag-backup-files]
1154 with a prefix argument."
1155 (interactive "P")
1156 (setq keep (if keep (prefix-numeric-value keep) dired-kept-versions))
1157 (let ((early-retention (if (< keep 0) (- keep) kept-old-versions))
1158 (late-retention (if (<= keep 0) dired-kept-versions keep))
1159 (file-version-assoc-list ()))
1160 (message "Cleaning numerical backups (keeping %d late, %d old)..."
1161 late-retention early-retention)
1162 ;; Look at each file.
1163 ;; If the file has numeric backup versions,
1164 ;; put on file-version-assoc-list an element of the form
1165 ;; (FILENAME . VERSION-NUMBER-LIST)
1166 (dired-map-dired-file-lines (function dired-collect-file-versions))
1167 ;; Sort each VERSION-NUMBER-LIST,
1168 ;; and remove the versions not to be deleted.
1169 (let ((fval file-version-assoc-list))
1170 (while fval
1171 (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<)))
1172 (v-count (length sorted-v-list)))
1173 (if (> v-count (+ early-retention late-retention))
1174 (rplacd (nthcdr early-retention sorted-v-list)
1175 (nthcdr (- v-count late-retention)
1176 sorted-v-list)))
1177 (rplacd (car fval)
1178 (cdr sorted-v-list)))
1179 (setq fval (cdr fval))))
1180 ;; Look at each file. If it is a numeric backup file,
1181 ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion.
1182 (dired-map-dired-file-lines (function dired-trample-file-versions))
1183 (message "Cleaning numerical backups...done")))
1184
1185 ;;; Subroutines of dired-clean-directory.
1186
1187 (defun dired-map-dired-file-lines (fun)
1188 ;; Perform FUN with point at the end of each non-directory line.
1189 ;; FUN takes one argument, the filename (complete pathname).
1190 (dired-check-ls-l)
1191 (save-excursion
1192 (let (file buffer-read-only)
1193 (goto-char (point-min))
1194 (while (not (eobp))
1195 (save-excursion
1196 (and (not (looking-at dired-re-dir))
1197 (not (eolp))
1198 (setq file (dired-get-filename nil t)) ; nil on non-file
1199 (progn (end-of-line)
1200 (funcall fun file))))
1201 (forward-line 1)))))
1202
1203 (defun dired-collect-file-versions (fn)
1204 ;; "If it looks like file FN has versions, return a list of the versions.
1205 ;;That is a list of strings which are file names.
1206 ;;The caller may want to flag some of these files for deletion."
1207 (let* ((base-versions
1208 (concat (file-name-nondirectory fn) ".~"))
1209 (bv-length (length base-versions))
1210 (possibilities (file-name-all-completions
1211 base-versions
1212 (file-name-directory fn)))
1213 (versions (mapcar 'backup-extract-version possibilities)))
1214 (if versions
1215 (setq file-version-assoc-list (cons (cons fn versions)
1216 file-version-assoc-list)))))
1217
1218 (defun dired-trample-file-versions (fn)
1219 (let* ((start-vn (string-match "\\.~[0-9]+~$" fn))
1220 base-version-list)
1221 (and start-vn
1222 (setq base-version-list ; there was a base version to which
1223 (assoc (substring fn 0 start-vn) ; this looks like a
1224 file-version-assoc-list)) ; subversion
1225 (not (memq (string-to-int (substring fn (+ 2 start-vn)))
1226 base-version-list)) ; this one doesn't make the cut
1227 (progn (beginning-of-line)
1228 (delete-char 1)
1229 (insert dired-del-marker)))))
1230
1231
1232 ;; Keeping Dired buffers in sync with the filesystem and with each other
1233
1234 (defvar dired-buffers nil
1235 ;; Enlarged by dired-advertise
1236 ;; Queried by function dired-buffers-for-dir. When this detects a
1237 ;; killed buffer, it is removed from this list.
1238 "Alist of directories and their associated dired buffers.")
1239
1240 (defun dired-buffers-for-dir (dir)
1241 ;; Return a list of buffers that dired DIR (top level or in-situ subdir).
1242 ;; The list is in reverse order of buffer creation, most recent last.
1243 ;; As a side effect, killed dired buffers for DIR are removed from
1244 ;; dired-buffers.
1245 (setq dir (file-name-as-directory dir))
1246 (let ((alist dired-buffers) result elt)
1247 (while alist
1248 (setq elt (car alist))
1249 (if (dired-in-this-tree dir (car elt))
1250 (let ((buf (cdr elt)))
1251 (if (buffer-name buf)
1252 (if (assoc dir (save-excursion
1253 (set-buffer buf)
1254 dired-subdir-alist))
1255 (setq result (cons buf result)))
1256 ;; else buffer is killed - clean up:
1257 (setq dired-buffers (delq elt dired-buffers)))))
1258 (setq alist (cdr alist)))
1259 result))
1260
1261 (defun dired-advertise ()
1262 ;;"Advertise in variable `dired-buffers' that we dired `default-directory'."
1263 ;; With wildcards we actually advertise too much.
1264 (if (memq (current-buffer) (dired-buffers-for-dir default-directory))
1265 t ; we have already advertised ourselves
1266 (setq dired-buffers
1267 (cons (cons default-directory (current-buffer))
1268 dired-buffers))))
1269
1270 (defun dired-unadvertise (dir)
1271 ;; Remove DIR from the buffer alist in variable dired-buffers.
1272 ;; This has the effect of removing any buffer whose main directory is DIR.
1273 ;; It does not affect buffers in which DIR is a subdir.
1274 ;; Removing is also done as a side-effect in dired-buffer-for-dir.
1275 (setq dired-buffers
1276 (delq (assoc dir dired-buffers) dired-buffers)))
1277
1278 (defun dired-fun-in-all-buffers (directory fun &rest args)
1279 ;; In all buffers dired'ing DIRECTORY, run FUN with ARGS.
1280 ;; Return list of buffers where FUN succeeded (i.e., returned non-nil).
1281 (let ((buf-list (dired-buffers-for-dir directory))
1282 (obuf (current-buffer))
1283 buf success-list)
1284 (while buf-list
1285 (setq buf (car buf-list)
1286 buf-list (cdr buf-list))
1287 (unwind-protect
1288 (progn
1289 (set-buffer buf)
1290 (if (apply fun args)
1291 (setq success-list (cons (buffer-name buf) success-list))))
1292 (set-buffer obuf)))
1293 success-list))
1294
1295 (defun dired-add-file (filename &optional marker-char)
1296 (dired-fun-in-all-buffers
1297 (file-name-directory filename)
1298 (function dired-add-entry) filename marker-char))
1299
1300 (defun dired-add-entry (filename &optional marker-char)
1301 ;; Add a new entry for FILENAME, optionally marking it
1302 ;; with MARKER-CHAR (a character, else dired-marker-char is used).
1303 ;; Note that this adds the entry `out of order' if files sorted by
1304 ;; time, etc.
1305 ;; At least this version inserts in the right subdirectory (if present).
1306 ;; And it skips "." or ".." (see `dired-trivial-filenames').
1307 ;; Hidden subdirs are exposed if a file is added there.
1308 (setq filename (directory-file-name filename))
1309 ;; Entry is always for files, even if they happen to also be directories
1310 (let ((opoint (point))
1311 (cur-dir (dired-current-directory))
1312 (directory (file-name-directory filename))
1313 reason)
1314 (setq filename (file-name-nondirectory filename)
1315 reason
1316 (catch 'not-found
1317 (if (string= directory cur-dir)
1318 (progn
1319 (if (dired-subdir-hidden-p cur-dir)
1320 (dired-unhide-subdir))
1321 ;; We are already where we should be, except when
1322 ;; point is before the subdir line or its total line.
1323 (let ((p (dired-after-subdir-garbage cur-dir)))
1324 (if (< (point) p)
1325 (goto-char p))))
1326 ;; else try to find correct place to insert
1327 (if (dired-goto-subdir directory)
1328 (progn;; unhide if necessary
1329 (if (looking-at "\r");; point is at end of subdir line
1330 (dired-unhide-subdir))
1331 ;; found - skip subdir and `total' line
1332 ;; and uninteresting files like . and ..
1333 ;; This better not moves into the next subdir!
1334 (dired-goto-next-nontrivial-file))
1335 ;; not found
1336 (throw 'not-found "Subdir not found")))
1337 ;; found and point is at The Right Place:
1338 (let (buffer-read-only)
1339 (beginning-of-line)
1340 (dired-add-entry-do-indentation marker-char)
1341 (dired-ls (dired-make-absolute filename directory);; don't expand `.' !
1342 (concat dired-actual-switches "d"))
1343 (forward-line -1)
1344 ;; We want to have the non-directory part, only:
1345 (let* ((beg (dired-move-to-filename t)) ; error for strange output
1346 (end (dired-move-to-end-of-filename)))
1347 (setq filename (buffer-substring beg end))
1348 (delete-region beg end)
1349 (insert (file-name-nondirectory filename)))
1350 (if dired-after-readin-hook;; the subdir-alist is not affected...
1351 (save-excursion;; ...so we can run it right now:
1352 (save-restriction
1353 (beginning-of-line)
1354 (narrow-to-region (point) (save-excursion
1355 (forward-line 1) (point)))
1356 (run-hooks 'dired-after-readin-hook))))
1357 (dired-move-to-filename))
1358 ;; return nil if all went well
1359 nil))
1360 (if reason ; don't move away on failure
1361 (goto-char opoint))
1362 (not reason))) ; return t on succes, nil else
1363
1364 ;; This is a separate function for the sake of nested dired format.
1365 (defun dired-add-entry-do-indentation (marker-char)
1366 ;; two spaces or a marker plus a space:
1367 (insert (if marker-char
1368 (if (integerp marker-char) marker-char dired-marker-char)
1369 ?\040)
1370 ?\040))
1371
1372 (defun dired-after-subdir-garbage (dir)
1373 ;; Return pos of first file line of DIR, skipping header and total
1374 ;; or wildcard lines.
1375 ;; Important: never moves into the next subdir.
1376 ;; DIR is assumed to be unhidden.
1377 ;; Will probably be redefined for VMS etc.
1378 (save-excursion
1379 (or (dired-goto-subdir dir) (error "This cannot happen"))
1380 (forward-line 1)
1381 (while (and (not (eolp)) ; don't cross subdir boundary
1382 (not (dired-move-to-filename)))
1383 (forward-line 1))
1384 (point)))
1385
1386 (defun dired-remove-file (file)
1387 (dired-fun-in-all-buffers
1388 (file-name-directory file) (function dired-remove-entry) file))
1389
1390 (defun dired-remove-entry (file)
1391 (save-excursion
1392 (and (dired-goto-file file)
1393 (let (buffer-read-only)
1394 (delete-region (progn (beginning-of-line) (point))
1395 (save-excursion (forward-line 1) (point)))))))
1396
1397 (defun dired-relist-file (file)
1398 (dired-fun-in-all-buffers (file-name-directory file)
1399 (function dired-relist-entry) file))
1400
1401 (defun dired-relist-entry (file)
1402 ;; Relist the line for FILE, or just add it if it did not exist.
1403 ;; FILE must be an absolute pathname.
1404 (let (buffer-read-only marker)
1405 ;; If cursor is already on FILE's line delete-region will cause
1406 ;; save-excursion to fail because of floating makers,
1407 ;; moving point to beginning of line. Sigh.
1408 (save-excursion
1409 (and (dired-goto-file file)
1410 (delete-region (progn (beginning-of-line)
1411 (setq marker (following-char))
1412 (point))
1413 (save-excursion (forward-line 1) (point))))
1414 (setq file (directory-file-name file))
1415 (dired-add-entry file (if (eq ?\040 marker) nil marker)))))
1416
1417 (defun dired-update-file-line (file)
1418 ;; Delete the current line, and insert an entry for FILE.
1419 ;; If FILE is nil, then just delete the current line.
1420 ;; Keeps any marks that may be present in column one (doing this
1421 ;; here is faster than with dired-add-entry's optional arg).
1422 ;; Does not update other dired buffers. Use dired-relist-entry for that.
1423 (beginning-of-line)
1424 (let ((char (following-char)) (opoint (point)))
1425 (delete-region (point) (progn (forward-line 1) (point)))
1426 (if file
1427 (progn
1428 (dired-add-entry file)
1429 ;; Replace space by old marker without moving point.
1430 ;; Faster than goto+insdel inside a save-excursion?
1431 (subst-char-in-region opoint (1+ opoint) ?\040 char))))
1432 (dired-move-to-filename))
1433
1434
1435 ;; Running subprocesses, checking and logging of their errors.
1436
1437 (defvar dired-log-buf "*Dired log*")
1438
1439 (defun dired-why ()
1440 "Pop up a buffer with error log output from Dired.
1441 A group of errors from a single command ends with a formfeed.
1442 Thus, use \\[backward-page] to find the beginning of a group of errors."
1443 (interactive)
1444 (let ((obuf (current-buffer)))
1445 (pop-to-buffer dired-log-buf)
1446 (goto-char (point-max))
1447 (recenter -1)
1448 (switch-to-buffer-other-window obuf)))
1449
1450 (defun dired-log (log &rest args)
1451 ;; Log a message or the contents of a buffer.
1452 ;; If LOG is a string and there are more args, it is formatted with
1453 ;; those ARGS. Usually the LOG string ends with a \n.
1454 ;; End each bunch of errors with (dired-log t): this inserts
1455 ;; current time and buffer, and a \f (formfeed).
1456 (let ((obuf (current-buffer)))
1457 (unwind-protect ; want to move point
1458 (progn
1459 (set-buffer (get-buffer-create dired-log-buf))
1460 (goto-char (point-max))
1461 (let (buffer-read-only)
1462 (cond ((stringp log)
1463 (insert (if args
1464 (apply (function format) log args)
1465 log)))
1466 ((bufferp log)
1467 (insert-buffer log))
1468 ((eq t log)
1469 (insert "\n\t" (current-time-string)
1470 "\tBuffer `" (buffer-name obuf) "'\n\f\n")))))
1471 (set-buffer obuf))))
1472
1473 (defun dired-log-summary (log &rest args)
1474 ;; Log a summary describing a bunch of errors.
1475 (apply (function dired-log) (concat "\n" log) args)
1476 (dired-log t))
1477
1478 ;; In Emacs 19 this will return program's exit status.
1479 ;; This is a separate function so that ange-ftp can redefine it.
1480 (defun dired-call-process (program discard &rest arguments)
1481 ; "Run PROGRAM with output to current buffer unless DISCARD is t.
1482 ;Remaining arguments are strings passed as command arguments to PROGRAM."
1483 (apply 'call-process program nil (not discard) nil arguments))
1484
1485 (defun dired-check-process-checker (exit-status)
1486 ;; In Emacs 19, EXIT-STATUS comes from (dired-)call-process
1487 ;; Then this function should return (/= 0 exit-status)
1488 ;; In Emacs 18 the exit status is not accessible, so we
1489 ;; do the following which is not always correct as some compress
1490 ;; programs are verbose by default or otherwise braindamaged
1491 (if (and dired-emacs-19-p exit-status)
1492 (/= 0 exit-status);; #### install (does it work in Emacs 19?)
1493 (/= 0 (buffer-size))) ; run in program's output buffer
1494 ;; If have you one of those compress programs, you might
1495 ;; want to redefine this function to look closer at compress' output.
1496 ;; This is why it is a separate function.
1497 )
1498
1499 (defun dired-check-process (msg program &rest arguments)
1500 ; "Display MSG while running PROGRAM, and check for output.
1501 ;Remaining arguments are strings passed as command arguments to PROGRAM.
1502 ; On error as determined by dired-check-process-checker, insert output
1503 ; in a log buffer and return the offending ARGUMENTS or PROGRAM.
1504 ; Caller can cons up a list of failed args.
1505 ;Else returns nil for success."
1506 (let (err-buffer err (dir default-directory))
1507 (message "%s..." msg)
1508 (save-excursion
1509 ;; Get a clean buffer for error output:
1510 (setq err-buffer (get-buffer-create " *dired-check-process output*"))
1511 (set-buffer err-buffer)
1512 (erase-buffer)
1513 (setq default-directory dir ; caller's default-directory
1514 err (dired-check-process-checker
1515 (apply (function dired-call-process) program nil arguments)))
1516 (if err
1517 (progn
1518 (dired-log (concat program " " (prin1-to-string arguments) "\n"))
1519 (dired-log err-buffer)
1520 (or arguments program t))
1521 (kill-buffer err-buffer)
1522 (message "%s...done" msg)
1523 nil))))
1524
1525 ;;; 7K
1526 ;;;###begin dired-cmd.el
1527 ;; Diffing and compressing
1528
1529 (defun dired-diff (file &optional switches)
1530 "Compare file at point with file FILE using `diff'.
1531 FILE defaults to the file at the mark.
1532 The prompted-for file is the first file given to `diff'.
1533 Prefix arg lets you edit the diff switches. See the command `diff'."
1534 (interactive
1535 (let ((default (if (mark)
1536 (save-excursion (goto-char (mark))
1537 (dired-get-filename t t)))))
1538 (list (read-file-name (format "Diff %s with: %s"
1539 (dired-get-filename t)
1540 (if default
1541 (concat "(default " default ") ")
1542 ""))
1543 (dired-current-directory) default t)
1544 (if (fboundp 'diff-read-switches)
1545 (diff-read-switches "Options for diff: ")))))
1546 (if switches ; Emacs 19's diff has but two
1547 (diff file (dired-get-filename t) switches) ; args (yet ;-)
1548 (diff file (dired-get-filename t))))
1549
1550 (defun dired-backup-diff (&optional switches)
1551 "Diff this file with its backup file or vice versa.
1552 Uses the latest backup, if there are several numerical backups.
1553 If this file is a backup, diff it with its original.
1554 The backup file is the first file given to `diff'.
1555 Prefix arg lets you edit the diff switches. See the command `diff'."
1556 (interactive (list (if (fboundp 'diff-read-switches)
1557 (diff-read-switches "Diff with switches: "))))
1558 (let (bak ori (file (dired-get-filename)))
1559 (if (backup-file-name-p file)
1560 (setq bak file
1561 ori (file-name-sans-versions file))
1562 (setq bak (or (latest-backup-file file)
1563 (error "No backup found for %s" file))
1564 ori file))
1565 (if switches
1566 (diff bak ori switches)
1567 (diff bak ori))))
1568
1569 ;;#### install (move this function into files.el)
1570 (defun latest-backup-file (fn) ; actually belongs into files.el
1571 "Return the latest existing backup of FILE, or nil."
1572 ;; First try simple backup, then the highest numbered of the
1573 ;; numbered backups.
1574 ;; Ignore the value of version-control because we look for existing
1575 ;; backups, which maybe were made earlier or by another user with
1576 ;; a different value of version-control.
1577 (setq fn (expand-file-name fn))
1578 (or
1579 (let ((bak (make-backup-file-name fn)))
1580 (if (file-exists-p bak) bak))
1581 (let* ((dir (file-name-directory fn))
1582 (base-versions (concat (file-name-nondirectory fn) ".~"))
1583 (bv-length (length base-versions)))
1584 (concat dir
1585 (car (sort
1586 (file-name-all-completions base-versions dir)
1587 ;; bv-length is a fluid var for backup-extract-version:
1588 (function
1589 (lambda (fn1 fn2)
1590 (> (backup-extract-version fn1)
1591 (backup-extract-version fn2))))))))))
1592
1593 ;; This is a separate function for the sake of ange-ftp.el
1594 (defun dired-compress-make-compressed-filename (from-file &optional reverse)
1595 ;; "Converts a filename FROM-FILE to the filename of the associated
1596 ;; compressed file. With an optional argument REVERSE, the reverse
1597 ;; conversion is done."
1598
1599 (if reverse
1600
1601 ;; uncompress...
1602 ;; return `nil' if no match found -- better than nothing
1603 (let (case-fold-search ; case-sensitive search
1604 (string
1605 (concat "\\.\\(g?z\\|" (regexp-quote dired-gzip-file-extension)
1606 "$\\|Z\\)$")))
1607
1608 (and (string-match string from-file)
1609 (substring from-file 0 (match-beginning 0))))
1610
1611 ;; compress...
1612 ;; note: it could be that `gz' is not the proper extension for gzip
1613 (concat from-file
1614 (if dired-use-gzip-instead-of-compress
1615 dired-gzip-file-extension ".Z"))))
1616
1617
1618 (defun dired-compress ()
1619 ;; Compress current file. Return nil for success, offending filename else.
1620 (dired-check-ls-l)
1621 (let* (buffer-read-only
1622 (from-file (dired-get-filename))
1623 (to-file (dired-compress-make-compressed-filename from-file)))
1624 (cond ((save-excursion (beginning-of-line)
1625 (looking-at dired-re-sym))
1626 (dired-log (concat "Attempt to compress a symbolic link:\n"
1627 from-file))
1628 (dired-make-relative from-file))
1629 (
1630
1631 (if dired-use-gzip-instead-of-compress
1632 ;; gzip (GNU zip)
1633 ;; use `-q' (quiet) switch for gzip in case GZIP environment
1634 ;; variable contains `--verbose' - lrd - Feb 18, 1993
1635 (dired-check-process (concat "Gzip'ing " from-file)
1636 "gzip" "--quiet" "--force" "--suffix"
1637 dired-gzip-file-extension from-file)
1638
1639 (dired-check-process (concat "Compressing " from-file)
1640 "compress" "-f" from-file))
1641 ;; errors from the process are already logged by dired-check-process
1642 (dired-make-relative from-file))
1643 (t
1644 (dired-update-file-line to-file)
1645 nil))))
1646
1647 (defun dired-uncompress ()
1648 ;; Uncompress current file. Return nil for success, offending filename else.
1649 (let* (buffer-read-only
1650 (from-file (dired-get-filename))
1651 (to-file (dired-compress-make-compressed-filename from-file t)))
1652 (if
1653 (if dired-use-gzip-instead-of-compress
1654 ;; gzip (GNU zip)
1655 ;; use `-q' (quiet) switch for gzip in case GZIP environment
1656 ;; variable contains `--verbose' - lrd - Feb 18, 1993
1657 (dired-check-process (concat "Gunzip'ing " from-file)
1658 "gzip" "--decompress" "--quiet" "--suffix"
1659 dired-gzip-file-extension from-file)
1660
1661 (dired-check-process (concat "Uncompressing " from-file)
1662 "uncompress" from-file))
1663
1664 (dired-make-relative from-file)
1665 (dired-update-file-line to-file)
1666 nil)))
1667
1668 (defun dired-mark-map-check (fun arg op-symbol &optional show-progress)
1669 ; "Map FUN over marked files (with second ARG like in dired-mark-map)
1670 ; and display failures.
1671
1672 ; FUN takes zero args. It returns non-nil (the offending object, e.g.
1673 ; the short form of the filename) for a failure and probably logs a
1674 ; detailed error explanation using function `dired-log'.
1675
1676 ; OP-SYMBOL is a symbol describing the operation performed (e.g.
1677 ; `compress'). It is used with `dired-mark-pop-up' to prompt the user
1678 ; (e.g. with `Compress * [2 files]? ') and to display errors (e.g.
1679 ; `Failed to compress 1 of 2 files - type W to see why ("foo")')
1680
1681 ; SHOW-PROGRESS if non-nil means redisplay dired after each file."
1682 (if (dired-mark-confirm op-symbol arg)
1683 (let* ((total-list;; all of FUN's return values
1684 (dired-mark-map (funcall fun) arg show-progress))
1685 (total (length total-list))
1686 (failures (delq nil total-list))
1687 (count (length failures)))
1688 (if (not failures)
1689 (message "%s: %d file%s."
1690 (capitalize (symbol-name op-symbol))
1691 total (dired-plural-s total))
1692 (message "Failed to %s %d of %d file%s - type W to see why %s"
1693 (symbol-name op-symbol) count total (dired-plural-s total)
1694 ;; this gives a short list of failed files in parens
1695 ;; which may be sufficient for the user even
1696 ;; without typing `W' for the process' diagnostics
1697 failures)
1698 ;; end this bunch of errors:
1699 (dired-log-summary
1700 "Failed to %s %d of %d file%s"
1701 (symbol-name op-symbol) count total (dired-plural-s total))))))
1702
1703 (defun dired-do-compress (&optional arg)
1704 "Compress marked (or next ARG) files.
1705 Type \\[dired-do-uncompress] to uncompress again."
1706 (interactive "P")
1707 (dired-mark-map-check (function dired-compress) arg 'compress t))
1708
1709 (defun dired-do-uncompress (&optional arg)
1710 "Uncompress marked (or next ARG) files."
1711 (interactive "P")
1712 (dired-mark-map-check (function dired-uncompress) arg 'uncompress t))
1713
1714 ;; Commands for Emacs Lisp files - load and byte compile
1715
1716 (defun dired-byte-compile ()
1717 ;; Return nil for success, offending file name else.
1718 (let* ((filename (dired-get-filename))
1719 (elc-file
1720 (if (eq system-type 'vax-vms)
1721 (concat (substring filename 0 (string-match ";" filename)) "c")
1722 (concat filename "c")))
1723 buffer-read-only failure)
1724 (condition-case err
1725 (save-excursion (byte-compile-file filename))
1726 (error
1727 (setq failure err)))
1728 (if failure
1729 (progn
1730 (dired-log "Byte compile error for %s:\n%s\n" filename failure)
1731 (dired-make-relative filename))
1732 (dired-remove-file elc-file)
1733 (forward-line) ; insert .elc after its .el file
1734 (dired-add-file elc-file)
1735 nil)))
1736
1737 (defun dired-do-byte-compile (&optional arg)
1738 "Byte compile marked (or next ARG) Emacs lisp files."
1739 (interactive "P")
1740 (dired-mark-map-check (function dired-byte-compile) arg 'byte-compile t))
1741
1742 (defun dired-load ()
1743 ;; Return nil for success, offending file name else.
1744 (let ((file (dired-get-filename)) failure)
1745 (condition-case err
1746 (load file nil nil t)
1747 (error (setq failure err)))
1748 (if (not failure)
1749 nil
1750 (dired-log "Load error for %s:\n%s\n" file failure)
1751 (dired-make-relative file))))
1752
1753 (defun dired-do-load (&optional arg)
1754 "Load the marked (or next ARG) Emacs lisp files."
1755 (interactive "P")
1756 (dired-mark-map-check (function dired-load) arg 'load t))
1757
1758 (defun dired-do-chxxx (attribute-name program op-symbol arg)
1759 ;; Change file attributes (mode, group, owner) of marked files and
1760 ;; refresh their file lines.
1761 ;; ATTRIBUTE-NAME is a string describing the attribute to the user.
1762 ;; PROGRAM is the program used to change the attribute.
1763 ;; OP-SYMBOL is the type of operation (for use in dired-mark-pop-up).
1764 ;; ARG describes which files to use, like in dired-mark-get-files.
1765 (let* ((files (dired-mark-get-files t arg))
1766 (new-attribute
1767 (dired-mark-read-string
1768 (concat "Change " attribute-name " of %s to: ")
1769 nil op-symbol arg files))
1770 (operation (concat program " " new-attribute))
1771 (failure (apply (function dired-check-process)
1772 operation program new-attribute
1773 files)))
1774 (dired-do-redisplay arg);; moves point if ARG is an integer
1775 (if failure
1776 (dired-log-summary
1777 (message "%s: error - type W to see why." operation)))))
1778
1779 (defun dired-do-chmod (&optional arg)
1780 "Change the mode of the marked (or next ARG) files.
1781 This calls chmod, thus symbolic modes like `g+w' are allowed."
1782 (interactive "P")
1783 (dired-do-chxxx "Mode" "chmod" 'chmod arg))
1784
1785 (defun dired-do-chgrp (&optional arg)
1786 "Change the group of the marked (or next ARG) files."
1787 (interactive "P")
1788 (dired-do-chxxx "Group" "chgrp" 'chgrp arg))
1789
1790 (defun dired-do-chown (&optional arg)
1791 "Change the owner of the marked (or next ARG) files."
1792 (interactive "P")
1793 (dired-do-chxxx "Owner" dired-chown-program 'chown arg))
1794
1795 ;;;###end dired-cmd.el
1796
1797
1798 ;; Deleting files
1799
1800 ;; #### called dired-do-flagged-delete in FSF
1801 (defun dired-do-deletions (&optional nomessage)
1802 "In dired, delete the files flagged for deletion.
1803 If NOMESSAGE is non-nil, we don't display any message
1804 if there are no flagged files."
1805 (interactive)
1806 (let* ((dired-marker-char dired-del-marker)
1807 (regexp (dired-marker-regexp))
1808 case-fold-search)
1809 (if (save-excursion (goto-char (point-min))
1810 (re-search-forward regexp nil t))
1811 (dired-internal-do-deletions
1812 ;; this can't move point since ARG is nil
1813 (dired-mark-map (cons (dired-get-filename) (point))
1814 nil)
1815 nil)
1816 (or nomessage
1817 (message "(No deletions requested)")))))
1818
1819 (defun dired-do-delete (&optional arg)
1820 "Delete all marked (or next ARG) files."
1821 ;; This is more consistent with the file marking feature than
1822 ;; dired-do-deletions.
1823 (interactive "P")
1824 (dired-internal-do-deletions
1825 ;; this may move point if ARG is an integer
1826 (dired-mark-map (cons (dired-get-filename) (point))
1827 arg)
1828 arg))
1829
1830 (defvar dired-deletion-confirmer 'yes-or-no-p) ; or y-or-n-p?
1831
1832 (defun dired-internal-do-deletions (l arg)
1833 ;; L is an alist of files to delete, with their buffer positions.
1834 ;; ARG is the prefix arg.
1835 ;; Filenames are absolute (VMS needs this for logical search paths).
1836 ;; (car L) *must* be the *last* (bottommost) file in the dired buffer.
1837 ;; That way as changes are made in the buffer they do not shift the
1838 ;; lines still to be changed, so the (point) values in L stay valid.
1839 ;; Also, for subdirs in natural order, a subdir's files are deleted
1840 ;; before the subdir itself - the other way around would not work.
1841 (let ((files (mapcar (function car) l))
1842 (count (length l))
1843 (succ 0))
1844 ;; canonicalize file list for pop up
1845 (setq files (nreverse (mapcar (function dired-make-relative) files)))
1846 (if (dired-mark-pop-up
1847 " *Deletions*" 'delete files dired-deletion-confirmer
1848 (format "Delete %s " (dired-mark-prompt arg files)))
1849 (save-excursion
1850 (let (failures);; files better be in reverse order for this loop!
1851 (while l
1852 (goto-char (cdr (car l)))
1853 (let (buffer-read-only)
1854 (condition-case err
1855 (let ((fn (car (car l))))
1856 ;; This test is equivalent to
1857 ;; (and (file-directory-p fn) (not (file-symlink-p fn)))
1858 ;; but more efficient
1859 (if (eq t (car (file-attributes fn)))
1860 (remove-directory fn)
1861 (delete-file fn))
1862 ;; if we get here, removing worked
1863 (setq succ (1+ succ))
1864 (message "%s of %s deletions" succ count)
1865 (delete-region (progn (beginning-of-line) (point))
1866 (progn (forward-line 1) (point)))
1867 (dired-clean-up-after-deletion fn))
1868 (error;; catch errors from failed deletions
1869 (dired-log "%s\n" err)
1870 (setq failures (cons (car (car l)) failures)))))
1871 (setq l (cdr l)))
1872 (if (not failures)
1873 (message "%d deletion%s done" count (dired-plural-s count))
1874 (dired-log-summary
1875 (message "%d of %d deletion%s failed: %s"
1876 (length failures) count
1877 (dired-plural-s count)
1878 (prin1-to-string failures))))))
1879 (message "(No deletions performed)")))
1880 (dired-move-to-filename))
1881
1882 ;; This is a separate function for the sake of dired-x.el.
1883 (defun dired-clean-up-after-deletion (fn)
1884 ;; Clean up after a deleted file or directory FN.
1885 (save-excursion (and (dired-goto-subdir fn)
1886 (dired-kill-subdir))))
1887
1888
1889 (defun dired-replace-in-string (regexp newtext string)
1890 ;; Replace REGEXP with NEWTEXT everywhere in STRING and return result.
1891 ;; NEWTEXT is taken literally---no \\DIGIT escapes will be recognized.
1892 (let ((result "") (start 0) mb me)
1893 (while (string-match regexp string start)
1894 (setq mb (match-beginning 0)
1895 me (match-end 0)
1896 result (concat result (substring string start mb) newtext)
1897 start me))
1898 (concat result (substring string start))))
1899
1900 (defun dired-next-dirline (arg &optional opoint)
1901 "Goto ARG'th next directory file line."
1902 (interactive "_p")
1903 (dired-check-ls-l)
1904 (or opoint (setq opoint (point)))
1905 (if (if (> arg 0)
1906 (re-search-forward dired-re-dir nil t arg)
1907 (beginning-of-line)
1908 (re-search-backward dired-re-dir nil t (- arg)))
1909 (dired-move-to-filename) ; user may type `i' or `f'
1910 (goto-char opoint)
1911 (error "No more subdirectories")))
1912
1913 (defun dired-prev-dirline (arg)
1914 "Goto ARG'th previous directory file line."
1915 (interactive "_p")
1916 (dired-next-dirline (- arg)))
1917
1918 (defun dired-unflag-all-files (flag &optional arg)
1919 "Remove a specific or all flags from every file.
1920 With an arg, queries for each marked file.
1921 Type \\[help-command] at that time for help."
1922 (interactive "sRemove flag: (default: all flags) \nP")
1923 (let ((count 0)
1924 (re (if (zerop (length flag)) dired-re-mark
1925 (concat "^" (regexp-quote flag)))))
1926 (save-excursion
1927 (let (buffer-read-only case-fold-search query
1928 (help-form "\
1929 Type SPC or `y' to unflag one file, DEL or `n' to skip to next,
1930 `!' to unflag all remaining files with no more questions."))
1931 (goto-char (point-min))
1932 (while (re-search-forward re nil t)
1933 (if (or (not arg)
1934 (dired-query 'query "Unflag file `%s' ? "
1935 (dired-get-filename t)))
1936 (progn (delete-char -1) (insert " ") (setq count (1+ count))))
1937 (forward-line 1))))
1938 (message "%s" (format "Flags removed: %d %s" count flag) )))
1939
1940 ;; pop ups and user input for file marking
1941
1942 (defun dired-marker-regexp ()
1943 (concat "^" (regexp-quote (char-to-string dired-marker-char))))
1944
1945 (defun dired-plural-s (count)
1946 (if (= 1 count) "" "s"))
1947
1948 (defun dired-mark-prompt (arg files)
1949 ;; Return a string for use in a prompt, either the current file
1950 ;; name, or the marker and a count of marked files.
1951 (let ((count (length files)))
1952 (if (= count 1)
1953 (car files)
1954 ;; more than 1 file:
1955 (if (integerp arg)
1956 ;; abs(arg) = count
1957 ;; Perhaps this is nicer, but it also takes more screen space:
1958 ;;(format "[%s %d files]" (if (> arg 0) "next" "previous")
1959 ;; count)
1960 (format "[next %d files]" arg)
1961 (format "%c [%d files]" dired-marker-char count)))))
1962
1963 (defvar dired-query-alist
1964 '((?\y . y) (?\040 . y) ; `y' or SPC means accept once
1965 (?n . n) (?\177 . n) ; `n' or DEL skips once
1966 (?! . yes) ; `!' accepts rest
1967 (?q. no) (?\e . no) ; `q' or ESC skips rest
1968 ;; None of these keys quit - use C-g for that.
1969 ))
1970
1971 (defun dired-query (qs-var qs-prompt &rest qs-args)
1972 ;; Query user and return nil or t.
1973 ;; Store answer in symbol VAR (which must initially be bound to nil).
1974 ;; Format PROMPT with ARGS.
1975 ;; Binding variable help-form will help the user who types C-h.
1976 (let* ((char (symbol-value qs-var))
1977 (action (cdr (assoc char dired-query-alist))))
1978 (cond ((eq 'yes action)
1979 t) ; accept, and don't ask again
1980 ((eq 'no action)
1981 nil) ; skip, and don't ask again
1982 (t;; no lasting effects from last time we asked - ask now
1983 (let ((qprompt (concat qs-prompt
1984 (if help-form
1985 (format " [Type yn!q or %s] "
1986 (key-description
1987 (char-to-string help-char)))
1988 " [Type y, n, q or !] ")))
1989 result elt)
1990 ;; Actually it looks nicer without cursor-in-echo-area - you can
1991 ;; look at the dired buffer instead of at the prompt to decide.
1992 (apply 'message qprompt qs-args)
1993 (setq char (set qs-var (read-char)))
1994 (while (not (setq elt (assoc char dired-query-alist)))
1995 (message "Invalid char - type %c for help." help-char)
1996 (ding)
1997 (sit-for 1)
1998 (apply 'message qprompt qs-args)
1999 (setq char (set qs-var (read-char))))
2000 (memq (cdr elt) '(t y yes)))))))
2001
2002 (defun dired-pop-to-buffer (buf)
2003 ;; Pop up buffer BUF.
2004 ;; If dired-shrink-to-fit is t, make its window fit its contents.
2005 (if (not dired-shrink-to-fit)
2006 (pop-to-buffer (get-buffer-create buf))
2007 ;; let window shrink to fit:
2008 (let ((window (selected-window))
2009 target-lines w2)
2010 (cond ;; if split-window-threshold is enabled, use the largest window
2011 ((and (> (window-height (setq w2 (get-largest-window)))
2012 split-height-threshold)
2013 (= (screen-width) (window-width w2)))
2014 (setq window w2))
2015 ;; if the least-recently-used window is big enough, use it
2016 ((and (> (window-height (setq w2 (get-lru-window)))
2017 (* 2 window-min-height))
2018 (= (screen-width) (window-width w2)))
2019 (setq window w2)))
2020 (save-excursion
2021 (set-buffer buf)
2022 (goto-char (point-max))
2023 (skip-chars-backward "\n\r\t ")
2024 (setq target-lines (count-lines (point-min) (point))))
2025 (if (<= (window-height window) (* 2 window-min-height))
2026 ;; At this point, every window on the screen is too small to split.
2027 (setq w2 (display-buffer buf))
2028 (setq w2 (split-window window
2029 (max window-min-height
2030 (- (window-height window)
2031 (1+ (max window-min-height target-lines)))))))
2032 (set-window-buffer w2 buf)
2033 (if (< (1- (window-height w2)) target-lines)
2034 (progn
2035 (select-window w2)
2036 (enlarge-window (- target-lines (1- (window-height w2))))))
2037 (set-window-start w2 1)
2038 )))
2039
2040 (defvar dired-no-confirm nil
2041 ;; "If non-nil, list of symbols for commands dired should not confirm.
2042 ;;It can be a sublist of
2043 ;;
2044 ;; '(byte-compile chgrp chmod chown compress copy delete hardlink load
2045 ;; move print shell symlink uncompress)"
2046 )
2047
2048 (defun dired-mark-confirm (op-symbol arg)
2049 ;; Request confirmation from the user that the operation described
2050 ;; by OP-SYMBOL is to be performed on the marked files.
2051 ;; Confirmation consists in a y-or-n question with a file list
2052 ;; pop-up unless OP-SYMBOL is a member of `dired-no-confirm'.
2053 ;; The files used are determined by ARG (like in dired-mark-get-files).
2054 (or (memq op-symbol dired-no-confirm)
2055 (let ((files (dired-mark-get-files t arg)))
2056 (dired-mark-pop-up nil op-symbol files (function y-or-n-p)
2057 (concat (capitalize (symbol-name op-symbol)) " "
2058 (dired-mark-prompt arg files) "? ")))))
2059
2060 (defun dired-mark-pop-up (bufname op-symbol files function &rest args)
2061 ;;"Args BUFNAME OP-SYMBOL FILES FUNCTION &rest ARGS.
2062 ;;Return FUNCTION's result on ARGS after popping up a window (in a buffer
2063 ;;named BUFNAME, nil gives \" *Marked Files*\") showing the marked
2064 ;;files. Uses function `dired-pop-to-buffer' to do that.
2065 ;; FUNCTION should not manipulate files.
2066 ;; It should only read input (an argument or confirmation).
2067 ;;The window is not shown if there is just one file or
2068 ;; OP-SYMBOL is a member of the list in `dired-no-confirm'.
2069 ;;FILES is the list of marked files."
2070 (or bufname (setq bufname " *Marked Files*"))
2071 (if (or (memq op-symbol dired-no-confirm)
2072 (= (length files) 1))
2073 (apply function args)
2074 (save-excursion
2075 (set-buffer (get-buffer-create bufname))
2076 (erase-buffer)
2077 (dired-format-columns-of-files files))
2078 (save-window-excursion
2079 (dired-pop-to-buffer bufname)
2080 (apply function args))))
2081
2082 (defun dired-format-columns-of-files (files)
2083 ;; Files should be in forward order for this loop.
2084 ;; i.e., (car files) = first file in buffer.
2085 ;; Returns the number of lines used.
2086 (let* ((maxlen (+ 2 (apply 'max (mapcar 'length files))))
2087 (width (- (window-width (selected-window)) 2))
2088 (columns (max 1 (/ width maxlen)))
2089 (nfiles (length files))
2090 (rows (+ (/ nfiles columns)
2091 (if (zerop (% nfiles columns)) 0 1)))
2092 (i 0)
2093 (j 0))
2094 (setq files (nconc (copy-sequence files) ; fill up with empty fns
2095 (make-list (- (* columns rows) nfiles) "")))
2096 (setcdr (nthcdr (1- (length files)) files) files) ; make circular
2097 (while (< j rows)
2098 (while (< i columns)
2099 (indent-to (* i maxlen))
2100 (insert (car files))
2101 (setq files (nthcdr rows files)
2102 i (1+ i)))
2103 (insert "\n")
2104 (setq i 0
2105 j (1+ j)
2106 files (cdr files)))
2107 rows))
2108
2109 ;; Read arguments for a mark command of type OP-SYMBOL,
2110 ;; perhaps popping up the list of marked files.
2111 ;; ARG is the prefix arg and indicates whether the files came from
2112 ;; marks (ARG=nil) or a repeat factor (integerp ARG).
2113 ;; If the current file was used, the list has but one element and ARG
2114 ;; does not matter. (It is non-nil, non-integer in that case, namely '(4)).
2115
2116 (defun dired-mark-read-string (prompt initial op-symbol arg files)
2117 ;; PROMPT for a string, with INITIAL input.
2118 ;; Other args are used to give user feedback and pop-up:
2119 ;; OP-SYMBOL of command, prefix ARG, marked FILES.
2120 (dired-mark-pop-up
2121 nil op-symbol files
2122 (function read-string)
2123 (format prompt (dired-mark-prompt arg files)) initial))
2124
2125 (defun dired-mark-read-file-name (prompt dir op-symbol arg files)
2126 (dired-mark-pop-up
2127 nil op-symbol files
2128 (function read-file-name)
2129 (format prompt (dired-mark-prompt arg files)) dir))
2130
2131 (defun dired-mark-file (arg)
2132 "In dired, mark the current line's file for later commands.
2133 With arg, repeat over several lines.
2134 Use \\[dired-unflag-all-files] to remove all flags."
2135 (interactive "p")
2136 (let (buffer-read-only)
2137 (dired-repeat-over-lines
2138 arg
2139 (function (lambda () (delete-char 1) (insert dired-marker-char))))))
2140
2141 (defun dired-next-marked-file (arg &optional wrap opoint)
2142 "Move to the next marked file, wrapping around the end of the buffer."
2143 (interactive "_p\np")
2144 (or opoint (setq opoint (point)));; return to where interactively started
2145 (if (if (> arg 0)
2146 (re-search-forward dired-re-mark nil t arg)
2147 (beginning-of-line)
2148 (re-search-backward dired-re-mark nil t (- arg)))
2149 (dired-move-to-filename)
2150 (if (null wrap)
2151 (progn
2152 (goto-char opoint)
2153 (error "No next marked file"))
2154 (message "(Wraparound for next marked file)")
2155 (goto-char (if (> arg 0) (point-min) (point-max)))
2156 (dired-next-marked-file arg nil opoint))))
2157
2158 (defun dired-prev-marked-file (arg &optional wrap)
2159 "Move to the previous marked file, wrapping around the end of the buffer."
2160 (interactive "_p\np")
2161 (dired-next-marked-file (- arg) wrap))
2162
2163 (defun dired-file-marker (file)
2164 ;; Return FILE's marker, or nil if unmarked.
2165 (save-excursion
2166 (and (dired-goto-file file)
2167 (progn
2168 (beginning-of-line)
2169 (if (not (equal ?\040 (following-char)))
2170 (following-char))))))
2171
2172 (defun dired-read-regexp (prompt &optional initial)
2173 ;; This is an extra function so that gmhist can redefine it.
2174 (setq dired-flagging-regexp
2175 (read-string prompt (or initial dired-flagging-regexp))))
2176
2177 (defun dired-mark-files-regexp (regexp &optional marker-char)
2178 "Mark all files matching REGEXP for use in later commands.
2179 A prefix argument means to unmark them instead.
2180 `.' and `..' are never marked.
2181
2182 REGEXP is an Emacs regexp, not a shell wildcard. Thus, use `\\.o$' for
2183 object files--just `.o' will mark more than you might think."
2184 (interactive
2185 (list (dired-read-regexp (concat (if current-prefix-arg "Unmark" "Mark")
2186 " files (regexp): "))
2187 (if current-prefix-arg ?\040)))
2188 (let ((dired-marker-char (or marker-char dired-marker-char)))
2189 (dired-mark-if
2190 (and (not (looking-at dired-re-dot))
2191 (not (eolp)) ; empty line
2192 (let ((fn (dired-get-filename nil t)))
2193 (and fn (string-match regexp (file-name-nondirectory fn)))))
2194 "matching file")))
2195
2196 (defun dired-flag-regexp-files (regexp)
2197 "In dired, flag all files containing the specified REGEXP for deletion.
2198 The match is against the non-directory part of the filename. Use `^'
2199 and `$' to anchor matches. Exclude subdirs by hiding them.
2200 `.' and `..' are never flagged."
2201 (interactive (list (dired-read-regexp "Flag for deletion (regexp): ")))
2202 (dired-mark-files-regexp regexp dired-del-marker))
2203
2204 (defun dired-mark-symlinks (unflag-p)
2205 "Mark all symbolic links.
2206 With prefix argument, unflag all those files."
2207 (interactive "P")
2208 (dired-check-ls-l)
2209 (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char)))
2210 (dired-mark-if (looking-at dired-re-sym) "symbolic link")))
2211
2212 (defun dired-mark-directories (unflag-p)
2213 "Mark all directory file lines except `.' and `..'.
2214 With prefix argument, unflag all those files."
2215 (interactive "P")
2216 (dired-check-ls-l)
2217 (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char)))
2218 (dired-mark-if (and (looking-at dired-re-dir)
2219 (not (looking-at dired-re-dot)))
2220 "directory file")))
2221
2222 (defun dired-mark-executables (unflag-p)
2223 "Mark all executable files.
2224 With prefix argument, unflag all those files."
2225 (interactive "P")
2226 (dired-check-ls-l)
2227 (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char)))
2228 (dired-mark-if (looking-at dired-re-exe) "executable file")))
2229
2230 ;; dired-x.el has a dired-mark-sexp interactive command: mark
2231 ;; files for which PREDICATE returns non-nil.
2232
2233 (defun dired-flag-auto-save-files (&optional unflag-p)
2234 "Flag for deletion files whose names suggest they are auto save files.
2235 A prefix argument says to unflag those files instead."
2236 (interactive "P")
2237 (dired-check-ls-l)
2238 (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker)))
2239 (dired-mark-if
2240 (and (not (looking-at dired-re-dir))
2241 (let ((fn (dired-get-filename t t)))
2242 (if fn (auto-save-file-name-p
2243 (file-name-nondirectory fn)))))
2244 "auto save file")))
2245
2246 (defun dired-flag-backup-files (&optional unflag-p)
2247 "Flag all backup files (names ending with `~') for deletion.
2248 With prefix argument, unflag these files."
2249 (interactive "P")
2250 (dired-check-ls-l)
2251 (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker)))
2252 (dired-mark-if
2253 (and (not (looking-at dired-re-dir))
2254 (let ((fn (dired-get-filename t t)))
2255 (if fn (backup-file-name-p fn))))
2256 "backup file")))
2257
2258
2259 ;;; Shell commands
2260 ;;#### install (move this function into simple.el)
2261 (defun shell-quote (filename) ; actually belongs into simple.el
2262 "Quote a file name for inferior shell (see variable shell-file-name)."
2263 ;; Quote everything except POSIX filename characters.
2264 ;; This should be safe enough even for really wierd shells.
2265 (let ((result "") (start 0) end)
2266 (while (string-match "[^---0-9a-zA-Z_./]" filename start)
2267 (setq end (match-beginning 0)
2268 result (concat result (substring filename start end)
2269 "\\" (substring filename end (1+ end)))
2270 start (1+ end)))
2271 (concat result (substring filename start))))
2272
2273 (defun dired-read-shell-command (prompt arg files)
2274 ;; "Read a dired shell command prompting with PROMPT (using read-string).
2275 ;;ARG is the prefix arg and may be used to indicate in the prompt which
2276 ;; files are affected.
2277 ;;This is an extra function so that you can redefine it, e.g., to use gmhist."
2278 (dired-mark-pop-up
2279 nil 'shell files
2280 (function read-string) (format prompt (dired-mark-prompt arg files))))
2281
2282 ;; The in-background argument is only needed in Emacs 18 where
2283 ;; shell-command doesn't understand an appended ampersand `&'.
2284 (defun dired-do-shell-command (&optional arg in-background)
2285 "Run a shell command on the marked files.
2286 If there is output, it goes to a separate buffer.
2287 The list of marked files is appended to the command string unless asterisks
2288 `*' indicate the place(s) where the list should go.
2289 If no files are marked or a specific numeric prefix arg is given, uses
2290 next ARG files. As always, a raw arg (\\[universal-argument]) means the current file.
2291 The prompt mentions the file(s) or the marker, as appropriate.
2292 With a zero argument, run command on each marked file separately: `cmd *
2293 foo' results in `cmd F1 foo; ...; cmd Fn foo'.
2294 No automatic redisplay is attempted, as the file names may have
2295 changed. Type \\[dired-do-redisplay] to redisplay the marked files.
2296 The shell command has the top level directory as working directory, so
2297 output files usually are created there instead of in a subdir."
2298 ;;Functions dired-run-shell-command and dired-shell-stuff-it do the
2299 ;;actual work and can be redefined for customization.
2300 (interactive "P")
2301 (let* ((on-each (equal arg 0))
2302 (prompt (concat (if in-background "& on " "! on ")
2303 (if on-each "each " "")
2304 "%s: "))
2305 (file-list (dired-mark-get-files t (if on-each nil arg)))
2306 ;; Want to give feedback whether this file or marked files are used:
2307 (command (dired-read-shell-command
2308 prompt (if on-each nil arg) file-list))
2309 (result
2310 (dired-shell-stuff-it command file-list on-each arg)))
2311 ;; execute the shell command
2312 (dired-run-shell-command result in-background)))
2313
2314 ;; Might use {,} for bash or csh:
2315 (defvar dired-mark-prefix ""
2316 "Prepended to marked files in dired shell commands.")
2317 (defvar dired-mark-postfix ""
2318 "Appended to marked files in dired shell commands.")
2319 (defvar dired-mark-separator " "
2320 "Separates marked files in dired shell commands.")
2321
2322 (defun dired-shell-stuff-it (command file-list on-each &optional raw-arg)
2323 ;; "Make up a shell command line from COMMAND and FILE-LIST.
2324 ;; If ON-EACH is t, COMMAND should be applied to each file, else
2325 ;; simply concat all files and apply COMMAND to this.
2326 ;; FILE-LIST's elements will be quoted for the shell."
2327 ;; Might be redefined for smarter things and could then use RAW-ARG
2328 ;; (coming from interactive P and currently ignored) to decide what to do.
2329 ;; Smart would be a way to access basename or extension of file names.
2330 ;; See dired-trns.el for an approach to this.
2331 ;; Bug: There is no way to quote a *
2332 ;; On the other hand, you can never accidentally get a * into your cmd.
2333 (let ((stuff-it
2334 (if (string-match "\\*" command)
2335 (function (lambda (x)
2336 (dired-replace-in-string "\\*" x command)))
2337 (function (lambda (x) (concat command " " x))))))
2338 (if on-each
2339 (mapconcat stuff-it (mapcar (function shell-quote) file-list) ";")
2340 (let ((fns (mapconcat (function shell-quote)
2341 file-list dired-mark-separator)))
2342 (if (> (length file-list) 1)
2343 (setq fns (concat dired-mark-prefix fns dired-mark-postfix)))
2344 (funcall stuff-it fns)))))
2345
2346 ;; This is an extra function so that it can be redefined by ange-ftp.
2347 (defun dired-run-shell-command (command &optional in-background)
2348 (if (and in-background (not (string-match "&[ \t]*$" command)))
2349 (setq command (concat command " &")))
2350 (shell-command command))
2351
2352 (defun dired-do-print (&optional arg)
2353 "Print the marked (or next ARG) files.
2354 Uses the shell command coming from variables `lpr-command' and
2355 `lpr-switches' as default."
2356 (interactive "P")
2357 (or (listp lpr-switches)
2358 (error "lpr-switches must be a *list* of strings"))
2359 (let* ((file-list (dired-mark-get-files t arg))
2360 (switches (mapconcat (function identity) lpr-switches " "))
2361 (command (dired-mark-read-string
2362 "Print %s with: "
2363 (concat lpr-command " " switches)
2364 'print arg file-list)))
2365 (dired-run-shell-command (dired-shell-stuff-it command file-list nil))))
2366
2367
2368 ;;; 10K
2369 ;;;###begin dired-cp.el
2370 ;;; Copy, move/rename, making hard and symbolic links
2371
2372 (defvar dired-backup-if-overwrite nil
2373 "*Non-nil if Dired should ask about making backups before overwriting files.
2374 Special value 'always suppresses confirmation.")
2375
2376 (defun dired-handle-overwrite (to)
2377 ;; Save old version of a to be overwritten file TO.
2378 ;; `overwrite-confirmed' and `overwrite-backup-query' are fluid vars
2379 ;; from dired-create-files.
2380 (if (and dired-backup-if-overwrite
2381 overwrite-confirmed
2382 (or (eq 'always dired-backup-if-overwrite)
2383 (dired-query 'overwrite-backup-query
2384 (format "Make backup for existing file `%s'? " to))))
2385 (let ((backup (car (find-backup-file-name to))))
2386 (rename-file to backup 0) ; confirm overwrite of old backup
2387 (dired-relist-entry backup))))
2388
2389 (defun dired-copy-file (from to ok-flag)
2390 (dired-handle-overwrite to)
2391 (copy-file from to ok-flag dired-copy-preserve-time))
2392
2393 (defun dired-rename-file (from to ok-flag)
2394 (dired-handle-overwrite to)
2395 (rename-file from to ok-flag) ; error is caught in -create-files
2396 ;; Silently rename the visited file of any buffer visiting this file.
2397 (and (get-file-buffer from)
2398 (save-excursion
2399 (set-buffer (get-file-buffer from))
2400 (let ((modflag (buffer-modified-p)))
2401 (set-visited-file-name to) ; kills write-file-hooks
2402 (set-buffer-modified-p modflag))))
2403 (dired-remove-file from)
2404 ;; See if it's an inserted subdir, and rename that, too.
2405 (dired-rename-subdir from to))
2406
2407 (defun dired-rename-subdir (from-dir to-dir)
2408 (setq from-dir (file-name-as-directory from-dir)
2409 to-dir (file-name-as-directory to-dir))
2410 (dired-fun-in-all-buffers from-dir
2411 (function dired-rename-subdir-1) from-dir to-dir)
2412 ;; Update visited file name of all affected buffers
2413 (let ((blist (buffer-list)))
2414 (while blist
2415 (save-excursion
2416 (set-buffer (car blist))
2417 (if (and buffer-file-name
2418 (dired-in-this-tree buffer-file-name from-dir))
2419 (let ((modflag (buffer-modified-p))
2420 (to-file (dired-replace-in-string
2421 (concat "^" (regexp-quote from-dir))
2422 to-dir
2423 buffer-file-name)))
2424 (set-visited-file-name to-file)
2425 (set-buffer-modified-p modflag))))
2426 (setq blist (cdr blist)))))
2427
2428 (defun dired-rename-subdir-1 (dir to)
2429 ;; Rename DIR to TO in headerlines and dired-subdir-alist, if DIR or
2430 ;; one of its subdirectories is expanded in this buffer.
2431 (let ((alist dired-subdir-alist)
2432 (elt nil))
2433 (while alist
2434 (setq elt (car alist)
2435 alist (cdr alist))
2436 (if (dired-in-this-tree (car elt) dir)
2437 ;; ELT's subdir is affected by the rename
2438 (dired-rename-subdir-2 elt dir to)))
2439 (if (equal dir default-directory)
2440 ;; if top level directory was renamed, lots of things have to be
2441 ;; updated:
2442 (progn
2443 (dired-unadvertise dir) ; we no longer dired DIR...
2444 (setq default-directory to
2445 dired-directory (expand-file-name;; this is correct
2446 ;; with and without wildcards
2447 (file-name-nondirectory dired-directory)
2448 to))
2449 (let ((new-name (file-name-nondirectory
2450 (directory-file-name dired-directory))))
2451 ;; try to rename buffer, but just leave old name if new
2452 ;; name would already exist (don't try appending "<%d>")
2453 (or (get-buffer new-name)
2454 (rename-buffer new-name)))
2455 ;; ... we dired TO now:
2456 (dired-advertise)))))
2457
2458 (defun dired-rename-subdir-2 (elt dir to)
2459 ;; Update the headerline and dired-subdir-alist element of directory
2460 ;; described by alist-element ELT to reflect the moving of DIR to TO.
2461 ;; Thus, ELT describes either DIR itself or a subdir of DIR.
2462
2463 ;; Bug: If TO is not longer part of the same dired tree as DIR was,
2464 ;; updating the headerline is actually not the right thing---it
2465 ;; should be removed in that case and a completely new entry be
2466 ;; added for TO. Actually, removing and adding anew would always be
2467 ;; the right (but slow) way of doing it.
2468
2469 ;; The consequences are pretty harmless though (no updates since
2470 ;; dired-buffers-for-dir will not suspect it to be in this dired
2471 ;; buffer).
2472
2473 (save-excursion
2474 (let ((regexp (regexp-quote (directory-file-name dir)))
2475 (newtext (directory-file-name to))
2476 buffer-read-only)
2477 (goto-char (dired-get-subdir-min elt))
2478 ;; Update subdir headerline in buffer
2479 (if (not (looking-at dired-subdir-regexp))
2480 (error "%s not found where expected - dired-subdir-alist broken?"
2481 dir)
2482 (goto-char (match-beginning 1))
2483 (if (re-search-forward regexp (match-end 1) t)
2484 (replace-match newtext t t)
2485 (error "Expected to find `%s' in headerline of %s" dir (car elt))))
2486 ;; Update buffer-local dired-subdir-alist
2487 (setcar elt
2488 (dired-normalize-subdir
2489 (dired-replace-in-string regexp newtext (car elt)))))))
2490
2491 ;; Cloning replace-match to work on strings instead of in buffer:
2492 ;; The FIXEDCASE parameter of replace-match is not implemented.
2493 (defun dired-string-replace-match (regexp string newtext
2494 &optional literal global)
2495 "Replace first match of REGEXP in STRING with NEWTEXT.
2496 If it does not match, nil is returned instead of the new string.
2497 Optional arg LITERAL means to take NEWTEXT literally.
2498 Optional arg GLOBAL means to replace all matches."
2499 (if global
2500 (let ((result "") (start 0) mb me)
2501 (while (string-match regexp string start)
2502 (setq mb (match-beginning 0)
2503 me (match-end 0)
2504 result (concat result
2505 (substring string start mb)
2506 (if literal
2507 newtext
2508 (dired-expand-newtext string newtext)))
2509 start me))
2510 (if mb ; matched at least once
2511 (concat result (substring string start))
2512 nil))
2513 ;; not GLOBAL
2514 (if (not (string-match regexp string 0))
2515 nil
2516 (concat (substring string 0 (match-beginning 0))
2517 (if literal newtext (dired-expand-newtext string newtext))
2518 (substring string (match-end 0))))))
2519
2520 (defun dired-expand-newtext (string newtext)
2521 ;; Expand \& and \1..\9 (referring to STRING) in NEWTEXT, using match data.
2522 ;; Note that in Emacs 18 match data are clipped to current buffer
2523 ;; size...so the buffer should better not be smaller than STRING.
2524 (let ((pos 0)
2525 (len (length newtext))
2526 (expanded-newtext ""))
2527 (while (< pos len)
2528 (setq expanded-newtext
2529 (concat expanded-newtext
2530 (let ((c (aref newtext pos)))
2531 (if (= ?\\ c)
2532 (cond ((= ?\& (setq c
2533 (aref newtext
2534 (setq pos (1+ pos)))))
2535 (substring string
2536 (match-beginning 0)
2537 (match-end 0)))
2538 ((and (>= c ?1) (<= c ?9))
2539 ;; return empty string if N'th
2540 ;; sub-regexp did not match:
2541 (let ((n (- c ?0)))
2542 (if (match-beginning n)
2543 (substring string
2544 (match-beginning n)
2545 (match-end n))
2546 "")))
2547 (t
2548 (char-to-string c)))
2549 (char-to-string c)))))
2550 (setq pos (1+ pos)))
2551 expanded-newtext))
2552
2553 ;; The basic function for half a dozen variations on cp/mv/ln/ln -s.
2554 (defun dired-create-files (file-creator operation fn-list name-constructor
2555 &optional marker-char)
2556
2557 ;; Create a new file for each from a list of existing files. The user
2558 ;; is queried, dired buffers are updated, and at the end a success or
2559 ;; failure message is displayed
2560
2561 ;; FILE-CREATOR must accept three args: oldfile newfile ok-if-already-exists
2562
2563 ;; It is called for each file and must create newfile, the entry of
2564 ;; which will be added. The user will be queried if the file already
2565 ;; exists. If oldfile is removed by FILE-CREATOR (i.e, it is a
2566 ;; rename), it is FILE-CREATOR's responsibility to update dired
2567 ;; buffers. FILE-CREATOR must abort by signalling a file-error if it
2568 ;; could not create newfile. The error is caught and logged.
2569
2570 ;; OPERATION (a capitalized string, e.g. `Copy') describes the
2571 ;; operation performed. It is used for error logging.
2572
2573 ;; FN-LIST is the list of files to copy (full absolute pathnames).
2574
2575 ;; NAME-CONSTRUCTOR returns a newfile for every oldfile, or nil to
2576 ;; skip. If it skips files for other reasons than a direct user
2577 ;; query, it is supposed to tell why (using dired-log).
2578
2579 ;; Optional MARKER-CHAR is a character with which to mark every
2580 ;; newfile's entry, or t to use the current marker character if the
2581 ;; oldfile was marked.
2582
2583 (let (failures skipped (success-count 0) (total (length fn-list)))
2584 (let (to overwrite-query
2585 overwrite-backup-query) ; for dired-handle-overwrite
2586 (mapcar
2587 (function
2588 (lambda (from)
2589 (setq to (funcall name-constructor from))
2590 (if (equal to from)
2591 (progn
2592 (setq to nil)
2593 (dired-log "Cannot %s to same file: %s\n"
2594 (downcase operation) from)))
2595 (if (not to)
2596 (setq skipped (cons (dired-make-relative from) skipped))
2597 (let* ((overwrite (file-exists-p to))
2598 (overwrite-confirmed ; for dired-handle-overwrite
2599 (and overwrite
2600 (let ((help-form '(format "\
2601 Type SPC or `y' to overwrite file `%s',
2602 DEL or `n' to skip to next,
2603 ESC or `q' to not overwrite any of the remaining files,
2604 `!' to overwrite all remaining files with no more questions." to)))
2605 (dired-query 'overwrite-query
2606 "Overwrite `%s'?" to))))
2607 ;; must determine if FROM is marked before file-creator
2608 ;; gets a chance to delete it (in case of a move).
2609 (actual-marker-char
2610 (cond ((integerp marker-char) marker-char)
2611 (marker-char (dired-file-marker from)) ; slow
2612 (t nil))))
2613 (condition-case err
2614 (progn
2615 (funcall file-creator from to overwrite-confirmed)
2616 (if overwrite
2617 ;; If we get here, file-creator hasn't been aborted
2618 ;; and the old entry (if any) has to be deleted
2619 ;; before adding the new entry.
2620 (dired-remove-file to))
2621 (setq success-count (1+ success-count))
2622 (message "%s: %d of %d" operation success-count total)
2623 (dired-add-file to actual-marker-char))
2624 (file-error ; FILE-CREATOR aborted
2625 (progn
2626 (setq failures (cons (dired-make-relative from) failures))
2627 (dired-log "%s `%s' to `%s' failed:\n%s\n"
2628 operation from to err))))))))
2629 fn-list))
2630 (cond
2631 (failures
2632 (dired-log-summary
2633 (message "%s failed for %d of %d file%s %s"
2634 operation (length failures) total
2635 (dired-plural-s total) failures)))
2636 (skipped
2637 (dired-log-summary
2638 (message "%s: %d of %d file%s skipped %s"
2639 operation (length skipped) total
2640 (dired-plural-s total) skipped)))
2641 (t
2642 (message "%s: %s file%s."
2643 operation success-count (dired-plural-s success-count)))))
2644 (dired-move-to-filename))
2645
2646 (defun dired-do-create-files (op-symbol file-creator operation arg
2647 &optional marker-char op1
2648 how-to)
2649 ;; Create a new file for each marked file.
2650 ;; Prompts user for target, which is a directory in which to create
2651 ;; the new files. Target may be a plain file if only one marked
2652 ;; file exists.
2653 ;; OP-SYMBOL is the symbol for the operation. Function `dired-mark-pop-up'
2654 ;; will determine wether pop-ups are appropriate for this OP-SYMBOL.
2655 ;; FILE-CREATOR and OPERATION as in dired-create-files.
2656 ;; ARG as in dired-mark-get-files.
2657 ;; Optional arg OP1 is an alternate form for OPERATION if there is
2658 ;; only one file.
2659 ;; Optional arg MARKER-CHAR as in dired-create-files.
2660 ;; Optional arg HOW-TO determines how to treat target:
2661 ;; If HOW-TO is not given (or nil), and target is a directory, the
2662 ;; file(s) are created inside the target directory. If target
2663 ;; is not a directory, there must be exactly one marked file,
2664 ;; else error.
2665 ;; If HOW-TO is t, then target is not modified. There must be
2666 ;; exactly one marked file, else error.
2667 ;; Else HOW-TO is assumed to be a function of one argument, target,
2668 ;; that looks at target and returns a value for the into-dir
2669 ;; variable. The function dired-into-dir-with-symlinks is provided
2670 ;; for the case (common when creating symlinks) that symbolic
2671 ;; links to directories are not to be considered as directories
2672 ;; (as file-directory-p would if HOW-TO had been nil).
2673 (or op1 (setq op1 operation))
2674 (let* ((fn-list (dired-mark-get-files nil arg))
2675 (fn-count (length fn-list))
2676 (target (expand-file-name
2677 (dired-mark-read-file-name
2678 (concat (if (= 1 fn-count) op1 operation) " %s to: ")
2679 (dired-dwim-target-directory)
2680 op-symbol arg (mapcar (function dired-make-relative) fn-list))))
2681 (into-dir (cond ((null how-to) (file-directory-p target))
2682 ((eq how-to t) nil)
2683 (t (funcall how-to target)))))
2684 (if (and (> fn-count 1)
2685 (not into-dir))
2686 (error "Marked %s: target must be a directory: %s" operation target))
2687 ;; rename-file bombs when moving directories unless we do this:
2688 (or into-dir (setq target (directory-file-name target)))
2689 (dired-create-files
2690 file-creator operation fn-list
2691 (if into-dir ; target is a directory
2692 ;; This function uses fluid vars into-dir and target when called
2693 ;; inside dired-create-files:
2694 (function (lambda (from)
2695 (expand-file-name (file-name-nondirectory from) target)))
2696 (function (lambda (from) target)))
2697 marker-char)))
2698
2699 (defun dired-dwim-target-directory ()
2700 ;; Try to guess which target directory the user may want.
2701 ;; If there is a dired buffer displayed in the next window, use
2702 ;; its current subdir, else use current subdir of this dired buffer.
2703 (let ((this-dir (and (eq major-mode 'dired-mode)
2704 (dired-current-directory))))
2705 ;; non-dired buffer may want to profit from this function, e.g. vm-uudecode
2706 (if dired-dwim-target
2707 (let* ((other-buf (window-buffer (next-window)))
2708 (other-dir (save-excursion
2709 (set-buffer other-buf)
2710 (and (eq major-mode 'dired-mode)
2711 (dired-current-directory)))))
2712 (or other-dir this-dir))
2713 this-dir)))
2714
2715 (defun dired-into-dir-with-symlinks (target)
2716 (and (file-directory-p target)
2717 (not (file-symlink-p target))))
2718 ;; This may not always be what you want, especially if target is your
2719 ;; home directory and it happens to be a symbolic link, as is often the
2720 ;; case with NFS and automounters. Or if you want to make symlinks
2721 ;; into directories that themselves are only symlinks, also quite
2722 ;; common.
2723
2724 ;; So we don't use this function as value for HOW-TO in
2725 ;; dired-do-symlink, which has the minor disadvantage of
2726 ;; making links *into* a symlinked-dir, when you really wanted to
2727 ;; *overwrite* that symlink. In that (rare, I guess) case, you'll
2728 ;; just have to remove that symlink by hand before making your marked
2729 ;; symlinks.
2730
2731 (defun dired-do-copy (&optional arg)
2732 "Copy all marked (or next ARG) files, or copy the current file.
2733 Thus, a zero prefix argument copies nothing. But it toggles the
2734 variable `dired-copy-preserve-time' (which see)."
2735 (interactive "P")
2736 (if (not (zerop (prefix-numeric-value arg)))
2737 (dired-do-create-files 'copy (function dired-copy-file)
2738 (if dired-copy-preserve-time "Copy [-p]" "Copy")
2739 arg dired-keep-marker-copy)
2740 (setq dired-copy-preserve-time (not dired-copy-preserve-time))
2741 (if dired-copy-preserve-time
2742 (message "Copy will preserve time.")
2743 (message "Copied files will get current date."))))
2744
2745 (defun dired-do-symlink (&optional arg)
2746 "Symlink all marked (or next ARG) files into a directory,
2747 or make a symbolic link to the current file."
2748 (interactive "P")
2749 (dired-do-create-files 'symlink (function make-symbolic-link)
2750 "SymLink" arg dired-keep-marker-symlink))
2751
2752 (defun dired-do-hardlink (&optional arg)
2753 "Hard-link all marked (or next ARG) files into a directory,
2754 or make a hard link to the current file."
2755 (interactive "P")
2756 (dired-do-create-files 'hardlink (function add-name-to-file)
2757 "HardLink" arg dired-keep-marker-hardlink))
2758
2759 (defun dired-do-move (&optional arg)
2760 "Move all marked (or next ARG) files into a directory,
2761 or rename the current file.
2762 A zero ARG moves no files but toggles `dired-dwim-target' (which see)."
2763 (interactive "P")
2764 (if (not (zerop (prefix-numeric-value arg)))
2765 (dired-do-create-files 'move (function dired-rename-file)
2766 "Move" arg dired-keep-marker-move "Rename")
2767 (setq dired-dwim-target (not dired-dwim-target))
2768 (message "dired-dwim-target is %s." (if dired-dwim-target "ON" "OFF"))))
2769
2770 ;;;###end dired-cp.el
2771
2772 ;;; 5K
2773 ;;;###begin dired-re.el
2774 (defun dired-do-create-files-regexp
2775 (file-creator operation arg regexp newname &optional whole-path marker-char)
2776 ;; Create a new file for each marked file using regexps.
2777 ;; FILE-CREATOR and OPERATION as in dired-create-files.
2778 ;; ARG as in dired-mark-get-files.
2779 ;; Matches each marked file against REGEXP and constructs the new
2780 ;; filename from NEWNAME (like in function replace-match).
2781 ;; Optional arg WHOLE-PATH means match/replace the whole pathname
2782 ;; instead of only the non-directory part of the file.
2783 ;; Optional arg MARKER-CHAR as in dired-create-files.
2784 (let* ((fn-list (dired-mark-get-files nil arg))
2785 (fn-count (length fn-list))
2786 (operation-prompt (concat operation " `%s' to `%s'?"))
2787 (rename-regexp-help-form (format "\
2788 Type SPC or `y' to %s one match, DEL or `n' to skip to next,
2789 `!' to %s all remaining matches with no more questions."
2790 (downcase operation)
2791 (downcase operation)))
2792 (regexp-name-constructor
2793 ;; Function to construct new filename using REGEXP and NEWNAME:
2794 (if whole-path ; easy (but rare) case
2795 (function
2796 (lambda (from)
2797 (let ((to (dired-string-replace-match regexp from newname))
2798 ;; must bind help-form directly around call to
2799 ;; dired-query
2800 (help-form rename-regexp-help-form))
2801 (if to
2802 (and (dired-query 'rename-regexp-query
2803 operation-prompt
2804 from
2805 to)
2806 to)
2807 (dired-log "%s: %s did not match regexp %s\n"
2808 operation from regexp)))))
2809 ;; not whole-path, replace non-directory part only
2810 (function
2811 (lambda (from)
2812 (let* ((new (dired-string-replace-match
2813 regexp (file-name-nondirectory from) newname))
2814 (to (and new ; nil means there was no match
2815 (expand-file-name new
2816 (file-name-directory from))))
2817 (help-form rename-regexp-help-form))
2818 (if to
2819 (and (dired-query 'rename-regexp-query
2820 operation-prompt
2821 (dired-make-relative from)
2822 (dired-make-relative to))
2823 to)
2824 (dired-log "%s: %s did not match regexp %s\n"
2825 operation (file-name-nondirectory from) regexp)))))))
2826 rename-regexp-query)
2827 (dired-create-files
2828 file-creator operation fn-list regexp-name-constructor marker-char)))
2829
2830 (defun dired-mark-read-regexp (operation)
2831 ;; Prompt user about performing OPERATION.
2832 ;; Read and return list of: regexp newname arg whole-path.
2833 (let* ((whole-path
2834 (equal 0 (prefix-numeric-value current-prefix-arg)))
2835 (arg
2836 (if whole-path nil current-prefix-arg))
2837 (regexp
2838 (dired-read-regexp
2839 (concat (if whole-path "Path " "") operation " from (regexp): ")
2840 dired-flagging-regexp))
2841 (newname
2842 (read-string
2843 (concat (if whole-path "Path " "") operation " " regexp " to: "))))
2844 (list regexp newname arg whole-path)))
2845
2846 (defun dired-do-rename-regexp (regexp newname &optional arg whole-path)
2847 "Rename marked files containing REGEXP to NEWNAME.
2848 As each match is found, the user must type a character saying
2849 what to do with it. For directions, type \\[help-command] at that time.
2850 NEWNAME may contain \\=\\<n> or \\& as in `query-replace-regexp'.
2851 REGEXP defaults to the last regexp used.
2852 With a zero prefix arg, renaming by regexp affects the complete
2853 pathname - usually only the non-directory part of file names is used
2854 and changed."
2855 (interactive (dired-mark-read-regexp "Rename"))
2856 (dired-do-create-files-regexp
2857 (function dired-rename-file)
2858 "Rename" arg regexp newname whole-path dired-keep-marker-move))
2859
2860 (defun dired-do-copy-regexp (regexp newname &optional arg whole-path)
2861 "Copy all marked files containing REGEXP to NEWNAME.
2862 See function `dired-rename-regexp' for more info."
2863 (interactive (dired-mark-read-regexp "Copy"))
2864 (dired-do-create-files-regexp
2865 (function dired-copy-file)
2866 (if dired-copy-preserve-time "Copy [-p]" "Copy")
2867 arg regexp newname whole-path dired-keep-marker-copy))
2868
2869 (defun dired-do-hardlink-regexp (regexp newname &optional arg whole-path)
2870 "Hardlink all marked files containing REGEXP to NEWNAME.
2871 See function `dired-rename-regexp' for more info."
2872 (interactive (dired-mark-read-regexp "HardLink"))
2873 (dired-do-create-files-regexp
2874 (function add-name-to-file)
2875 "HardLink" arg regexp newname whole-path dired-keep-marker-hardlink))
2876
2877 (defun dired-do-symlink-regexp (regexp newname &optional arg whole-path)
2878 "Symlink all marked files containing REGEXP to NEWNAME.
2879 See function `dired-rename-regexp' for more info."
2880 (interactive (dired-mark-read-regexp "SymLink"))
2881 (dired-do-create-files-regexp
2882 (function make-symbolic-link)
2883 "SymLink" arg regexp newname whole-path dired-keep-marker-symlink))
2884
2885 (defun dired-create-files-non-directory
2886 (file-creator basename-constructor operation arg)
2887 ;; Perform FILE-CREATOR on the non-directory part of marked files
2888 ;; using function BASENAME-CONSTRUCTOR, with query for each file.
2889 ;; OPERATION like in dired-create-files, ARG like in dired-mark-get-files.
2890 (let (rename-non-directory-query)
2891 (dired-create-files
2892 file-creator
2893 operation
2894 (dired-mark-get-files nil arg)
2895 (function
2896 (lambda (from)
2897 (let ((to (concat (file-name-directory from)
2898 (funcall basename-constructor
2899 (file-name-nondirectory from)))))
2900 (and (let ((help-form (format "\
2901 Type SPC or `y' to %s one file, DEL or `n' to skip to next,
2902 `!' to %s all remaining matches with no more questions."
2903 (downcase operation)
2904 (downcase operation))))
2905 (dired-query 'rename-non-directory-query
2906 (concat operation " `%s' to `%s'")
2907 (dired-make-relative from)
2908 (dired-make-relative to)))
2909 to))))
2910 dired-keep-marker-move)))
2911
2912 (defun dired-rename-non-directory (basename-constructor operation arg)
2913 (dired-create-files-non-directory
2914 (function dired-rename-file)
2915 basename-constructor operation arg))
2916
2917 (defun dired-upcase (&optional arg)
2918 "Rename all marked (or next ARG) files to upper case."
2919 (interactive "P")
2920 (dired-rename-non-directory (function upcase) "Rename upcase" arg))
2921
2922 (defun dired-downcase (&optional arg)
2923 "Rename all marked (or next ARG) files to lower case."
2924 (interactive "P")
2925 (dired-rename-non-directory (function downcase) "Rename downcase" arg))
2926
2927 ;;;###end dired-re.el
2928
2929
2930 ;; Tree Dired
2931
2932 ;;; utility functions
2933
2934 (defun dired-in-this-tree (file dir)
2935 ;;"Is FILE part of the directory tree starting at DIR?"
2936 (let (case-fold-search)
2937 (string-match (concat "^" (regexp-quote dir)) file)))
2938
2939 (defun dired-make-absolute (file &optional dir)
2940 ;;"Convert FILE (a pathname relative to DIR) to an absolute pathname."
2941 ;; We can't always use expand-file-name as this would get rid of `.'
2942 ;; or expand in / instead default-directory if DIR=="".
2943 ;; This should be good enough for ange-ftp, but might easily be
2944 ;; redefined (for VMS?).
2945 ;; It should be reasonably fast, though, as it is called in
2946 ;; dired-get-filename.
2947 (concat (or dir default-directory) file))
2948
2949 (defun dired-make-relative (file &optional dir no-error)
2950 ;;"Convert FILE (an absolute pathname) to a pathname relative to DIR.
2951 ;; Else error (unless NO-ERROR is non-nil, then FILE is returned unchanged)
2952 ;;DIR defaults to default-directory."
2953 ;; DIR must be file-name-as-directory, as with all directory args in
2954 ;; elisp code.
2955 (or dir (setq dir default-directory))
2956 (if (string-match (concat "^" (regexp-quote dir)) file)
2957 (substring file (match-end 0))
2958 (if no-error
2959 file
2960 (error "%s: not in directory tree growing at %s" file dir))))
2961
2962 (defun dired-normalize-subdir (dir)
2963 ;; Prepend default-directory to DIR if relative path name.
2964 ;; dired-get-filename must be able to make a valid filename from a
2965 ;; file and its directory DIR.
2966 (file-name-as-directory
2967 (if (file-name-absolute-p dir)
2968 dir
2969 (expand-file-name dir default-directory))))
2970
2971 (defun dired-between-files ()
2972 ;; Point must be at beginning of line
2973 ;; Should be equivalent to (save-excursion (not (dired-move-to-filename)))
2974 ;; but is about 1.5..2.0 times as fast. (Actually that's not worth it)
2975 (or (looking-at "^$\\|^. *$\\|^. total\\|^. wildcard")
2976 (looking-at dired-subdir-regexp)))
2977
2978 (defun dired-get-subdir ()
2979 ;;"Return the subdir name on this line, or nil if not on a headerline."
2980 ;; Look up in the alist whether this is a headerline.
2981 (save-excursion
2982 (let ((cur-dir (dired-current-directory)))
2983 (beginning-of-line) ; alist stores b-o-l positions
2984 (and (zerop (- (point)
2985 (dired-get-subdir-min (assoc cur-dir
2986 dired-subdir-alist))))
2987 cur-dir))))
2988
2989 ;(defun dired-get-subdir-min (elt)
2990 ; (cdr elt))
2991 ;; can't use macro, must be redefinable for other alist format in dired-nstd.
2992 (fset 'dired-get-subdir-min 'cdr)
2993
2994 (defun dired-get-subdir-max (elt)
2995 (save-excursion
2996 (goto-char (dired-get-subdir-min elt))
2997 (dired-subdir-max)))
2998
2999 (defun dired-clear-alist ()
3000 (while dired-subdir-alist
3001 (set-marker (dired-get-subdir-min (car dired-subdir-alist)) nil)
3002 (setq dired-subdir-alist (cdr dired-subdir-alist))))
3003
3004 (defun dired-simple-subdir-alist ()
3005 ;; Build and return `dired-subdir-alist' assuming just the top level
3006 ;; directory to be inserted. Don't parse the buffer.
3007 (set (make-local-variable 'dired-subdir-alist)
3008 (list (cons default-directory (point-min-marker)))))
3009
3010 (defun dired-build-subdir-alist ()
3011 "Build `dired-subdir-alist' by parsing the buffer and return it's new value."
3012 (interactive)
3013 (dired-clear-alist)
3014 (save-excursion
3015 (let ((count 0))
3016 (goto-char (point-min))
3017 (setq dired-subdir-alist nil)
3018 (while (re-search-forward dired-subdir-regexp nil t)
3019 (setq count (1+ count))
3020 (dired-alist-add-1 (buffer-substring (match-beginning 1)
3021 (match-end 1))
3022 ;; Put subdir boundary between lines:
3023 (save-excursion
3024 (goto-char (match-beginning 0))
3025 (beginning-of-line)
3026 (point-marker)))
3027 (message "%d" count))
3028 (message "%d director%s." count (if (= 1 count) "y" "ies"))
3029 ;; We don't need to sort it because it is in buffer order per
3030 ;; constructionem. Return new alist:
3031 dired-subdir-alist)))
3032
3033 (defun dired-alist-add (dir new-marker)
3034 ;; Add new DIR at NEW-MARKER. Sort alist.
3035 (dired-alist-add-1 dir new-marker)
3036 (dired-alist-sort))
3037
3038 (defun dired-alist-add-1 (dir new-marker)
3039 ;; Add new DIR at NEW-MARKER. Don't sort.
3040 (setq dired-subdir-alist
3041 (cons (cons (dired-normalize-subdir dir) new-marker)
3042 dired-subdir-alist)))
3043
3044 (defun dired-alist-sort ()
3045 ;; Keep the alist sorted on buffer position.
3046 (setq dired-subdir-alist
3047 (sort dired-subdir-alist
3048 (function (lambda (elt1 elt2)
3049 (> (dired-get-subdir-min elt1)
3050 (dired-get-subdir-min elt2)))))))
3051
3052 (defun dired-unsubdir (dir)
3053 ;; Remove DIR from the alist
3054 (setq dired-subdir-alist
3055 (delq (assoc dir dired-subdir-alist) dired-subdir-alist)))
3056
3057 (defun dired-goto-next-nontrivial-file ()
3058 ;; Position point on first nontrivial file after point.
3059 (dired-goto-next-file);; so there is a file to compare with
3060 (if (stringp dired-trivial-filenames)
3061 (while (and (not (eobp))
3062 (string-match dired-trivial-filenames
3063 (file-name-nondirectory
3064 (or (dired-get-filename nil t) ""))))
3065 (forward-line 1)
3066 (dired-move-to-filename))))
3067
3068 (defun dired-goto-next-file ()
3069 (let ((max (1- (dired-subdir-max))))
3070 (while (and (not (dired-move-to-filename)) (< (point) max))
3071 (forward-line 1))))
3072
3073 (defun dired-goto-subdir (dir)
3074 "Goto end of header line of DIR in this dired buffer.
3075 Return value of point on success, otherwise return nil.
3076 The next char is either \\n, or \\r if DIR is hidden."
3077 (interactive
3078 (prog1 ; let push-mark display its message
3079 (list (expand-file-name
3080 (completing-read "Goto in situ directory: " ; prompt
3081 dired-subdir-alist ; table
3082 nil ; predicate
3083 t ; require-match
3084 (dired-current-directory))))
3085 (push-mark)))
3086 (setq dir (file-name-as-directory dir))
3087 (let ((elt (assoc dir dired-subdir-alist)))
3088 (and elt
3089 (goto-char (dired-get-subdir-min elt))
3090 ;; dired-subdir-hidden-p and dired-add-entry depend on point being
3091 ;; at either \r or \n after this function succeeds.
3092 (progn (skip-chars-forward "^\r\n")
3093 (point)))))
3094
3095 (defun dired-goto-file (file)
3096 "Goto file line of FILE in this dired buffer."
3097 ;; Return value of point on success, else nil.
3098 ;; FILE must be an absolute pathname.
3099 ;; Loses if FILE contains control chars like "\007" for which ls
3100 ;; either inserts "?" or "\\007" into the buffer, so we won't find
3101 ;; it in the buffer.
3102 (interactive
3103 (prog1 ; let push-mark display its message
3104 (list (expand-file-name
3105 (read-file-name "Goto file: "
3106 (dired-current-directory))))
3107 (push-mark)))
3108 (setq file (directory-file-name file)) ; does no harm if no directory
3109 (let (found case-fold-search)
3110 (save-excursion
3111 (if (dired-goto-subdir (or (file-name-directory file)
3112 (error "Need absolute pathname for %s" file)))
3113 (let ((base (file-name-nondirectory file))
3114 (boundary (dired-subdir-max)))
3115 (while (and (not found)
3116 ;; filenames are preceded by SPC, this makes
3117 ;; the search faster (e.g. for the filename "-"!).
3118 (search-forward (concat " " base) boundary 'move))
3119 ;; Match could have BASE just as initial substring
3120 ;; or in permission bits or date or
3121 ;; not be a proper filename at all:
3122 (if (equal base (dired-get-filename 'no-dir t))
3123 ;; Must move to filename since an (actually
3124 ;; correct) match could have been elsewhere on the
3125 ;; ;; line (e.g. "-" would match somewhere in the
3126 ;; permission bits).
3127 (setq found (dired-move-to-filename)))))))
3128 (and found
3129 ;; return value of point (i.e., FOUND):
3130 (goto-char found))))
3131
3132 (defun dired-initial-position (dirname)
3133 ;; Where point should go in a new listing of DIRNAME.
3134 ;; Point assumed at beginning of new subdir line.
3135 ;; You may redefine this function as you wish, e.g. like in dired-x.el.
3136 (end-of-line)
3137 (if dired-trivial-filenames (dired-goto-next-nontrivial-file)))
3138
3139 ;;; moving by subdirectories
3140
3141 (defun dired-subdir-index (dir)
3142 ;; Return an index into alist for use with nth
3143 ;; for the sake of subdir moving commands.
3144 (let (found (index 0) (alist dired-subdir-alist))
3145 (while alist
3146 (if (string= dir (car (car alist)))
3147 (setq alist nil found t)
3148 (setq alist (cdr alist) index (1+ index))))
3149 (if found index nil)))
3150
3151 (defun dired-next-subdir (arg &optional no-error-if-not-found no-skip)
3152 "Go to next subdirectory, regardless of level."
3153 ;; Use 0 arg to go to this directory's header line.
3154 ;; NO-SKIP prevents moving to end of header line, returning whatever
3155 ;; position was found in dired-subdir-alist.
3156 (interactive "_p")
3157 (let ((this-dir (dired-current-directory))
3158 pos index)
3159 ;; nth with negative arg does not return nil but the first element
3160 (setq index (- (dired-subdir-index this-dir) arg))
3161 (setq pos (if (>= index 0)
3162 (dired-get-subdir-min (nth index dired-subdir-alist))))
3163 (if pos
3164 (progn
3165 (goto-char pos)
3166 (or no-skip (skip-chars-forward "^\n\r"))
3167 (point))
3168 (if no-error-if-not-found
3169 nil ; return nil if not found
3170 (error "%s directory" (if (> arg 0) "Last" "First"))))))
3171
3172 (defun dired-prev-subdir (arg &optional no-error-if-not-found no-skip)
3173 "Go to previous subdirectory, regardless of level.
3174 When called interactively and not on a subdir line, go to this subdir's line."
3175 ;;(interactive "_p")
3176 (interactive
3177 (list (if current-prefix-arg
3178 (prefix-numeric-value current-prefix-arg)
3179 ;; if on subdir start already, don't stay there!
3180 (if (dired-get-subdir) 1 0))))
3181 (dired-next-subdir (- arg) no-error-if-not-found no-skip))
3182
3183 (defun dired-tree-up (arg)
3184 "Go up ARG levels in the dired tree."
3185 (interactive "_p")
3186 (let ((dir (dired-current-directory)))
3187 (while (>= arg 1)
3188 (setq arg (1- arg)
3189 dir (file-name-directory (directory-file-name dir))))
3190 ;;(setq dir (expand-file-name dir))
3191 (or (dired-goto-subdir dir)
3192 (error "Cannot go up to %s - not in this tree." dir))))
3193
3194 (defun dired-tree-down ()
3195 "Go down in the dired tree."
3196 (interactive "_")
3197 (let ((dir (dired-current-directory)) ; has slash
3198 pos case-fold-search) ; filenames are case sensitive
3199 (let ((rest (reverse dired-subdir-alist)) elt)
3200 (while rest
3201 (setq elt (car rest)
3202 rest (cdr rest))
3203 (if (dired-in-this-tree (directory-file-name (car elt)) dir)
3204 (setq rest nil
3205 pos (dired-goto-subdir (car elt))))))
3206 (if pos
3207 (goto-char pos)
3208 (error "At the bottom"))))
3209
3210 ;;; hiding
3211
3212 (defun dired-subdir-hidden-p (dir)
3213 (and selective-display
3214 (save-excursion
3215 (dired-goto-subdir dir)
3216 (looking-at "\r"))))
3217
3218 (defun dired-unhide-subdir ()
3219 (let (buffer-read-only)
3220 (subst-char-in-region (dired-subdir-min) (dired-subdir-max) ?\r ?\n)))
3221
3222 (defun dired-hide-check ()
3223 (or selective-display
3224 (error "selective-display must be t for subdir hiding to work!")))
3225
3226 (defun dired-hide-subdir (arg)
3227 "Hide or unhide the current subdirectory and move to next directory.
3228 Optional prefix arg is a repeat factor.
3229 Use \\[dired-hide-all] to (un)hide all directories."
3230 (interactive "p")
3231 (dired-hide-check)
3232 (while (>= (setq arg (1- arg)) 0)
3233 (let* ((cur-dir (dired-current-directory))
3234 (hidden-p (dired-subdir-hidden-p cur-dir))
3235 (elt (assoc cur-dir dired-subdir-alist))
3236 (end-pos (1- (dired-get-subdir-max elt)))
3237 buffer-read-only)
3238 ;; keep header line visible, hide rest
3239 (goto-char (dired-get-subdir-min elt))
3240 (skip-chars-forward "^\n\r")
3241 (if hidden-p
3242 (subst-char-in-region (point) end-pos ?\r ?\n)
3243 (subst-char-in-region (point) end-pos ?\n ?\r)))
3244 (dired-next-subdir 1 t)))
3245
3246 (defun dired-hide-all (arg)
3247 "Hide all subdirectories, leaving only their header lines.
3248 If there is already something hidden, make everything visible again.
3249 Use \\[dired-hide-subdir] to (un)hide a particular subdirectory."
3250 (interactive "P")
3251 (dired-hide-check)
3252 (let (buffer-read-only)
3253 (if (save-excursion
3254 (goto-char (point-min))
3255 (search-forward "\r" nil t))
3256 ;; unhide - bombs on \r in filenames
3257 (subst-char-in-region (point-min) (point-max) ?\r ?\n)
3258 ;; hide
3259 (let ((pos (point-max)) ; pos of end of last directory
3260 (alist dired-subdir-alist))
3261 (while alist ; while there are dirs before pos
3262 (subst-char-in-region (dired-get-subdir-min (car alist)) ; pos of prev dir
3263 (save-excursion
3264 (goto-char pos) ; current dir
3265 ;; we're somewhere on current dir's line
3266 (forward-line -1)
3267 (point))
3268 ?\n ?\r)
3269 (setq pos (dired-get-subdir-min (car alist))) ; prev dir gets current dir
3270 (setq alist (cdr alist)))))))
3271
3272
3273 ;; This function is the heart of tree dired.
3274 ;; It is called for each retrieved filename.
3275 ;; It could stand to be faster, though it's mostly function call
3276 ;; overhead. Avoiding to funcall seems to save about 10% in
3277 ;; dired-get-filename. Make it a defsubst?
3278 (defun dired-current-directory (&optional localp)
3279 "Return the name of the subdirectory to which this line belongs.
3280 This returns a string with trailing slash, like `default-directory'.
3281 Optional argument means return a file name relative to `default-directory'."
3282 (let ((here (point))
3283 (alist (or dired-subdir-alist
3284 ;; probably because called in a non-dired buffer
3285 (error "No subdir-alist in %s" (current-buffer))))
3286 elt dir)
3287 (while alist
3288 (setq elt (car alist)
3289 dir (car elt)
3290 ;; use `<=' (not `<') as subdir line is part of subdir
3291 alist (if (<= (dired-get-subdir-min elt) here)
3292 nil ; found
3293 (cdr alist))))
3294 (if localp
3295 (dired-make-relative dir default-directory)
3296 dir)))
3297
3298 ;; Subdirs start at the beginning of their header lines and end just
3299 ;; before the beginning of the next header line (or end of buffer).
3300
3301 (defun dired-subdir-min ()
3302 (save-excursion
3303 (if (not (dired-prev-subdir 0 t t))
3304 (error "Not in a subdir!")
3305 (point))))
3306
3307 (defun dired-subdir-max ()
3308 (save-excursion
3309 (if (not (dired-next-subdir 1 t t))
3310 (point-max)
3311 (point))))
3312
3313 (defun dired-kill-line-or-subdir (&optional arg)
3314 "Kill this line (but not this file).
3315 Optional prefix argument is a repeat factor.
3316 If file is displayed as in situ subdir, kill that as well.
3317 If on a subdir headerline, kill whole subdir."
3318 (interactive "p")
3319 (if (dired-get-subdir)
3320 (dired-kill-subdir)
3321 (dired-kill-line arg)))
3322
3323 (defun dired-kill-line (&optional arg)
3324 (interactive "P")
3325 (setq arg (prefix-numeric-value arg))
3326 (let (buffer-read-only file)
3327 (while (/= 0 arg)
3328 (setq file (dired-get-filename nil t))
3329 (if (not file)
3330 (error "Can only kill file lines.")
3331 (save-excursion (and file
3332 (dired-goto-subdir file)
3333 (dired-kill-subdir)))
3334 (delete-region (progn (beginning-of-line) (point))
3335 (progn (forward-line 1) (point)))
3336 (if (> arg 0)
3337 (setq arg (1- arg))
3338 (setq arg (1+ arg))
3339 (forward-line -1))))
3340 (dired-move-to-filename)))
3341
3342 (defun dired-kill-subdir (&optional remember-marks)
3343 "Remove all lines of current subdirectory.
3344 Lower levels are unaffected."
3345 ;; With optional REMEMBER-MARKS, return a mark-alist.
3346 (interactive)
3347 (let ((beg (dired-subdir-min))
3348 (end (dired-subdir-max))
3349 buffer-read-only cur-dir)
3350 (setq cur-dir (dired-current-directory))
3351 (if (equal cur-dir default-directory)
3352 (error "Attempt to kill top level directory"))
3353 (prog1
3354 (if remember-marks (dired-remember-marks beg end))
3355 (delete-region beg end)
3356 (if (eobp) ; don't leave final blank line
3357 (delete-char -1))
3358 (dired-unsubdir cur-dir))))
3359
3360 (defun dired-do-kill (&optional arg fmt)
3361 "Kill all marked lines (not files).
3362 With a prefix arg, kill all lines not marked or flagged."
3363 ;; Returns count of killed lines. FMT="" suppresses message.
3364 (interactive "P")
3365 (save-excursion
3366 (goto-char (point-min))
3367 (let (buffer-read-only (count 0))
3368 (if (not arg) ; kill marked lines
3369 (let ((regexp (dired-marker-regexp)))
3370 (while (and (not (eobp))
3371 (re-search-forward regexp nil t))
3372 (setq count (1+ count))
3373 (delete-region (progn (beginning-of-line) (point))
3374 (progn (forward-line 1) (point)))))
3375 ;; else kill unmarked lines
3376 (while (not (eobp))
3377 (if (or (dired-between-files)
3378 (not (looking-at "^ ")))
3379 (forward-line 1)
3380 (setq count (1+ count))
3381 (delete-region (point) (save-excursion
3382 (forward-line 1)
3383 (point))))))
3384 (or (equal "" fmt)
3385 (message (or fmt "Killed %d line%s.") count (dired-plural-s count)))
3386 count)))
3387
3388 (defun dired-do-redisplay (&optional arg test-for-subdir)
3389 "Redisplay all marked (or next ARG) files.
3390
3391 If on a subdir line, redisplay that subdirectory. In that case,
3392 a prefix arg lets you edit the ls switches used for the new listing."
3393 ;; Moves point if the next ARG files are redisplayed.
3394 (interactive "P\np")
3395 (if (and test-for-subdir (dired-get-subdir))
3396 (dired-insert-subdir
3397 (dired-get-subdir)
3398 (if arg (read-string "Switches for listing: " dired-actual-switches)))
3399 (message "Redisplaying...")
3400 ;; message instead of making dired-mark-map show-progress is much faster
3401 (dired-mark-map (let ((fname (dired-get-filename)))
3402 (message "Redisplaying... %s" fname)
3403 (dired-update-file-line fname))
3404 arg)
3405 (dired-move-to-filename)
3406 (message "Redisplaying...done")))
3407
3408 (defun dired-mark-files-in-region (start end)
3409 (let (buffer-read-only)
3410 (if (> start end)
3411 (error "start > end"))
3412 (goto-char start) ; assumed at beginning of line
3413 (while (< (point) end)
3414 ;; Skip subdir line and following garbage like the `total' line:
3415 (while (and (< (point) end) (dired-between-files))
3416 (forward-line 1))
3417 (if (and (not (looking-at dired-re-dot))
3418 (dired-get-filename nil t))
3419 (progn
3420 (delete-char 1)
3421 (insert dired-marker-char)))
3422 (forward-line 1))))
3423
3424 (defun dired-mark-subdir-files ()
3425 "Mark all files except `.' and `..'."
3426 (interactive "P")
3427 (let ((p-min (dired-subdir-min)))
3428 (dired-mark-files-in-region p-min (dired-subdir-max))))
3429
3430 (defun dired-mark-subdir-or-file (arg)
3431 "Mark the current (or next ARG) files.
3432 If on a subdir headerline, mark all its files except `.' and `..'.
3433
3434 Use \\[dired-unflag-all-files] to remove all marks
3435 and \\[dired-unmark-subdir-or-file] on a subdir to remove the marks in
3436 this subdir."
3437 (interactive "P")
3438 (if (dired-get-subdir)
3439 (save-excursion (dired-mark-subdir-files))
3440 (dired-mark-file (prefix-numeric-value arg))))
3441
3442 (defun dired-unmark-subdir-or-file (arg)
3443 "Unmark the current (or next ARG) files.
3444 If looking at a subdir, unmark all its files except `.' and `..'."
3445 (interactive "P")
3446 (let ((dired-marker-char ?\040))
3447 (dired-mark-subdir-or-file arg)))
3448
3449 ;;; 5K
3450 ;;;###begin dired-ins.el
3451
3452 (defun dired-maybe-insert-subdir (dirname &optional
3453 switches no-error-if-not-dir-p)
3454 "Insert this subdirectory into the same dired buffer.
3455 If it is already present, just move to it (type \\[dired-do-redisplay] to refresh),
3456 else inserts it at its natural place (as ls -lR would have done).
3457 With a prefix arg, you may edit the ls switches used for this listing.
3458 You can add `R' to the switches to expand the whole tree starting at
3459 this subdirectory.
3460 This function takes some pains to conform to ls -lR output."
3461 (interactive
3462 (list (dired-get-filename)
3463 (if current-prefix-arg
3464 (read-string "Switches for listing: " dired-actual-switches))))
3465 (let ((opoint (point)))
3466 ;; We don't need a marker for opoint as the subdir is always
3467 ;; inserted *after* opoint.
3468 (setq dirname (file-name-as-directory dirname))
3469 (or (and (not switches)
3470 (dired-goto-subdir dirname))
3471 (dired-insert-subdir dirname switches no-error-if-not-dir-p))
3472 ;; Push mark so that it's easy to find back. Do this after the
3473 ;; insert message so that the user sees the `Mark set' message.
3474 (push-mark opoint)))
3475
3476 (defun dired-insert-subdir (dirname &optional switches no-error-if-not-dir-p)
3477 "Insert this subdirectory into the same dired buffer.
3478 If it is already present, overwrites previous entry,
3479 else inserts it at its natural place (as ls -lR would have done).
3480 With a prefix arg, you may edit the ls switches used for this listing.
3481 You can add `R' to the switches to expand the whole tree starting at
3482 this subdirectory.
3483 This function takes some pains to conform to ls -lR output."
3484 ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like
3485 ;; Prospero where dired-ls does the right thing, but
3486 ;; file-directory-p has not been redefined.
3487 (interactive
3488 (list (dired-get-filename)
3489 (if current-prefix-arg
3490 (read-string "Switches for listing: " dired-actual-switches))))
3491 (setq dirname (file-name-as-directory (expand-file-name dirname)))
3492 (dired-insert-subdir-validate dirname switches)
3493 (or no-error-if-not-dir-p
3494 (file-directory-p dirname)
3495 (error "Attempt to insert a non-directory: %s" dirname))
3496 (let ((elt (assoc dirname dired-subdir-alist))
3497 switches-have-R mark-alist case-fold-search buffer-read-only)
3498 ;; case-fold-search is nil now, so we can test for capital `R':
3499 (if (setq switches-have-R (and switches (string-match "R" switches)))
3500 ;; avoid duplicated subdirs
3501 (setq mark-alist (dired-kill-tree dirname t)))
3502 (if elt
3503 ;; If subdir is already present, remove it and remember its marks
3504 (setq mark-alist (nconc (dired-insert-subdir-del elt) mark-alist))
3505 (dired-insert-subdir-newpos dirname)) ; else compute new position
3506 (dired-insert-subdir-doupdate
3507 dirname elt (dired-insert-subdir-doinsert dirname switches))
3508 (if switches-have-R (dired-build-subdir-alist))
3509 (dired-initial-position dirname)
3510 (save-excursion (dired-mark-remembered mark-alist))))
3511
3512 ;; This is a separate function for dired-vms.
3513 (defun dired-insert-subdir-validate (dirname &optional switches)
3514 ;; Check that it is valid to insert DIRNAME with SWITCHES.
3515 ;; Signal an error if invalid (e.g. user typed `i' on `..').
3516 (or (dired-in-this-tree dirname default-directory)
3517 (error "%s: not in this directory tree" dirname))
3518 (if switches
3519 (let (case-fold-search)
3520 (mapcar
3521 (function
3522 (lambda (x)
3523 (or (eq (null (string-match x switches))
3524 (null (string-match x dired-actual-switches)))
3525 (error "Can't have dirs with and without -%s switches together"
3526 x))))
3527 ;; all switches that make a difference to dired-get-filename:
3528 '("F" "b")))))
3529
3530 (defun dired-kill-tree (dirname &optional remember-marks)
3531 ;;"Kill all proper subdirs of DIRNAME, excluding DIRNAME itself.
3532 ;; With optional arg REMEMBER-MARKS, return an alist of marked files."
3533 (interactive "DKill tree below directory: ")
3534 (let ((s-alist dired-subdir-alist) dir m-alist)
3535 (while s-alist
3536 (setq dir (car (car s-alist))
3537 s-alist (cdr s-alist))
3538 (if (and (not (string-equal dir dirname))
3539 (dired-in-this-tree dir dirname)
3540 (dired-goto-subdir dir))
3541 (setq m-alist (nconc (dired-kill-subdir remember-marks) m-alist))))
3542 m-alist))
3543
3544 (defun dired-insert-subdir-newpos (new-dir)
3545 ;; Find pos for new subdir, according to tree order.
3546 (let ((alist dired-subdir-alist) elt dir pos new-pos)
3547 (while alist
3548 (setq elt (car alist)
3549 alist (cdr alist)
3550 dir (car elt)
3551 pos (dired-get-subdir-min elt))
3552 (if (dired-tree-lessp dir new-dir)
3553 ;; Insert NEW-DIR after DIR
3554 (setq new-pos (dired-get-subdir-max elt)
3555 alist nil)))
3556 (goto-char new-pos))
3557 ;; want a separating newline between subdirs
3558 (or (eobp)
3559 (forward-line -1))
3560 (insert "\n")
3561 (point))
3562
3563 (defun dired-insert-subdir-del (element)
3564 ;; Erase an already present subdir (given by ELEMENT) from buffer.
3565 ;; Move to that buffer position. Return a mark-alist.
3566 (let ((begin-marker (dired-get-subdir-min element)))
3567 (goto-char begin-marker)
3568 ;; Are at beginning of subdir (and inside it!). Now determine its end:
3569 (goto-char (dired-subdir-max))
3570 (or (eobp);; want a separating newline _between_ subdirs:
3571 (forward-char -1))
3572 (prog1
3573 (dired-remember-marks begin-marker (point))
3574 (delete-region begin-marker (point)))))
3575
3576 (defun dired-insert-subdir-doinsert (dirname switches)
3577 ;; Insert ls output after point and put point on the correct
3578 ;; position for the subdir alist.
3579 ;; Return the boundary of the inserted text (as list of BEG and END).
3580 (let ((begin (point)) end)
3581 (message "Reading directory %s..." dirname)
3582 (let ((dired-actual-switches
3583 (or switches
3584 (dired-replace-in-string "R" "" dired-actual-switches))))
3585 (if (equal dirname (car (car (reverse dired-subdir-alist))))
3586 ;; top level directory may contain wildcards:
3587 (dired-readin-insert dired-directory)
3588 (dired-ls dirname dired-actual-switches nil t)))
3589 (message "Reading directory %s...done" dirname)
3590 (setq end (point-marker))
3591 (dired-indent-rigidly begin end 2)
3592 ;; call dired-insert-headerline afterwards, as under VMS dired-ls
3593 ;; does insert the headerline itself and the insert function just
3594 ;; moves point.
3595 ;; Need a marker for END as this inserts text.
3596 (goto-char begin)
3597 (dired-insert-headerline dirname)
3598 ;; point is now like in dired-build-subdir-alist
3599 (prog1
3600 (list begin (marker-position end))
3601 (set-marker end nil))))
3602
3603 (defun dired-insert-subdir-doupdate (dirname elt beg-end)
3604 ;; Point is at the correct subdir alist position for ELT,
3605 ;; BEG-END is the subdir-region (as list of begin and end).
3606 (if elt ; subdir was already present
3607 ;; update its position (should actually be unchanged)
3608 (set-marker (dired-get-subdir-min elt) (point-marker))
3609 (dired-alist-add dirname (point-marker)))
3610 ;; The hook may depend on the subdir-alist containing the just
3611 ;; inserted subdir, so run it after dired-alist-add:
3612 (if dired-after-readin-hook
3613 (save-excursion
3614 (let ((begin (nth 0 beg-end))
3615 (end (nth 1 beg-end)))
3616 (goto-char begin)
3617 (save-restriction
3618 (narrow-to-region begin end)
3619 ;; hook may add or delete lines, but the subdir boundary
3620 ;; marker floats
3621 (run-hooks 'dired-after-readin-hook))))))
3622
3623 (defun dired-tree-lessp (dir1 dir2)
3624 ;; Lexicographic order on pathname components, like `ls -lR':
3625 ;; DIR1 < DIR2 iff DIR1 comes *before* DIR2 in an `ls -lR' listing,
3626 ;; i.e., iff DIR1 is a (grand)parent dir of DIR2,
3627 ;; or DIR1 and DIR2 are in the same parentdir and their last
3628 ;; components are string-lessp.
3629 ;; Thus ("/usr/" "/usr/bin") and ("/usr/a/" "/usr/b/") are tree-lessp.
3630 ;; string-lessp could arguably be replaced by file-newer-than-file-p
3631 ;; if dired-actual-switches contained `t'.
3632 (setq dir1 (file-name-as-directory dir1)
3633 dir2 (file-name-as-directory dir2))
3634 (let ((components-1 (dired-split "/" dir1))
3635 (components-2 (dired-split "/" dir2)))
3636 (while (and components-1
3637 components-2
3638 (equal (car components-1) (car components-2)))
3639 (setq components-1 (cdr components-1)
3640 components-2 (cdr components-2)))
3641 (let ((c1 (car components-1))
3642 (c2 (car components-2)))
3643
3644 (cond ((and c1 c2)
3645 (string-lessp c1 c2))
3646 ((and (null c1) (null c2))
3647 nil) ; they are equal, not lessp
3648 ((null c1) ; c2 is a subdir of c1: c1<c2
3649 t)
3650 ((null c2) ; c1 is a subdir of c2: c1>c2
3651 nil)
3652 (t (error "This can't happen"))))))
3653
3654 ;; There should be a builtin split function - inverse to mapconcat.
3655 (defun dired-split (pat str &optional limit)
3656 "Splitting on regexp PAT, turn string STR into a list of substrings.
3657 Optional third arg LIMIT (>= 1) is a limit to the length of the
3658 resulting list.
3659 Thus, if SEP is a regexp that only matches itself,
3660
3661 (mapconcat 'identity (dired-split SEP STRING) SEP)
3662
3663 is always equal to STRING."
3664 (let* ((start (string-match pat str))
3665 (result (list (substring str 0 start)))
3666 (count 1)
3667 (end (if start (match-end 0))))
3668 (if end ; else nothing left
3669 (while (and (or (not (integerp limit))
3670 (< count limit))
3671 (string-match pat str end))
3672 (setq start (match-beginning 0)
3673 count (1+ count)
3674 result (cons (substring str end start) result)
3675 end (match-end 0)
3676 start end)
3677 ))
3678 (if (and (or (not (integerp limit))
3679 (< count limit))
3680 end) ; else nothing left
3681 (setq result
3682 (cons (substring str end) result)))
3683 (nreverse result)))
3684
3685 (defun dired-indent-rigidly (start end arg)
3686 ;; like indent-rigidly but has more efficient behavior w.r.t. the
3687 ;; after-change-functions (i.e., font-lock-mode.)
3688 (save-excursion
3689 (let ((after-change-functions nil)
3690 (after-change-function nil))
3691 (goto-char end)
3692 (indent-rigidly start end arg))
3693 ;; deletion
3694 (run-hook-with-args 'after-change-functions start start (- end start))
3695 (run-hook-with-args 'after-change-function start start (- end start))
3696 ;; insertion
3697 (run-hook-with-args 'after-change-functions start (point) 0)
3698 (run-hook-with-args 'after-change-function start (point) 0)
3699 ))
3700
3701 (if (string-lessp emacs-version "19")
3702 (fset 'dired-indent-rigidly (symbol-function 'indent-rigidly)))
3703
3704 ;;;###end dired-ins.el
3705
3706
3707 ;;; Sorting
3708
3709 ;; Most ls can only sort by name or by date (with -t), nothing else.
3710 ;; GNU ls sorts on size with -S, on extension with -X, and unsorted with -U.
3711 ;; So anything that does not contain these is sort "by name".
3712
3713 (defvar dired-ls-sorting-switches "SXU"
3714 "String of ls switches (single letters) except `t' that influence sorting.")
3715
3716 (defvar dired-sort-by-date-regexp
3717 (concat "^-[^" dired-ls-sorting-switches
3718 "]*t[^" dired-ls-sorting-switches "]*$")
3719 "Regexp recognized by dired to set `by date' mode.")
3720
3721 (defvar dired-sort-by-name-regexp
3722 (concat "^-[^t" dired-ls-sorting-switches "]+$")
3723 "Regexp recognized by dired to set `by name' mode.")
3724
3725 (defvar dired-sort-mode nil
3726 "Whether Dired sorts by name, date etc. (buffer-local).")
3727 ;; This is nil outside dired buffers so it can be used in the modeline
3728
3729 (defun dired-sort-set-modeline ()
3730 ;; Set modeline display according to dired-actual-switches.
3731 ;; Modeline display of "by name" or "by date" guarantees the user a
3732 ;; match with the corresponding regexps. Non-matching switches are
3733 ;; shown literally.
3734 (setq dired-sort-mode
3735 (let (case-fold-search)
3736 (cond ((string-match dired-sort-by-name-regexp dired-actual-switches)
3737 " by name")
3738 ((string-match dired-sort-by-date-regexp dired-actual-switches)
3739 " by date")
3740 (t
3741 (concat " " dired-actual-switches)))))
3742 ;; update mode line:
3743 (set-buffer-modified-p (buffer-modified-p)))
3744
3745 (defun dired-sort-toggle-or-edit (&optional arg)
3746 "Toggle between sort by date/name and refresh the dired buffer.
3747 With a prefix argument you can edit the current listing switches instead."
3748 (interactive "P")
3749 (if arg
3750 (dired-sort-other
3751 (read-string "ls switches (must contain -l): " dired-actual-switches))
3752 (dired-sort-toggle)))
3753
3754 (defun dired-sort-toggle ()
3755 ;; Toggle between sort by date/name. Reverts the buffer.
3756 (setq dired-actual-switches
3757 (let (case-fold-search)
3758 (concat
3759 "-l"
3760 (dired-replace-in-string (concat "[---lt"
3761 dired-ls-sorting-switches "]")
3762 ""
3763 dired-actual-switches)
3764 (if (string-match (concat "[t" dired-ls-sorting-switches "]")
3765 dired-actual-switches)
3766 ""
3767 "t"))))
3768 (dired-sort-set-modeline)
3769 (revert-buffer))
3770
3771 (defun dired-sort-other (switches &optional no-revert)
3772 ;; Specify new ls SWITCHES for current dired buffer. Values matching
3773 ;; `dired-sort-by-date-regexp' or `dired-sort-by-name-regexp' set the
3774 ;; minor mode accordingly, others appear literally in the mode line.
3775 ;; With optional second arg NO-REVERT, don't refresh the listing afterwards.
3776 (setq dired-actual-switches switches)
3777 (dired-sort-set-modeline)
3778 (or no-revert (revert-buffer)))
3779
3780 (if (eq system-type 'vax-vms)
3781 (load "dired-vms"))
3782
3783 (if (string-match "XEmacs" emacs-version)
3784 (load "dired-xemacs-menu"))
3785
3786 (run-hooks 'dired-load-hook) ; for your customizations