Mercurial > hg > xemacs-beta
comparison lisp/efs/dired.el @ 98:0d2f883870bc r20-1b1
Import from CVS: tag r20-1b1
author | cvs |
---|---|
date | Mon, 13 Aug 2007 09:13:56 +0200 |
parents | |
children | 4be1180a9e89 |
comparison
equal
deleted
inserted
replaced
97:498bf5da1c90 | 98:0d2f883870bc |
---|---|
1 ; -*- Emacs-Lisp -*- | |
2 ;; DIRED commands for Emacs. | |
3 ;; Copyright (C) 1985, 1986, 1991 Free Software Foundation, Inc. | |
4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
5 ;; | |
6 ;; File: dired.el | |
7 ;; RCS: | |
8 ;; Dired Version: $Revision: 1.2 $ | |
9 ;; Description: The DIRectory EDitor is for manipulating, and running | |
10 ;; commands on files in a directory. | |
11 ;; Authors: FSF, | |
12 ;; Sebastian Kremer <sk@thp.uni-koeln.de>, | |
13 ;; Sandy Rutherford <sandy@ibm550.sissa.it> | |
14 ;; Cast of thousands... | |
15 ;; | |
16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
17 | |
18 ;; This program is free software; you can redistribute it and/or modify | |
19 ;; it under the terms of the GNU General Public License as published by | |
20 ;; the Free Software Foundation; either version 1, or (at your option) | |
21 ;; any later version. | |
22 | |
23 ;; This program is distributed in the hope that it will be useful, | |
24 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
25 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
26 ;; GNU General Public License for more details. | |
27 | |
28 ;; You should have received a copy of the GNU General Public License | |
29 ;; along with GNU Emacs; see the file COPYING. If not, write to | |
30 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
31 | |
32 ;; Rewritten in 1990/1991 to add tree features, file marking and | |
33 ;; sorting by Sebastian Kremer <sk@thp.uni-koeln.de>. | |
34 ;; 7-1993: Added special features for efs interaction and upgraded to Emacs 19. | |
35 ;; Sandy Rutherford <sandy@ibm550.sissa.it> | |
36 | |
37 ;;; Dired Version | |
38 | |
39 (defconst dired-version (substring "$Revision: 1.2 $" 11 -2) | |
40 "The revision number of Tree Dired (as a string). | |
41 | |
42 Don't forget to mention this when reporting bugs to: | |
43 | |
44 efs-bugs@cuckoo.hpl.hp.com") | |
45 | |
46 ;; Global key bindings: | |
47 ;; -------------------- | |
48 ;; | |
49 ;; By convention, dired uses the following global key-bindings. | |
50 ;; These may or may not already be set up in your local emacs. If not | |
51 ;; then you will need to add them to your .emacs file, or the system | |
52 ;; default.el file. We don't set them automatically here, as users may | |
53 ;; have individual preferences. | |
54 ;; | |
55 ;; (define-key ctl-x-map "d" 'dired) | |
56 ;; (define-key ctl-x-4-map "d" 'dired-other-window) | |
57 ;; (define-key ctl-x-map "\C-j" 'dired-jump-back) | |
58 ;; (define-key ctl-x-4-map "\C-j" 'dired-jump-back-other-window) | |
59 ;; | |
60 ;; For V19 emacs only. (Make sure that the ctl-x-5-map exists.) | |
61 ;; (define-key ctl-x-5-map "d" 'dired-other-frame) | |
62 ;; (define-key Ctl-x-5-map "\C-j" 'dired-jump-back-other-frame) | |
63 | |
64 | |
65 ;;; Grok the current emacs version | |
66 ;; | |
67 ;; Hopefully these two variables provide us with enough version sensitivity. | |
68 | |
69 ;; Make sure that we have a frame-width function | |
70 (or (fboundp 'frame-width) (fset 'frame-width 'screen-width)) | |
71 | |
72 ;;; Requirements and provisions | |
73 | |
74 (provide 'dired) | |
75 (require 'backquote) ; For macros. | |
76 | |
77 ;; Compatibility requirements for the file-name-handler-alist. | |
78 (let ((lucid-p (string-match "Lucid" emacs-version)) | |
79 ver subver) | |
80 (or (string-match "^\\([0-9]+\\)\\.\\([0-9]+\\)" emacs-version) | |
81 (error "dired does not work with emacs version %s" emacs-version)) | |
82 (setq ver (string-to-int (substring emacs-version (match-beginning 1) | |
83 (match-end 1))) | |
84 subver (string-to-int (substring emacs-version (match-beginning 2) | |
85 (match-end 2)))) | |
86 (cond | |
87 ((= ver 18) | |
88 (require 'emacs-19) | |
89 (require 'fn-handler)) | |
90 ((and (= ver 19) (if lucid-p (< subver 10) (< subver 23))) | |
91 (require 'fn-handler)) | |
92 ((< ver 18) | |
93 (error "dired does not work with emacs version %s" emacs-version)))) | |
94 | |
95 ;; Load default-dir last, because we want its interactive specs. | |
96 (require 'default-dir) | |
97 | |
98 | |
99 ;;;;---------------------------------------------------------------- | |
100 ;;;; Customizable variables | |
101 ;;;;---------------------------------------------------------------- | |
102 ;; | |
103 ;; The funny comments are for autoload.el, to automagically update | |
104 ;; loaddefs. | |
105 | |
106 ;;; Variables for compressing files. | |
107 | |
108 ;;;###autoload | |
109 (defvar dired-compression-method 'compress | |
110 "*Type of compression program to use. | |
111 Give as a symbol. | |
112 Currently-recognized methods are: gzip pack compact compress. | |
113 To change this variable use \\[dired-do-compress] with a zero prefix.") | |
114 | |
115 ;;;###autoload | |
116 (defvar dired-compression-method-alist | |
117 '((gzip ".gz" ("gzip") ("gzip" "-d") "-f") | |
118 ;; Put compress before pack, so that it wins out if we are using | |
119 ;; efs to work on a case insensitive OS. The -f flag does | |
120 ;; two things in compress. No harm in giving it twice. | |
121 (compress ".Z" ("compress" "-f") ("compress" "-d") "-f") | |
122 ;; pack support may not work well. pack is too chatty and there is no way | |
123 ;; to force overwrites. | |
124 (pack ".z" ("pack" "-f") ("unpack")) | |
125 (compact ".C" ("compact") ("uncompact"))) | |
126 | |
127 "*Association list of compression method descriptions. | |
128 Each element of the table should be a list of the form | |
129 | |
130 \(compress-type extension (compress-args) (decompress-args) force-flag\) | |
131 | |
132 where | |
133 `compress-type' is a unique symbol in the alist to which | |
134 `dired-compression-method' can be set; | |
135 `extension' is the file extension (as a string) used by files compressed | |
136 by this method; | |
137 `compress-args' is a list of the path of the compression program and | |
138 flags to pass as separate arguments; | |
139 `decompress-args' is a list of the path of the decompression | |
140 program and flags to pass as separate arguments. | |
141 `force-flag' is the switch to pass to the command to force overwriting | |
142 of existing files. | |
143 | |
144 For example: | |
145 | |
146 \(setq dired-compresssion-method-alist | |
147 \(cons '\(frobnicate \".frob\" \(\"frob\"\) \(\"frob\" \"-d\"\) \"-f\"\) | |
148 dired-compression-method-alist\)\) | |
149 => \(\(frobnicate \".frob\" \(\"frob\"\) \(\"frob\" \"-d\"\)\) | |
150 \(gzip \".gz\" \(\"gzip\"\) \(\"gunzip\"\)\) | |
151 ...\) | |
152 | |
153 See also: dired-compression-method <V>") | |
154 | |
155 ;;; Variables for the ls program. | |
156 | |
157 ;;;###autoload | |
158 (defvar dired-ls-program "ls" | |
159 "*Absolute or relative name of the ls program used by dired.") | |
160 | |
161 ;;;###autoload | |
162 (defvar dired-listing-switches "-al" | |
163 "*Switches passed to ls for dired. MUST contain the `l' option. | |
164 Can contain even `F', `b', `i' and `s'.") | |
165 | |
166 (defvar dired-ls-F-marks-symlinks | |
167 (memq system-type '(aix-v3 hpux silicon-graphics-unix)) | |
168 ;; Both SunOS and Ultrix have system-type berkeley-unix. But | |
169 ;; SunOS doesn't mark symlinks, but Ultrix does. Therefore, | |
170 ;; can't grok this case. | |
171 "*Informs dired about how ls -lF marks symbolic links. | |
172 Set this to t if `dired-ls-program' with -lF marks the name of the symbolic | |
173 link itself with a trailing @. | |
174 | |
175 For example: If foo is a link pointing to bar, and \"ls -F bar\" gives | |
176 | |
177 ... bar -> foo | |
178 | |
179 set this variable to nil. If it gives | |
180 | |
181 ... bar@ -> foo | |
182 | |
183 set this variable to t. | |
184 | |
185 Dired checks if there is really a @ appended. Thus, if you have a | |
186 marking ls program on one host and a non-marking on another host, and | |
187 don't care about symbolic links which really end in a @, you can | |
188 always set this variable to t. | |
189 | |
190 If you use efs, it will make this variable buffer-local, and control | |
191 it according to its assessment of how the remote host marks symbolic | |
192 links.") | |
193 | |
194 (defvar dired-show-ls-switches nil | |
195 "*If non-nil dired will show the dired ls switches on the modeline. | |
196 If nil, it will indicate how the files are sorted by either \"by name\" or | |
197 \"by date\". If it is unable to recognize the sorting defined by the switches, | |
198 then the switches will be shown explicitly on the modeline, regardless of the | |
199 setting of this variable.") | |
200 | |
201 ;;; Variables for other unix utility programs. | |
202 | |
203 ;; For most program names, don't use absolute paths so that dired | |
204 ;; uses the user's value of the environment variable PATH. chown is | |
205 ;; an exception as it is not always in the PATH. | |
206 | |
207 ;;;###autoload | |
208 (defvar dired-chown-program | |
209 (if (memq system-type '(hpux dgux usg-unix-v)) "chown" "/etc/chown") | |
210 "*Name of chown command (usully `chown' or `/etc/chown').") | |
211 | |
212 ;;;###autoload | |
213 (defvar dired-gnutar-program nil | |
214 "*If non-nil, name of the GNU tar executable (e.g. \"tar\" or \"gnutar\"). | |
215 GNU tar's `z' switch is used for compressed tar files. | |
216 If you don't have GNU tar, set this to nil: a pipe using `zcat' is then used.") | |
217 | |
218 ;;;###autoload | |
219 (defvar dired-unshar-program nil | |
220 "*Set to the name of the unshar program, if you have it.") | |
221 | |
222 ;;; Markers | |
223 | |
224 (defvar dired-keep-marker-rename t | |
225 ;; Use t as default so that moved files `take their markers with them' | |
226 "*Controls marking of renamed files. | |
227 If t, files keep their previous marks when they are renamed. | |
228 If a character, renamed files (whether previously marked or not) | |
229 are afterward marked with that character.") | |
230 | |
231 (defvar dired-keep-marker-compress t | |
232 "*Controls marking of compressed or uncompressed files. | |
233 If t, files keep their previous marks when they are compressed. | |
234 If a character, compressed or uncompressed files (whether previously | |
235 marked or not) are afterward marked with that character.") | |
236 | |
237 (defvar dired-keep-marker-uucode ?U | |
238 "*Controls marking of uuencoded or uudecoded files. | |
239 If t, files keep their previous marks when they are uuencoded. | |
240 If a character, uuencoded or uudecoded files (whether previously | |
241 marked or not) are afterward marked with that character.") | |
242 | |
243 (defvar dired-keep-marker-copy ?C | |
244 "*Controls marking of copied files. | |
245 If t, copied files are marked if and as the corresponding original files were. | |
246 If a character, copied files are unconditionally marked with that character.") | |
247 | |
248 (defvar dired-keep-marker-hardlink ?H | |
249 "*Controls marking of newly made hard links. | |
250 If t, they are marked if and as the files linked to were marked. | |
251 If a character, new links are unconditionally marked with that character.") | |
252 | |
253 (defvar dired-keep-marker-symlink ?S | |
254 "*Controls marking of newly made symbolic links. | |
255 If t, they are marked if and as the files linked to were marked. | |
256 If a character, new links are unconditionally marked with that character.") | |
257 | |
258 (defvar dired-keep-marker-kill ?K | |
259 "*When killed file lines are redisplayed, they will have this marker. | |
260 Setting this to nil means that they will not have any marker.") | |
261 | |
262 (defvar dired-failed-marker-shell ?! | |
263 "*If non-nil, a character with which to mark files of failed shell commands. | |
264 Applies to the command `dired-do-shell-command'. Files for which the shell | |
265 command has a nonzero exit status will be marked with this character") | |
266 | |
267 ;;; Behavioral Variables | |
268 | |
269 ;;;###autoload | |
270 (defvar dired-local-variables-file ".dired" | |
271 "*If non-nil, filename for local variables for Dired. | |
272 If Dired finds a file with that name in the current directory, it will | |
273 temporarily insert it into the dired buffer and run `hack-local-variables'. | |
274 | |
275 Type \\[info] and `g' `(emacs)File Variables' `RET' for more info on | |
276 local variables.") | |
277 | |
278 ;; Usually defined in files.el. Define here anyway, to be safe. | |
279 ;;;###autoload | |
280 (defvar dired-kept-versions 2 | |
281 "*When cleaning directory, number of versions to keep.") | |
282 | |
283 ;;;###autoload | |
284 (defvar dired-find-subdir nil | |
285 "*Determines whether dired tries to lookup a subdir in existing buffers. | |
286 If non-nil, dired does not make a new buffer for a directory if it can be | |
287 found (perhaps as subdir) in some existing dired buffer. If there are several | |
288 dired buffers for a directory, then the most recently used one is chosen. | |
289 | |
290 Dired avoids switching to the current buffer, so that if you have | |
291 a normal and a wildcard buffer for the same directory, C-x d RET will | |
292 toggle between those two.") | |
293 | |
294 ;;;###autoload | |
295 (defvar dired-use-file-transformers t | |
296 "*Determines whether dired uses file transformers. | |
297 If non-nil `dired-do-shell-command' will apply file transformers to file names. | |
298 See \\[describe-function] for dired-do-shell-command for more information.") | |
299 | |
300 ;;;###autoload | |
301 (defvar dired-dwim-target nil | |
302 "*If non-nil, dired tries to guess a default target directory. | |
303 This means that if there is a dired buffer displayed in the next window, | |
304 use its current subdir, instead of the current subdir of this dired buffer. | |
305 The target is put in the prompt for file copy, rename, etc.") | |
306 | |
307 ;;;###autoload | |
308 (defvar dired-copy-preserve-time nil | |
309 "*If non-nil, Dired preserves the last-modified time in a file copy. | |
310 \(This works on only some systems.)\\<dired-mode-map> | |
311 Use `\\[dired-do-copy]' with a zero prefix argument to toggle its value.") | |
312 | |
313 ;;;###autoload | |
314 (defvar dired-no-confirm nil | |
315 "*If non-nil, a list of symbols for commands dired should not confirm. | |
316 It can be a sublist of | |
317 | |
318 '(byte-compile chgrp chmod chown compress copy delete hardlink load | |
319 move print shell symlink uncompress recursive-delete kill-file-buffer | |
320 kill-dired-buffer patch create-top-dir revert-subdirs) | |
321 | |
322 The meanings of most of the symbols are obvious. A few exceptions: | |
323 | |
324 'compress applies to compression or decompression by any of the | |
325 compression program in `dired-compression-method-alist'. | |
326 | |
327 'kill-dired-buffer applies to offering to kill dired buffers for | |
328 directories which have been deleted. | |
329 | |
330 'kill-file-buffer applies to offering to kill buffers visiting files | |
331 which have been deleted. | |
332 | |
333 'recursive-delete applies to recursively deleting non-empty | |
334 directories, and all of their contents. | |
335 | |
336 'create-top-dir applies to `dired-up-directory' creating a new top level | |
337 directory for the dired buffer. | |
338 | |
339 'revert-subdirs applies to re-reading subdirectories which have | |
340 been modified on disk. | |
341 | |
342 Note that this list also applies to remote files accessed with efs | |
343 or ange-ftp.") | |
344 | |
345 ;;;###autoload | |
346 (defvar dired-backup-if-overwrite nil | |
347 "*Non-nil if Dired should ask about making backups before overwriting files. | |
348 Special value 'always suppresses confirmation.") | |
349 | |
350 ;;;###autoload | |
351 (defvar dired-omit-files nil | |
352 "*If non-nil un-interesting files will be omitted from this dired buffer. | |
353 Use \\[dired-omit-toggle] to see these files. (buffer local)") | |
354 (make-variable-buffer-local 'dired-omit-files) | |
355 | |
356 ;;;###autoload | |
357 (defvar dired-mail-reader 'rmail | |
358 "*Mail reader used by dired for dired-read-mail \(\\[dired-read-mail]\). | |
359 The symbols 'rmail and 'vm are the only two allowed values.") | |
360 | |
361 (defvar dired-verify-modtimes t | |
362 "*If non-nil dired will revert dired buffers for modified subdirectories. | |
363 See also dired-no-confirm <V>.") | |
364 | |
365 ;;; File name regular expressions and extensions. | |
366 | |
367 (defvar dired-trivial-filenames "^\\.\\.?$\\|^#" | |
368 "*Regexp of files to skip when finding first file of a directory listing. | |
369 A value of nil means move to the subdir line. | |
370 A value of t means move to first file.") | |
371 | |
372 (defvar dired-cleanup-alist | |
373 (list | |
374 '("tex" ".toc" ".log" ".aux" ".dvi") | |
375 '("latex" ".toc" ".log" ".aux" ".idx" ".lof" ".lot" ".glo" ".dvi") | |
376 '("bibtex" ".blg" ".bbl") | |
377 '("texinfo" ".cp" ".cps" ".fn" ".fns" ".ky" ".kys" ".pg" ".pgs" | |
378 ".tp" ".tps" ".vr" ".vrs") | |
379 '("patch" ".rej" ".orig") | |
380 '("backups" "~") | |
381 (cons "completion-ignored-extensions" completion-ignored-extensions)) | |
382 "*Alist of extensions for temporary files created by various programs. | |
383 Used by `dired-cleanup'.") | |
384 | |
385 (defvar dired-omit-extensions | |
386 (let ((alist dired-cleanup-alist) | |
387 x result) | |
388 (while alist | |
389 (setq x (cdr (car alist)) | |
390 alist (cdr alist)) | |
391 (while x | |
392 (or (member (car x) result) | |
393 (setq result (cons (car x) result))) | |
394 (setq x (cdr x)))) | |
395 result) | |
396 "*List of extensions for file names that will be omitted (buffer-local). | |
397 This only has effect when the subdirectory is in omission mode. | |
398 To make omission mode the default, set `dired-omit-files' to t. | |
399 See also `dired-omit-extensions'.") | |
400 (make-variable-buffer-local 'dired-omit-extensions) | |
401 | |
402 (defvar dired-omit-regexps '("^#" "^\\.") | |
403 "*File names matching these regexp may be omitted (buffer-local). | |
404 This only has effect when the subdirectory is in omission mode. | |
405 To make omission mode the default, set `dired-omit-files' to t. | |
406 This only has effect when `dired-omit-files-p' is t. | |
407 See also `dired-omit-extensions'.") | |
408 (make-variable-buffer-local 'dired-omit-files-regexp) | |
409 | |
410 (defvar dired-filename-re-ext "\\..+$" ; start from the first dot. last dot? | |
411 "*Defines what is the extension of a file name. | |
412 \(match-beginning 0\) for this regexp in the file name without directory will | |
413 be taken to be the start of the extension.") | |
414 | |
415 ;;; Hook variables | |
416 | |
417 (defvar dired-load-hook nil | |
418 "Run after loading dired. | |
419 You can customize key bindings or load extensions with this.") | |
420 | |
421 (defvar dired-grep-load-hook nil | |
422 "Run after loading dired-grep.") | |
423 | |
424 (defvar dired-mode-hook nil | |
425 "Run at the very end of dired-mode.") | |
426 | |
427 (defvar dired-before-readin-hook nil | |
428 "Hook run before a dired buffer is newly read in, created,or reverted.") | |
429 | |
430 (defvar dired-after-readin-hook nil | |
431 "Hook run after each listing of a file or directory. | |
432 The buffer is narrowed to the new listing.") | |
433 | |
434 (defvar dired-setup-keys-hook nil | |
435 "Hook run when dired sets up its keymap. | |
436 This happens the first time that `dired-mode' is called, and runs after | |
437 `dired-mode-hook'. This hook can be used to make alterations to the | |
438 dired keymap.") | |
439 | |
440 ;;; Internal variables | |
441 ;; | |
442 ;; If you set these, know what you are doing. | |
443 | |
444 ;;; Marker chars. | |
445 | |
446 (defvar dired-marker-char ?* ; the answer is 42 | |
447 ; life the universe and everything | |
448 ;; so that you can write things like | |
449 ;; (let ((dired-marker-char ?X)) | |
450 ;; ;; great code using X markers ... | |
451 ;; ) | |
452 ;; For example, commands operating on two sets of files, A and B. | |
453 ;; Or marking files with digits 0-9. This could implicate | |
454 ;; concentric sets or an order for the marked files. | |
455 ;; The code depends on dynamic scoping on the marker char. | |
456 "In dired, character used to mark files for later commands.") | |
457 (make-variable-buffer-local 'dired-marker-char) | |
458 | |
459 (defconst dired-default-marker dired-marker-char) | |
460 ;; Stores the default value of dired-marker-char when dynamic markers | |
461 ;; are being used. | |
462 | |
463 (defvar dired-del-marker ?D | |
464 "Character used to flag files for deletion.") | |
465 | |
466 ;; \017=^O for Omit - other packages can chose other control characters. | |
467 (defvar dired-omit-marker-char ?\017) | |
468 ;; Marker used for omitted files. Shouldn't be used by anything else. | |
469 | |
470 (defvar dired-kill-marker-char ?\C-k) | |
471 ;; Marker used by dired-do-kill. Shouldn't be used by anything else. | |
472 | |
473 ;;; State variables | |
474 | |
475 (defvar dired-mode-line-modified "-%s%s%s-" | |
476 "*Format string to show the modification status of the buffer.") | |
477 | |
478 (defvar dired-del-flags-number 0) | |
479 (make-variable-buffer-local 'dired-del-flags-number) | |
480 (defvar dired-marks-number 0) | |
481 (make-variable-buffer-local 'dired-marks-number) | |
482 (defvar dired-other-marks-number 0) | |
483 (make-variable-buffer-local 'dired-other-marks-number) | |
484 | |
485 (defvar dired-marked-files nil | |
486 "List of filenames from last `dired-copy-filename-as-kill' call.") | |
487 | |
488 (defvar dired-directory nil | |
489 "The directory name or shell wildcard that was used as argument to `ls'. | |
490 Local to each dired buffer. May be a list, in which case the car is the | |
491 directory name and the cdr is the actual files to list.") | |
492 (make-variable-buffer-local 'dired-directory) | |
493 | |
494 (defvar dired-internal-switches nil | |
495 "The actual (buffer-local) value of `dired-listing-switches'. | |
496 The switches are represented as a list of characters.") | |
497 (make-variable-buffer-local 'dired-internal-switches) | |
498 | |
499 (defvar dired-subdir-alist nil | |
500 "Association list of subdirectories and their buffer positions. | |
501 Each subdirectory has an element: (DIRNAME . STARTMARKER). | |
502 The order of elements is the reverse of the order in the buffer.") | |
503 (make-variable-buffer-local 'dired-subdir-alist) | |
504 | |
505 (defvar dired-curr-subdir-min 0) | |
506 ;; Cache for modeline tracking of the cursor | |
507 (make-variable-buffer-local 'dired-curr-subdir-min) | |
508 | |
509 (defvar dired-curr-subdir-max 0) | |
510 ;; Cache for modeline tracking of the cursor | |
511 (make-variable-buffer-local 'dired-curr-subdir-max) | |
512 | |
513 (defvar dired-subdir-omit nil) | |
514 ;; Controls whether the modeline shows Omit. | |
515 (make-variable-buffer-local 'dired-subdir-omit) | |
516 | |
517 (defvar dired-in-query nil) | |
518 ;; let-bound to t when dired is in the process of querying the user. | |
519 ;; This is to keep asynch messaging from clobbering the query prompt. | |
520 | |
521 (defvar dired-overwrite-confirmed nil) | |
522 ;; Fluid variable used to remember if a bunch of overwrites have been | |
523 ;; confirmed. | |
524 | |
525 (defvar dired-overwrite-backup-query nil) | |
526 ;; Fluid var used to remember if backups have been requested for overwrites. | |
527 | |
528 (defvar dired-file-creator-query nil) | |
529 ;; Fluid var to remember responses to file-creator queries. | |
530 | |
531 (defvar dired-omit-silent nil) | |
532 ;; This is sometimes let-bound to t if messages would be annoying, | |
533 ;; e.g., in dired-awrh.el. Binding to 0, only suppresses | |
534 ;; \"(Nothing to omit)\" message. | |
535 | |
536 (defvar dired-buffers nil | |
537 ;; Enlarged by dired-advertise | |
538 ;; Queried by function dired-buffers-for-dir. When this detects a | |
539 ;; killed buffer, it is removed from this list. | |
540 "Alist of directories and their associated dired buffers.") | |
541 | |
542 (defvar dired-sort-mode nil | |
543 "Whether Dired sorts by name, date, etc. | |
544 \(buffer-local\)") | |
545 ;; This is nil outside dired buffers so it can be used in the modeline | |
546 (make-variable-buffer-local 'dired-sort-mode) | |
547 | |
548 (defvar dired-marker-stack nil | |
549 "List of previously used dired marker characters.") | |
550 (make-variable-buffer-local 'dired-marker-stack) | |
551 | |
552 (defvar dired-marker-stack-pointer 0) | |
553 ;; Points to the current marker in the stack | |
554 (make-variable-buffer-local 'dired-marker-stack-pointer) | |
555 | |
556 (defvar dired-marker-stack-cursor ?\ ; space | |
557 "Character to use as a cursor in the dired marker stack.") | |
558 | |
559 (defconst dired-marker-string "" | |
560 "String version of `dired-marker-stack'.") | |
561 (make-variable-buffer-local 'dired-marker-string) | |
562 | |
563 (defvar dired-modeline-tracking-cmds nil) | |
564 ;; List of commands after which the modeline gets updated. | |
565 | |
566 ;;; Config. variables not usually considered fair game for the user. | |
567 | |
568 (defvar dired-deletion-confirmer 'yes-or-no-p) ; or y-or-n-p? | |
569 | |
570 (defvar dired-log-buffer "*Dired log*") | |
571 ;; Name of buffer used to log dired messages and errors. | |
572 | |
573 ;;; Assoc. lists | |
574 | |
575 ;; For pop ups and user input for file marking | |
576 (defvar dired-query-alist | |
577 '((?\y . y) (?\040 . y) ; `y' or SPC means accept once | |
578 (?n . n) (?\177 . n) ; `n' or DEL skips once | |
579 (?! . yes) ; `!' accepts rest | |
580 (?q. no) (?\e . no) ; `q' or ESC skips rest | |
581 ;; None of these keys quit - use C-g for that. | |
582 )) | |
583 | |
584 (defvar dired-sort-type-alist | |
585 ;; alist of sort flags, and the sort type, as a symbol. | |
586 ;; Don't put ?r in here. It's handled separately. | |
587 '((?t . date) (?S . size) (?U . unsort) (?X . ext))) | |
588 | |
589 ;;; Internal regexps for examining ls listings. | |
590 ;; | |
591 ;; Many of these regexps must be tested at beginning-of-line, but are also | |
592 ;; used to search for next matches, so neither omitting "^" nor | |
593 ;; replacing "^" by "\n" (to make it slightly faster) will work. | |
594 | |
595 (defvar dired-re-inode-size "[ \t0-9]*") | |
596 ;; Regexp for optional initial inode and file size. | |
597 ;; Must match output produced by ls' -i and -s flags. | |
598 | |
599 (defvar dired-re-mark "^[^ \n\r]") | |
600 ;; Regexp matching a marked line. | |
601 ;; Important: the match ends just after the marker. | |
602 | |
603 (defvar dired-re-maybe-mark "^. ") | |
604 | |
605 (defvar dired-re-dir (concat dired-re-maybe-mark dired-re-inode-size "d")) | |
606 ;; Matches directory lines | |
607 | |
608 (defvar dired-re-sym (concat dired-re-maybe-mark dired-re-inode-size "l")) | |
609 ;; Matches symlink lines | |
610 | |
611 (defvar dired-re-exe;; match ls permission string of an executable file | |
612 (mapconcat (function | |
613 (lambda (x) | |
614 (concat dired-re-maybe-mark dired-re-inode-size x))) | |
615 '("-[-r][-w][xs][-r][-w].[-r][-w]." | |
616 "-[-r][-w].[-r][-w][xs][-r][-w]." | |
617 "-[-r][-w].[-r][-w].[-r][-w][xst]") | |
618 "\\|")) | |
619 | |
620 (defvar dired-re-dot "^.* \\.\\.?/?$") ; with -F, might end in `/' | |
621 ;; . and .. files | |
622 | |
623 (defvar dired-re-month-and-time | |
624 (concat | |
625 " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|June?\\|July?\\|Aug\\|Sep\\|Oct\\|Nov\\|" | |
626 ; June and July are for HP-UX 9.0 | |
627 "Dec\\) [ 0-3][0-9]\\(" | |
628 " [012][0-9]:[0-6][0-9] \\|" ; time | |
629 " [12][90][0-9][0-9] \\|" ; year on IRIX, NeXT, SunOS, ULTRIX, Apollo, | |
630 ; HP-UX, A/UX | |
631 " [12][90][0-9][0-9] \\)" ; year on AIX | |
632 )) | |
633 ;; This regexp MUST match all the way to first character of the filename. | |
634 ;; You can loosen it to taste, but then you might bomb on filenames starting | |
635 ;; with a space. This will have to be modified for non-english month names. | |
636 | |
637 (defvar dired-subdir-regexp | |
638 "\\([\n\r]\n\\|\\`\\). \\([^\n\r]+\\)\\(:\\)\\(\\.\\.\\.\r\\|[\n\r]\\)") | |
639 ;; Regexp matching a maybe hidden subdirectory line in ls -lR output. | |
640 ;; Subexpression 2 is the subdirectory proper, no trailing colon. | |
641 ;; Subexpression 3 must end right before the \n or \r at the end of | |
642 ;; the subdir heading. Matches headings after indentation has been done. | |
643 | |
644 (defvar dired-unhandle-add-files nil) | |
645 ;; List of files that the dired handler function need not add to dired buffers. | |
646 ;; This is because they have already been added, most likely in | |
647 ;; dired-create-files. This is because dired-create-files add files with | |
648 ;; special markers. | |
649 | |
650 ;;; history variables | |
651 | |
652 (defvar dired-regexp-history nil | |
653 "History list of regular expressions used in Dired commands.") | |
654 | |
655 (defvar dired-chmod-history nil | |
656 "History of arguments to chmod in dired.") | |
657 | |
658 (defvar dired-chown-history nil | |
659 "History of arguments to chown in dired.") | |
660 | |
661 (defvar dired-chgrp-history nil | |
662 "History of arguments to chgrp in dired.") | |
663 | |
664 (defvar dired-cleanup-history nil | |
665 "History of arguments to dired-cleanup.") | |
666 | |
667 (defvar dired-goto-file-history nil) | |
668 ;; History for dired-goto-file and dired-goto-subdir | |
669 (put 'dired-goto-file-history 'cursor-end t) ; for gmhist | |
670 | |
671 (defvar dired-history nil) | |
672 ;; Catch-all history variable for dired file ops without | |
673 ;; their own history. | |
674 | |
675 (defvar dired-op-history-alist | |
676 ;; alist of dired file operations and history symbols | |
677 '((chgrp . dired-chgrp-history) (chown . dired-chown-history) | |
678 (chmod . dired-chmod-history) )) | |
679 | |
680 ;;; Tell the byte-compiler that we know what we're doing. | |
681 ;;; Do we? | |
682 | |
683 (defvar file-name-handler-alist) | |
684 (defvar inhibit-file-name-operation) | |
685 (defvar inhibit-file-name-handlers) | |
686 (defvar efs-dired-host-type) | |
687 | |
688 | |
689 ;;;;------------------------------------------------------------------ | |
690 ;;;; Utilities | |
691 ;;;;------------------------------------------------------------------ | |
692 | |
693 ;;; Macros | |
694 ;; | |
695 ;; Macros must be defined before they are used - for the byte compiler. | |
696 | |
697 (defmacro dired-get-subdir-min (elt) | |
698 ;; Returns the value of the subdir minumum for subdir with entry ELT in | |
699 ;; dired-subdir-alist. | |
700 (list 'nth 1 elt)) | |
701 | |
702 (defmacro dired-save-excursion (&rest body) | |
703 ;; Saves excursions of the point (not buffer) in dired buffers. | |
704 ;; It tries to be robust against deletion of the region about the point. | |
705 ;; Note that this assumes only dired-style deletions. | |
706 (let ((temp-bolm (make-symbol "bolm")) | |
707 (temp-fnlp (make-symbol "fnlp")) | |
708 (temp-offset-bol (make-symbol "offset-bol"))) | |
709 (` (let (((, temp-bolm) (make-marker)) | |
710 (, temp-fnlp) (, temp-offset-bol)) | |
711 (let ((bol (save-excursion (skip-chars-backward "^\n\r") (point)))) | |
712 (set-marker (, temp-bolm) bol) | |
713 (setq (, temp-offset-bol) (- (point) bol) | |
714 (, temp-fnlp) (memq (char-after bol) '(?\n\ ?\r)))) | |
715 (unwind-protect | |
716 (progn | |
717 (,@ body)) | |
718 ;; Use the marker to try to find the right line, then move to | |
719 ;; the proper column. | |
720 (goto-char (, temp-bolm)) | |
721 (and (not (, temp-fnlp)) | |
722 (not (eq (following-char) 0)) (memq (following-char) '(?\n ?\r)) | |
723 ;; The line containing the point got deleted. Note that this | |
724 ;; logic only works if we don't delete null lines, but we never | |
725 ;; do. | |
726 (forward-line 1)) ; don't move into a hidden line. | |
727 (skip-chars-forward "^\n\r" (+ (point) (, temp-offset-bol)))))))) | |
728 | |
729 (put 'dired-save-excursion 'lisp-indent-hook 0) | |
730 | |
731 (defun dired-substitute-marker (pos old new) | |
732 ;; Change marker, re-fontify | |
733 (subst-char-in-region pos (1+ pos) old new) | |
734 (dired-move-to-filename)) | |
735 | |
736 (defmacro dired-mark-if (predicate msg) | |
737 ;; Mark all files for which CONDITION evals to non-nil. | |
738 ;; CONDITION is evaluated on each line, with point at beginning of line. | |
739 ;; MSG is a noun phrase for the type of files being marked. | |
740 ;; It should end with a noun that can be pluralized by adding `s'. | |
741 ;; Return value is the number of files marked, or nil if none were marked. | |
742 (let ((temp-pt (make-symbol "pt")) | |
743 (temp-count (make-symbol "count")) | |
744 (temp-msg (make-symbol "msg"))) | |
745 (` (let (((, temp-msg) (, msg)) | |
746 ((, temp-count) 0) | |
747 (, temp-pt) buffer-read-only) | |
748 (save-excursion | |
749 (if (, temp-msg) (message "Marking %ss..." (, temp-msg))) | |
750 (goto-char (point-min)) | |
751 (while (not (eobp)) | |
752 (if (and (, predicate) | |
753 (not (char-equal (following-char) dired-marker-char))) | |
754 (progn | |
755 ;; Doing this rather than delete-char, insert | |
756 ;; avoids re-computing markers | |
757 (setq (, temp-pt) (point)) | |
758 (dired-substitute-marker | |
759 (, temp-pt) | |
760 (following-char) dired-marker-char) | |
761 (setq (, temp-count) (1+ (, temp-count))))) | |
762 (forward-line 1)) | |
763 (if (, temp-msg) | |
764 (message "%s %s%s %s%s." | |
765 (, temp-count) | |
766 (, temp-msg) | |
767 (dired-plural-s (, temp-count)) | |
768 (if (eq dired-marker-char ?\040) "un" "") | |
769 (if (eq dired-marker-char dired-del-marker) | |
770 "flagged" "marked")))) | |
771 (and (> (, temp-count) 0) (, temp-count)))))) | |
772 | |
773 (defmacro dired-map-over-marks (body arg &optional show-progress) | |
774 ;; Perform BODY with point somewhere on each marked line | |
775 ;; and return a list of BODY's results. | |
776 ;; If no marked file could be found, execute BODY on the current line. | |
777 ;; If ARG is an integer, use the next ARG (or previous -ARG, if ARG<0) | |
778 ;; files instead of the marked files. | |
779 ;; If ARG is t, only apply to marked files. If there are no marked files, | |
780 ;; the result is a noop. | |
781 ;; If ARG is otherwise non-nil, use current file instead. | |
782 ;; If optional third arg SHOW-PROGRESS evaluates to non-nil, | |
783 ;; redisplay the dired buffer after each file is processed. | |
784 ;; No guarantee is made about the position on the marked line. | |
785 ;; BODY must ensure this itself if it depends on this. | |
786 ;; Search starts at the beginning of the buffer, thus the car of the list | |
787 ;; corresponds to the line nearest to the buffer's bottom. This | |
788 ;; is also true for (positive and negative) integer values of ARG. | |
789 ;; To avoid code explosion, BODY should not be too long as it is | |
790 ;; expanded four times. | |
791 ;; | |
792 ;; Warning: BODY must not add new lines before point - this may cause an | |
793 ;; endless loop. | |
794 ;; This warning should not apply any longer, sk 2-Sep-1991 14:10. | |
795 (let ((temp-found (make-symbol "found")) | |
796 (temp-results (make-symbol "results")) | |
797 (temp-regexp (make-symbol "regexp")) | |
798 (temp-curr-pt (make-symbol "curr-pt")) | |
799 (temp-next-position (make-symbol "next-position"))) | |
800 (` (let (buffer-read-only case-fold-search (, temp-found) (, temp-results)) | |
801 (dired-save-excursion | |
802 (if (and (, arg) (not (eq (, arg) t))) | |
803 (if (integerp (, arg)) | |
804 (and (not (zerop (, arg))) | |
805 (progn;; no save-excursion, want to move point. | |
806 (dired-repeat-over-lines | |
807 arg | |
808 (function (lambda () | |
809 (if (, show-progress) (sit-for 0)) | |
810 (setq (, temp-results) | |
811 (cons (, body) | |
812 (, temp-results)))))) | |
813 (if (< (, arg) 0) | |
814 (nreverse (, temp-results)) | |
815 (, temp-results)))) | |
816 ;; non-nil, non-integer ARG means use current file: | |
817 (list (, body))) | |
818 (let (((, temp-regexp) | |
819 (concat "^" (regexp-quote (char-to-string | |
820 dired-marker-char)))) | |
821 (, temp-curr-pt) (, temp-next-position)) | |
822 (save-excursion | |
823 (goto-char (point-min)) | |
824 ;; remember position of next marked file before BODY | |
825 ;; can insert lines before the just found file, | |
826 ;; confusing us by finding the same marked file again | |
827 ;; and again and... | |
828 (setq (, temp-next-position) | |
829 (and (re-search-forward (, temp-regexp) nil t) | |
830 (point-marker)) | |
831 (, temp-found) (not (null (, temp-next-position)))) | |
832 (while (, temp-next-position) | |
833 (setq (, temp-curr-pt) (goto-char (, temp-next-position)) | |
834 ;; need to get next position BEFORE body | |
835 (, temp-next-position) | |
836 (and (re-search-forward (, temp-regexp) nil t) | |
837 (point-marker))) | |
838 (goto-char (, temp-curr-pt)) | |
839 (if (, show-progress) (sit-for 0)) | |
840 (setq (, temp-results) (cons (, body) (, temp-results))))) | |
841 (if (, temp-found) | |
842 (, temp-results) | |
843 ;; Do current file, unless arg is t | |
844 (and (not (eq (, arg) t)) | |
845 (list (, body))))))))))) | |
846 | |
847 ;;; General utility functions | |
848 | |
849 (defun dired-buffer-more-recently-used-p (buffer1 buffer2) | |
850 "Return t if BUFFER1 is more recently used than BUFFER2." | |
851 (if (equal buffer1 buffer2) | |
852 nil | |
853 (let ((more-recent nil) | |
854 (list (buffer-list))) | |
855 (while (and list | |
856 (not (setq more-recent (equal buffer1 (car list)))) | |
857 (not (equal buffer2 (car list)))) | |
858 (setq list (cdr list))) | |
859 more-recent))) | |
860 | |
861 (defun dired-file-modtime (file) | |
862 ;; Return the modtime of FILE, which is assumed to be already expanded | |
863 ;; by expand-file-name. | |
864 (let ((handler (find-file-name-handler file 'dired-file-modtime))) | |
865 (if handler | |
866 (funcall handler 'dired-file-modtime file) | |
867 (nth 5 (file-attributes file))))) | |
868 | |
869 (defun dired-set-file-modtime (file alist) | |
870 ;; Set the modtime for FILE in the subdir alist ALIST. | |
871 (let ((handler (find-file-name-handler file 'dired-set-file-modtime))) | |
872 (if handler | |
873 (funcall handler 'dired-set-file-modtime file alist) | |
874 (let ((elt (assoc file alist))) | |
875 (if elt | |
876 (setcar (nthcdr 4 elt) (nth 5 (file-attributes file)))))))) | |
877 | |
878 (defun dired-map-over-marks-check (fun arg op-symbol operation | |
879 &optional show-progress no-confirm) | |
880 ;; Map FUN over marked files (with second ARG like in dired-map-over-marks) | |
881 ;; and display failures. | |
882 | |
883 ;; FUN takes zero args. It returns non-nil (the offending object, e.g. | |
884 ;; the short form of the filename) for a failure and probably logs a | |
885 ;; detailed error explanation using function `dired-log'. | |
886 | |
887 ;; OP-SYMBOL is s symbol representing the operation. | |
888 ;; eg. 'compress | |
889 | |
890 ;; OPERATION is a string describing the operation performed (e.g. | |
891 ;; "Compress"). It is used with `dired-mark-pop-up' to prompt the user | |
892 ;; (e.g. with `Compress * [2 files]? ') and to display errors (e.g. | |
893 ;; `Failed to compress 1 of 2 files - type y to see why ("foo")') | |
894 | |
895 ;; SHOW-PROGRESS if non-nil means redisplay dired after each file. | |
896 | |
897 (if (or no-confirm (dired-mark-confirm op-symbol operation arg)) | |
898 (let* ((total-list;; all of FUN's return values | |
899 (dired-map-over-marks (funcall fun) arg show-progress)) | |
900 (total (length total-list)) | |
901 (failures (delq nil total-list)) | |
902 (count (length failures))) | |
903 (if (not failures) | |
904 (message "%s: %d file%s." operation total (dired-plural-s total)) | |
905 (message "Failed to %s %d of %d file%s - type y to see why %s" | |
906 operation count total (dired-plural-s total) | |
907 ;; this gives a short list of failed files in parens | |
908 ;; which may be sufficient for the user even | |
909 ;; without typing `W' for the process' diagnostics | |
910 failures) | |
911 ;; end this bunch of errors: | |
912 (dired-log-summary | |
913 (buffer-name (current-buffer)) | |
914 (format | |
915 "Failed to %s %d of %d file%s" | |
916 operation count total (dired-plural-s total)) | |
917 failures))))) | |
918 | |
919 (defun dired-make-switches-string (list) | |
920 ;; Converts a list of cracters to a string suitable for passing to ls. | |
921 (concat "-" (mapconcat 'char-to-string list ""))) | |
922 | |
923 (defun dired-make-switches-list (string) | |
924 ;; Converts a string of ls switches to a list of characters. | |
925 (delq ?- (mapcar 'identity string))) | |
926 | |
927 ;; Cloning replace-match to work on strings instead of in buffer: | |
928 ;; The FIXEDCASE parameter of replace-match is not implemented. | |
929 (defun dired-string-replace-match (regexp string newtext | |
930 &optional literal global) | |
931 ;; Replace first match of REGEXP in STRING with NEWTEXT. | |
932 ;; If it does not match, nil is returned instead of the new string. | |
933 ;; Optional arg LITERAL means to take NEWTEXT literally. | |
934 ;; Optional arg GLOBAL means to replace all matches. | |
935 (if global | |
936 (let ((result "") (start 0) mb me) | |
937 (while (string-match regexp string start) | |
938 (setq mb (match-beginning 0) | |
939 me (match-end 0) | |
940 result (concat result | |
941 (substring string start mb) | |
942 (if literal | |
943 newtext | |
944 (dired-expand-newtext string newtext))) | |
945 start me)) | |
946 (if mb ; matched at least once | |
947 (concat result (substring string start)) | |
948 nil)) | |
949 ;; not GLOBAL | |
950 (if (not (string-match regexp string 0)) | |
951 nil | |
952 (concat (substring string 0 (match-beginning 0)) | |
953 (if literal newtext (dired-expand-newtext string newtext)) | |
954 (substring string (match-end 0)))))) | |
955 | |
956 (defun dired-expand-newtext (string newtext) | |
957 ;; Expand \& and \1..\9 (referring to STRING) in NEWTEXT, using match data. | |
958 ;; Note that in Emacs 18 match data are clipped to current buffer | |
959 ;; size...so the buffer should better not be smaller than STRING. | |
960 (let ((pos 0) | |
961 (len (length newtext)) | |
962 (expanded-newtext "")) | |
963 (while (< pos len) | |
964 (setq expanded-newtext | |
965 (concat expanded-newtext | |
966 (let ((c (aref newtext pos))) | |
967 (if (= ?\\ c) | |
968 (cond ((= ?\& (setq c | |
969 (aref newtext | |
970 (setq pos (1+ pos))))) | |
971 (substring string | |
972 (match-beginning 0) | |
973 (match-end 0))) | |
974 ((and (>= c ?1) (<= c ?9)) | |
975 ;; return empty string if N'th | |
976 ;; sub-regexp did not match: | |
977 (let ((n (- c ?0))) | |
978 (if (match-beginning n) | |
979 (substring string | |
980 (match-beginning n) | |
981 (match-end n)) | |
982 ""))) | |
983 (t | |
984 (char-to-string c))) | |
985 (char-to-string c))))) | |
986 (setq pos (1+ pos))) | |
987 expanded-newtext)) | |
988 | |
989 (defun dired-in-this-tree (file dir) | |
990 ;;Is FILE part of the directory tree starting at DIR? | |
991 (let ((len (length dir))) | |
992 (and (>= (length file) len) | |
993 (string-equal (substring file 0 len) dir)))) | |
994 | |
995 (defun dired-tree-lessp (dir1 dir2) | |
996 ;; Lexicographic order on pathname components, like `ls -lR': | |
997 ;; DIR1 < DIR2 iff DIR1 comes *before* DIR2 in an `ls -lR' listing, | |
998 ;; i.e., iff DIR1 is a (grand)parent dir of DIR2, | |
999 ;; or DIR1 and DIR2 are in the same parentdir and their last | |
1000 ;; components are string-lessp. | |
1001 ;; Thus ("/usr/" "/usr/bin") and ("/usr/a/" "/usr/b/") are tree-lessp. | |
1002 ;; string-lessp could arguably be replaced by file-newer-than-file-p | |
1003 ;; if dired-internal-switches contained `t'. | |
1004 (let ((dir1 (file-name-as-directory dir1)) | |
1005 (dir2 (file-name-as-directory dir2)) | |
1006 (start1 1) | |
1007 (start2 1) | |
1008 comp1 comp2 end1 end2) | |
1009 (while (progn | |
1010 (setq end1 (string-match "/" dir1 start1) | |
1011 comp1 (substring dir1 start1 end1) | |
1012 end2 (string-match "/" dir2 start2) | |
1013 comp2 (substring dir2 start2 end2)) | |
1014 (and end1 end2 (string-equal comp1 comp2))) | |
1015 (setq start1 (1+ end1) | |
1016 start2 (1+ end2))) | |
1017 (if (eq (null end1) (null end2)) | |
1018 (string-lessp comp1 comp2) | |
1019 (null end1)))) | |
1020 | |
1021 ;; So that we can support case-insensitive systems. | |
1022 (fset 'dired-file-name-lessp 'string-lessp) | |
1023 | |
1024 | |
1025 ;;;; ------------------------------------------------------------------ | |
1026 ;;;; Initializing Dired | |
1027 ;;;; ------------------------------------------------------------------ | |
1028 | |
1029 ;;; Set the minor mode alist | |
1030 | |
1031 (or (equal (assq 'dired-sort-mode minor-mode-alist) | |
1032 '(dired-sort-mode dired-sort-mode)) | |
1033 ;; Test whether this has already been done in case dired is reloaded | |
1034 ;; There may be several elements with dired-sort-mode as car. | |
1035 (setq minor-mode-alist | |
1036 ;; cons " Omit" in first, so that it doesn't | |
1037 ;; get stuck between the directory and sort mode on the | |
1038 ;; mode line. | |
1039 (cons '(dired-sort-mode dired-sort-mode) | |
1040 (cons '(dired-subdir-omit " Omit") | |
1041 (cons '(dired-marker-stack dired-marker-string) | |
1042 minor-mode-alist))))) | |
1043 | |
1044 ;;; Keymaps | |
1045 | |
1046 (defvar dired-mode-map nil | |
1047 "Local keymap for dired-mode buffers.") | |
1048 (defvar dired-regexp-map nil | |
1049 "Dired keymap for commands that use regular expressions.") | |
1050 (defvar dired-diff-map nil | |
1051 "Dired keymap for diff and related commands.") | |
1052 (defvar dired-subdir-map nil | |
1053 "Dired keymap for commands that act on subdirs, or the files within them.") | |
1054 | |
1055 (defvar dired-keymap-grokked nil | |
1056 "Set to t after dired has grokked the global keymap.") | |
1057 | |
1058 (defun dired-key-description (cmd &rest prefixes) | |
1059 ;; Return a key description string for a menu. If prefixes are given, | |
1060 ;; they should be either strings, integers, or 'universal-argument. | |
1061 (let ((key (where-is-internal cmd dired-mode-map t))) | |
1062 (if key | |
1063 (key-description | |
1064 (apply 'vconcat | |
1065 (append | |
1066 (mapcar | |
1067 (function | |
1068 (lambda (x) | |
1069 (cond ((eq x 'universal-argument) | |
1070 (where-is-internal 'universal-argument | |
1071 dired-mode-map t)) | |
1072 ((integerp x) (int-to-string x)) | |
1073 (t x)))) | |
1074 prefixes) | |
1075 (list key)))) | |
1076 ""))) | |
1077 | |
1078 (defun dired-grok-keys (to-command from-command) | |
1079 ;; Assigns to TO-COMMAND the keys for the global binding of FROM-COMMAND. | |
1080 ;; Does not clobber anything in the local keymap. In emacs 19 should | |
1081 ;; use substitute-key-definition, but I believe that this will | |
1082 ;; clobber things in the local map. | |
1083 (let ((keys (where-is-internal from-command))) | |
1084 (while keys | |
1085 (condition-case nil | |
1086 (if (eq (global-key-binding (car keys)) (key-binding (car keys))) | |
1087 (local-set-key (car keys) to-command)) | |
1088 (error nil)) | |
1089 (setq keys (cdr keys))))) | |
1090 | |
1091 (defun dired-grok-keymap () | |
1092 ;; Initialize the dired keymaps. | |
1093 ;; This is actually done the first time that dired-mode runs. | |
1094 ;; We do it this late, to be sure that the user's global-keymap has | |
1095 ;; stabilized. | |
1096 (if dired-keymap-grokked | |
1097 () ; we've done it | |
1098 ;; Watch out for dired being invoked from the command line. | |
1099 ;; This is a bit kludgy, but so is the emacs startup sequence IMHO. | |
1100 (if (and term-setup-hook (boundp 'command-line-args-left)) | |
1101 (progn | |
1102 (if (string-equal "18." (substring emacs-version 0 3)) | |
1103 (funcall term-setup-hook) | |
1104 (run-hooks 'term-setup-hook)) | |
1105 (setq term-setup-hook nil))) | |
1106 (setq dired-keymap-grokked t) | |
1107 (run-hooks 'dired-setup-keys-hook) | |
1108 (dired-grok-keys 'dired-next-line 'next-line) | |
1109 (dired-grok-keys 'dired-previous-line 'previous-line) | |
1110 (dired-grok-keys 'dired-undo 'undo) | |
1111 (dired-grok-keys 'dired-undo 'advertised-undo) | |
1112 (dired-grok-keys 'dired-scroll-up 'scroll-up) | |
1113 (dired-grok-keys 'dired-scroll-down 'scroll-down) | |
1114 (dired-grok-keys 'dired-beginning-of-buffer 'beginning-of-buffer) | |
1115 (dired-grok-keys 'dired-end-of-buffer 'end-of-buffer) | |
1116 (dired-grok-keys 'dired-next-subdir 'forward-paragraph) | |
1117 (dired-grok-keys 'dired-prev-subdir 'backward-paragraph))) | |
1118 | |
1119 ;; The regexp-map is used for commands using regexp's. | |
1120 (if dired-regexp-map | |
1121 () | |
1122 (setq dired-regexp-map (make-sparse-keymap)) | |
1123 (define-key dired-regexp-map "C" 'dired-do-copy-regexp) | |
1124 ;; Not really a regexp, but does transform file names. | |
1125 (define-key dired-regexp-map "D" 'dired-downcase) | |
1126 (define-key dired-regexp-map "H" 'dired-do-hardlink-regexp) | |
1127 (define-key dired-regexp-map "R" 'dired-do-rename-regexp) | |
1128 (define-key dired-regexp-map "S" 'dired-do-symlink-regexp) | |
1129 (define-key dired-regexp-map "U" 'dired-upcase) | |
1130 (define-key dired-regexp-map "Y" 'dired-do-relsymlink-regexp) | |
1131 (define-key dired-regexp-map "c" 'dired-cleanup) | |
1132 (define-key dired-regexp-map "d" 'dired-flag-files-regexp) | |
1133 (define-key dired-regexp-map "e" 'dired-mark-extension) | |
1134 (define-key dired-regexp-map "m" 'dired-mark-files-regexp) | |
1135 (define-key dired-regexp-map "o" 'dired-add-omit-regexp) | |
1136 (define-key dired-regexp-map "x" 'dired-flag-extension)) ; a string, rather | |
1137 ; than a regexp. | |
1138 | |
1139 (if dired-diff-map | |
1140 () | |
1141 (setq dired-diff-map (make-sparse-keymap)) | |
1142 (define-key dired-diff-map "d" 'dired-diff) | |
1143 (define-key dired-diff-map "b" 'dired-backup-diff) | |
1144 (define-key dired-diff-map "m" 'dired-emerge) | |
1145 (define-key dired-diff-map "a" 'dired-emerge-with-ancestor) | |
1146 (define-key dired-diff-map "e" 'dired-ediff) | |
1147 (define-key dired-diff-map "p" 'dired-epatch)) | |
1148 | |
1149 (if dired-subdir-map | |
1150 () | |
1151 (setq dired-subdir-map (make-sparse-keymap)) | |
1152 (define-key dired-subdir-map "n" 'dired-redisplay-subdir) | |
1153 (define-key dired-subdir-map "m" 'dired-mark-subdir-files) | |
1154 (define-key dired-subdir-map "d" 'dired-flag-subdir-files) | |
1155 (define-key dired-subdir-map "z" 'dired-compress-subdir-files)) | |
1156 | |
1157 (fset 'dired-regexp-prefix dired-regexp-map) | |
1158 (fset 'dired-diff-prefix dired-diff-map) | |
1159 (fset 'dired-subdir-prefix dired-subdir-map) | |
1160 (fset 'efs-dired-prefix (function (lambda () | |
1161 (interactive) | |
1162 (error "efs-dired not loaded yet")))) | |
1163 | |
1164 ;; the main map | |
1165 (if dired-mode-map | |
1166 nil | |
1167 ;; Force `f' rather than `e' in the mode doc: | |
1168 (fset 'dired-advertised-find-file 'dired-find-file) | |
1169 (fset 'dired-advertised-next-subdir 'dired-next-subdir) | |
1170 (fset 'dired-advertised-prev-subdir 'dired-prev-subdir) | |
1171 (setq dired-mode-map (make-keymap)) | |
1172 (suppress-keymap dired-mode-map) | |
1173 ;; Commands to mark certain categories of files | |
1174 (define-key dired-mode-map "~" 'dired-flag-backup-files) | |
1175 (define-key dired-mode-map "#" 'dired-flag-auto-save-files) | |
1176 (define-key dired-mode-map "*" 'dired-mark-executables) | |
1177 (define-key dired-mode-map "." 'dired-clean-directory) | |
1178 (define-key dired-mode-map "/" 'dired-mark-directories) | |
1179 (define-key dired-mode-map "@" 'dired-mark-symlinks) | |
1180 (define-key dired-mode-map "," 'dired-mark-rcs-files) | |
1181 (define-key dired-mode-map "\M-(" 'dired-mark-sexp) | |
1182 (define-key dired-mode-map "\M-d" 'dired-mark-files-from-other-dired-buffer) | |
1183 (define-key dired-mode-map "\M-c" 'dired-mark-files-compilation-buffer) | |
1184 ;; Upper case keys (except ! and &) for operating on the marked files | |
1185 (define-key dired-mode-map "A" 'dired-do-tags-search) | |
1186 (define-key dired-mode-map "B" 'dired-do-byte-compile) | |
1187 (define-key dired-mode-map "C" 'dired-do-copy) | |
1188 (define-key dired-mode-map "E" 'dired-do-grep) | |
1189 (define-key dired-mode-map "F" 'dired-do-find-file) | |
1190 (define-key dired-mode-map "G" 'dired-do-chgrp) | |
1191 (define-key dired-mode-map "H" 'dired-do-hardlink) | |
1192 (define-key dired-mode-map "I" 'dired-do-insert-subdir) | |
1193 (define-key dired-mode-map "K" 'dired-do-kill-file-lines) | |
1194 (define-key dired-mode-map "L" 'dired-do-load) | |
1195 (define-key dired-mode-map "M" 'dired-do-chmod) | |
1196 (define-key dired-mode-map "N" 'dired-do-redisplay) | |
1197 (define-key dired-mode-map "O" 'dired-do-chown) | |
1198 (define-key dired-mode-map "P" 'dired-do-print) | |
1199 (define-key dired-mode-map "Q" 'dired-do-tags-query-replace) | |
1200 (define-key dired-mode-map "R" 'dired-do-rename) | |
1201 (define-key dired-mode-map "S" 'dired-do-symlink) | |
1202 (define-key dired-mode-map "T" 'dired-do-total-size) | |
1203 (define-key dired-mode-map "U" 'dired-do-uucode) | |
1204 (define-key dired-mode-map "W" 'dired-copy-filenames-as-kill) | |
1205 (define-key dired-mode-map "X" 'dired-do-delete) | |
1206 (define-key dired-mode-map "Y" 'dired-do-relsymlink) | |
1207 (define-key dired-mode-map "Z" 'dired-do-compress) | |
1208 (define-key dired-mode-map "!" 'dired-do-shell-command) | |
1209 (define-key dired-mode-map "&" 'dired-do-background-shell-command) | |
1210 ;; Make all regexp commands share a `%' prefix: | |
1211 (define-key dired-mode-map "%" 'dired-regexp-prefix) | |
1212 ;; Lower keys for commands not operating on all the marked files | |
1213 (define-key dired-mode-map "a" 'dired-apropos) | |
1214 (define-key dired-mode-map "c" 'dired-change-marks) | |
1215 (define-key dired-mode-map "d" 'dired-flag-file-deletion) | |
1216 (define-key dired-mode-map "\C-d" 'dired-flag-file-deletion-backup) | |
1217 (define-key dired-mode-map "e" 'dired-find-file) | |
1218 (define-key dired-mode-map "f" 'dired-advertised-find-file) | |
1219 (define-key dired-mode-map "g" 'revert-buffer) | |
1220 (define-key dired-mode-map "h" 'dired-describe-mode) | |
1221 (define-key dired-mode-map "i" 'dired-maybe-insert-subdir) | |
1222 (define-key dired-mode-map "k" 'dired-kill-subdir) | |
1223 (define-key dired-mode-map "m" 'dired-mark) | |
1224 (define-key dired-mode-map "o" 'dired-find-file-other-window) | |
1225 (define-key dired-mode-map "q" 'dired-quit) | |
1226 (define-key dired-mode-map "r" 'dired-read-mail) | |
1227 (define-key dired-mode-map "s" 'dired-sort-toggle-or-edit) | |
1228 (define-key dired-mode-map "t" 'dired-get-target-directory) | |
1229 (define-key dired-mode-map "u" 'dired-unmark) | |
1230 (define-key dired-mode-map "v" 'dired-view-file) | |
1231 (define-key dired-mode-map "w" (if (fboundp 'find-file-other-frame) | |
1232 'dired-find-file-other-frame | |
1233 'dired-find-file-other-window)) | |
1234 (define-key dired-mode-map "x" 'dired-expunge-deletions) | |
1235 (define-key dired-mode-map "y" 'dired-why) | |
1236 (define-key dired-mode-map "+" 'dired-create-directory) | |
1237 (define-key dired-mode-map "`" 'dired-recover-file) | |
1238 ;; dired-jump-back Should be in the global map, but put them here | |
1239 ;; too anyway. | |
1240 (define-key dired-mode-map "\C-x\C-j" 'dired-jump-back) | |
1241 (define-key dired-mode-map "\C-x4\C-j" 'dired-jump-back-other-window) | |
1242 (define-key dired-mode-map "\C-x5\C-j" 'dired-jump-back-other-frame) | |
1243 ;; Comparison commands | |
1244 (define-key dired-mode-map "=" 'dired-diff-prefix) | |
1245 ;; moving | |
1246 (define-key dired-mode-map "<" 'dired-prev-dirline) | |
1247 (define-key dired-mode-map ">" 'dired-next-dirline) | |
1248 (define-key dired-mode-map " " 'dired-next-line) | |
1249 (define-key dired-mode-map "n" 'dired-next-line) | |
1250 (define-key dired-mode-map "\C-n" 'dired-next-line) | |
1251 (define-key dired-mode-map "p" 'dired-previous-line) | |
1252 (define-key dired-mode-map "\C-p" 'dired-previous-line) | |
1253 (define-key dired-mode-map "\C-v" 'dired-scroll-up) | |
1254 (define-key dired-mode-map "\M-v" 'dired-scroll-down) | |
1255 (define-key dired-mode-map "\M-<" 'dired-beginning-of-buffer) | |
1256 (define-key dired-mode-map "\M->" 'dired-end-of-buffer) | |
1257 ;; This is silly, I'm changing it. -sb | |
1258 ;; (define-key dired-mode-map "\C-m" 'dired-goto-file) | |
1259 (define-key dired-mode-map "\C-m" 'dired-advertised-find-file) | |
1260 ;; motion by subdirectories | |
1261 (define-key dired-mode-map "^" 'dired-up-directory) | |
1262 (define-key dired-mode-map "\M-\C-u" 'dired-up-directory) | |
1263 (define-key dired-mode-map "\M-\C-d" 'dired-down-directory) | |
1264 (define-key dired-mode-map "\M-\C-n" 'dired-advertised-next-subdir) | |
1265 (define-key dired-mode-map "\M-\C-p" 'dired-advertised-prev-subdir) | |
1266 (define-key dired-mode-map "\C-j" 'dired-goto-subdir) | |
1267 ;; move to marked files | |
1268 (define-key dired-mode-map "\M-p" 'dired-prev-marked-file) | |
1269 (define-key dired-mode-map "\M-n" 'dired-next-marked-file) | |
1270 ;; hiding | |
1271 (define-key dired-mode-map "$" 'dired-hide-subdir) | |
1272 (define-key dired-mode-map "\M-$" 'dired-hide-all) | |
1273 ;; omitting | |
1274 (define-key dired-mode-map "\C-o" 'dired-omit-toggle) | |
1275 ;; markers | |
1276 (define-key dired-mode-map "\(" 'dired-set-marker-char) | |
1277 (define-key dired-mode-map "\)" 'dired-restore-marker-char) | |
1278 (define-key dired-mode-map "'" 'dired-marker-stack-left) | |
1279 (define-key dired-mode-map "\\" 'dired-marker-stack-right) | |
1280 ;; misc | |
1281 (define-key dired-mode-map "\C-i" 'dired-mark-prefix) | |
1282 (define-key dired-mode-map "?" 'dired-summary) | |
1283 (define-key dired-mode-map "\177" 'dired-backup-unflag) | |
1284 (define-key dired-mode-map "\C-_" 'dired-undo) | |
1285 (define-key dired-mode-map "\C-xu" 'dired-undo) | |
1286 (define-key dired-mode-map "\M-\C-?" 'dired-unmark-all-files) | |
1287 ;; The subdir map | |
1288 (define-key dired-mode-map "|" 'dired-subdir-prefix) | |
1289 ;; efs submap | |
1290 (define-key dired-mode-map "\M-e" 'efs-dired-prefix)) | |
1291 | |
1292 | |
1293 | |
1294 ;;;;------------------------------------------------------------------ | |
1295 ;;;; The dired command | |
1296 ;;;;------------------------------------------------------------------ | |
1297 | |
1298 ;;; User commands: | |
1299 ;;; All of these commands should have a binding in the global keymap. | |
1300 | |
1301 ;;;###autoload (define-key ctl-x-map "d" 'dired) | |
1302 ;;;###autoload | |
1303 (defun dired (dirname &optional switches) | |
1304 "\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. | |
1305 Optional second argument SWITCHES specifies the `ls' options used. | |
1306 \(Interactively, use a prefix argument to be able to specify SWITCHES.) | |
1307 Dired displays a list of files in DIRNAME (which may also have | |
1308 shell wildcards appended to select certain files). If DIRNAME is a cons, | |
1309 its first element is taken as the directory name and the resr as an explicit | |
1310 list of files to make directory entries for. | |
1311 \\<dired-mode-map>\ | |
1312 You can move around in it with the usual commands. | |
1313 You can flag files for deletion with \\[dired-flag-file-deletion] and then | |
1314 delete them by typing \\[dired-expunge-deletions]. | |
1315 Type \\[dired-describe-mode] after entering dired for more info. | |
1316 | |
1317 If DIRNAME is already in a dired buffer, that buffer is used without refresh." | |
1318 ;; Cannot use (interactive "D") because of wildcards. | |
1319 (interactive (dired-read-dir-and-switches "")) | |
1320 (switch-to-buffer (dired-noselect dirname switches))) | |
1321 | |
1322 ;;;###autoload (define-key ctl-x-4-map "d" 'dired-other-window) | |
1323 ;;;###autoload | |
1324 (defun dired-other-window (dirname &optional switches) | |
1325 "\"Edit\" directory DIRNAME. Like `dired' but selects in another window." | |
1326 (interactive (dired-read-dir-and-switches "in other window ")) | |
1327 (switch-to-buffer-other-window (dired-noselect dirname switches))) | |
1328 | |
1329 ;;;###autoload (define-key ctl-x-5-map "d" 'dired-other-frame) | |
1330 ;;;###autoload | |
1331 (defun dired-other-frame (dirname &optional switches) | |
1332 "\"Edit\" directory DIRNAME. Like `dired' but makes a new frame." | |
1333 (interactive (dired-read-dir-and-switches "in other frame ")) | |
1334 (switch-to-buffer-other-frame (dired-noselect dirname switches))) | |
1335 | |
1336 ;;;###autoload | |
1337 (defun dired-noselect (dir-or-list &optional switches) | |
1338 "Like `dired' but returns the dired buffer as value, does not select it." | |
1339 (or dir-or-list (setq dir-or-list (expand-file-name default-directory))) | |
1340 ;; This loses the distinction between "/foo/*/" and "/foo/*" that | |
1341 ;; some shells make: | |
1342 (let (dirname) | |
1343 (if (consp dir-or-list) | |
1344 (setq dirname (car dir-or-list)) | |
1345 (setq dirname dir-or-list)) | |
1346 (setq dirname (expand-file-name (directory-file-name dirname))) | |
1347 (if (file-directory-p dirname) | |
1348 (setq dirname (file-name-as-directory dirname))) | |
1349 (if (consp dir-or-list) | |
1350 (setq dir-or-list (cons dirname (cdr dir-or-list))) | |
1351 (setq dir-or-list dirname)) | |
1352 (dired-internal-noselect dir-or-list switches))) | |
1353 | |
1354 ;; Adapted from code by wurgler@zippysun.math.uakron.edu (Tom Wurgler). | |
1355 ;;;###autoload (define-key ctl-x-map "\C-j" 'dired-jump-back) | |
1356 ;;;###autoload | |
1357 (defun dired-jump-back () | |
1358 "Jump back to dired. | |
1359 If in a file, dired the current directory and move to file's line. | |
1360 If in dired already, pop up a level and goto old directory's line. | |
1361 In case the proper dired file line cannot be found, refresh the dired | |
1362 buffer and try again." | |
1363 (interactive) | |
1364 (let* ((file (if (eq major-mode 'dired-mode) | |
1365 (directory-file-name (dired-current-directory)) | |
1366 buffer-file-name)) | |
1367 (dir (if file | |
1368 (file-name-directory file) | |
1369 default-directory))) | |
1370 (dired dir) | |
1371 (if file (dired-really-goto-file file)))) | |
1372 | |
1373 ;;;###autoload (define-key ctl-x-4-map "\C-j" 'dired-jump-back-other-window) | |
1374 ;;;###autoload | |
1375 (defun dired-jump-back-other-window () | |
1376 "Like \\[dired-jump-back], but to other window." | |
1377 (interactive) | |
1378 (let* ((file (if (eq major-mode 'dired-mode) | |
1379 (directory-file-name (dired-current-directory)) | |
1380 buffer-file-name)) | |
1381 (dir (if file | |
1382 (file-name-directory file) | |
1383 default-directory))) | |
1384 (dired-other-window dir) | |
1385 (if file (dired-really-goto-file file)))) | |
1386 | |
1387 ;;;###autoload (define-key ctl-x-5-map "\C-j" 'dired-jump-back-other-frame) | |
1388 ;;;###autoload | |
1389 (defun dired-jump-back-other-frame () | |
1390 "Like \\[dired-jump-back], but in another frame." | |
1391 (interactive) | |
1392 (let* ((file (if (eq major-mode 'dired-mode) | |
1393 (directory-file-name (dired-current-directory)) | |
1394 buffer-file-name)) | |
1395 (dir (if file | |
1396 (file-name-directory file) | |
1397 default-directory))) | |
1398 (dired-other-frame dir) | |
1399 (if file (dired-really-goto-file file)))) | |
1400 | |
1401 ;;; Dired mode | |
1402 | |
1403 ;; Dired mode is suitable only for specially formatted data. | |
1404 (put 'dired-mode 'mode-class 'special) | |
1405 | |
1406 (defun dired-mode (&optional dirname switches) | |
1407 "\\<dired-mode-map>Dired mode is for \"editing\" directory trees. | |
1408 | |
1409 For a simple one-line help message, type \\[dired-summary] | |
1410 For a moderately detailed description of dired mode, type \\[dired-describe-mode] | |
1411 For the full dired info tree, type \\[universal-argument] \\[dired-describe-mode]" | |
1412 ;; Not to be called interactively (e.g. dired-directory will be set | |
1413 ;; to default-directory, which is wrong with wildcards). | |
1414 (kill-all-local-variables) | |
1415 (use-local-map dired-mode-map) | |
1416 (setq major-mode 'dired-mode | |
1417 mode-name "Dired" | |
1418 case-fold-search nil | |
1419 buffer-read-only t | |
1420 selective-display t ; for subdirectory hiding | |
1421 selective-display-ellipses nil ; for omit toggling | |
1422 mode-line-buffer-identification '("Dired: %12b") | |
1423 mode-line-modified (format dired-mode-line-modified "--" "--" "-") | |
1424 dired-directory (expand-file-name (or dirname default-directory)) | |
1425 dired-internal-switches (dired-make-switches-list | |
1426 (or switches dired-listing-switches))) | |
1427 (dired-advertise) ; default-directory is already set | |
1428 (set (make-local-variable 'revert-buffer-function) | |
1429 (function dired-revert)) | |
1430 (set (make-local-variable 'default-directory-function) | |
1431 'dired-current-directory) | |
1432 (set (make-local-variable 'page-delimiter) | |
1433 "\n\n") | |
1434 (set (make-local-variable 'list-buffers-directory) | |
1435 dired-directory) | |
1436 ;; Will only do something in Emacs 19. | |
1437 (add-hook (make-local-variable 'kill-buffer-hook) | |
1438 'dired-unadvertise-current-buffer) | |
1439 ;; Same here | |
1440 (if window-system | |
1441 (add-hook (make-local-variable 'post-command-hook) | |
1442 (function | |
1443 (lambda () | |
1444 (if (memq this-command dired-modeline-tracking-cmds) | |
1445 (dired-update-mode-line t)))))) | |
1446 (dired-sort-other dired-internal-switches t) | |
1447 (dired-hack-local-variables) | |
1448 (run-hooks 'dired-mode-hook) | |
1449 ;; Run this after dired-mode-hook, in case that hook makes changes to | |
1450 ;; the keymap. | |
1451 (dired-grok-keymap)) | |
1452 | |
1453 ;;; Internal functions for starting dired | |
1454 | |
1455 (defun dired-read-dir-and-switches (str) | |
1456 ;; For use in interactive. | |
1457 (reverse (list | |
1458 (if current-prefix-arg | |
1459 (read-string "Dired listing switches: " | |
1460 dired-listing-switches)) | |
1461 (let ((default-directory (default-directory))) | |
1462 (read-file-name (format "Dired %s(directory): " str) | |
1463 nil default-directory nil))))) | |
1464 | |
1465 (defun dired-hack-local-variables () | |
1466 "Parse, bind or evaluate any local variables for current dired buffer. | |
1467 See variable `dired-local-variables-file'." | |
1468 (if (and dired-local-variables-file | |
1469 (file-exists-p dired-local-variables-file)) | |
1470 (let (buffer-read-only opoint ) | |
1471 (save-excursion | |
1472 (goto-char (point-max)) | |
1473 (setq opoint (point-marker)) | |
1474 (insert "\^L\n") | |
1475 (insert-file-contents dired-local-variables-file)) | |
1476 (let ((buffer-file-name dired-local-variables-file)) | |
1477 (condition-case err | |
1478 (hack-local-variables) | |
1479 (error (message "Error in dired-local-variables-file: %s" err) | |
1480 (sit-for 1)))) | |
1481 ;; Must delete it as (eobp) is often used as test for last | |
1482 ;; subdir in dired.el. | |
1483 (delete-region opoint (point-max)) | |
1484 (set-marker opoint nil)))) | |
1485 | |
1486 ;; Separate function from dired-noselect for the sake of dired-vms.el. | |
1487 (defun dired-internal-noselect (dir-or-list &optional switches mode) | |
1488 ;; If there is an existing dired buffer for DIRNAME, just leave | |
1489 ;; buffer as it is (don't even call dired-revert). | |
1490 ;; This saves time especially for deep trees or with efs. | |
1491 ;; The user can type `g'easily, and it is more consistent with find-file. | |
1492 ;; But if SWITCHES are given they are probably different from the | |
1493 ;; buffer's old value, so call dired-sort-other, which does | |
1494 ;; revert the buffer. | |
1495 ;; If the user specifies a directory with emacs startup, eg. | |
1496 ;; emacs ~, dir-or-list may be unexpanded at this point. | |
1497 | |
1498 (let* ((dirname (expand-file-name (if (consp dir-or-list) | |
1499 (car dir-or-list) | |
1500 dir-or-list))) | |
1501 (buffer (dired-find-buffer-nocreate dir-or-list mode)) | |
1502 ;; note that buffer already is in dired-mode, if found | |
1503 (new-buffer-p (not buffer)) | |
1504 (old-buf (current-buffer)) | |
1505 wildcard) | |
1506 (or buffer | |
1507 (let ((default-major-mode 'fundamental-mode)) | |
1508 ;; We don't want default-major-mode to run hooks and set auto-fill | |
1509 ;; or whatever, now that dired-mode does not | |
1510 ;; kill-all-local-variables any longer. | |
1511 (setq buffer (create-file-buffer (directory-file-name dirname))))) | |
1512 (set-buffer buffer) | |
1513 (if (not new-buffer-p) ; existing buffer ... | |
1514 (progn | |
1515 (if switches | |
1516 (dired-sort-other | |
1517 (if (stringp switches) | |
1518 (dired-make-switches-list switches) | |
1519 switches))) | |
1520 (if dired-verify-modtimes (dired-verify-modtimes)) | |
1521 (if (and dired-find-subdir | |
1522 (not (string-equal (dired-current-directory) | |
1523 (file-name-as-directory dirname)))) | |
1524 (dired-initial-position dirname))) | |
1525 ;; Else a new buffer | |
1526 (if (file-directory-p dirname) | |
1527 (setq default-directory dirname | |
1528 wildcard (consp dir-or-list)) | |
1529 (setq default-directory (file-name-directory dirname) | |
1530 wildcard t)) | |
1531 (or switches (setq switches dired-listing-switches)) | |
1532 (dired-mode dirname switches) | |
1533 ;; default-directory and dired-internal-switches are set now | |
1534 ;; (buffer-local), so we can call dired-readin: | |
1535 (let ((failed t)) | |
1536 (unwind-protect | |
1537 (progn (dired-readin dir-or-list buffer wildcard) | |
1538 (setq failed nil)) | |
1539 ;; dired-readin can fail if parent directories are inaccessible. | |
1540 ;; Don't leave an empty buffer around in that case. | |
1541 (if failed (kill-buffer buffer)))) | |
1542 ;; No need to narrow since the whole buffer contains just | |
1543 ;; dired-readin's output, nothing else. The hook can | |
1544 ;; successfully use dired functions (e.g. dired-get-filename) | |
1545 ;; as the subdir-alist has been built in dired-readin. | |
1546 (run-hooks 'dired-after-readin-hook) | |
1547 ;; I put omit-expunge after the dired-after-readin-hook | |
1548 ;; in case that hook marks files. Does this make sense? Also, users | |
1549 ;; might want to set dired-omit-files-p in some incredibly clever | |
1550 ;; way depending on the contents of the directory... I don't know... | |
1551 (if dired-omit-files | |
1552 (dired-omit-expunge nil t)) | |
1553 (goto-char (point-min)) | |
1554 (dired-initial-position dirname)) | |
1555 (set-buffer old-buf) | |
1556 buffer)) | |
1557 | |
1558 (defun dired-find-buffer-nocreate (dir-or-list &optional mode) | |
1559 ;; Returns a dired buffer for DIR-OR-LIST. DIR-OR-LIST may be wildcard, | |
1560 ;; or a directory and alist of files. | |
1561 ;; If dired-find-subdir is non-nil, is satisfied with a dired | |
1562 ;; buffer containing DIR-OR-LIST as a subdirectory. If there is more | |
1563 ;; than one candidate, returns the most recently used. | |
1564 (if dired-find-subdir | |
1565 (let ((buffers (sort (delq (current-buffer) | |
1566 (dired-buffers-for-dir dir-or-list t)) | |
1567 (function dired-buffer-more-recently-used-p)))) | |
1568 (or (car buffers) | |
1569 ;; Couldn't find another buffer. Will the current one do? | |
1570 ;; It is up dired-initial-position to actually go to the subdir. | |
1571 (and (or (equal dir-or-list dired-directory) ; covers wildcards | |
1572 (and (stringp dir-or-list) | |
1573 (not (string-equal | |
1574 dir-or-list | |
1575 (expand-file-name default-directory))) | |
1576 (assoc (file-name-as-directory dir-or-list) | |
1577 dired-subdir-alist))) | |
1578 (current-buffer)))) | |
1579 ;; Else just look through the buffer list. | |
1580 (let (found (blist (buffer-list))) | |
1581 (or mode (setq mode 'dired-mode)) | |
1582 (save-excursion | |
1583 (while blist | |
1584 (set-buffer (car blist)) | |
1585 (if (and (eq major-mode mode) | |
1586 (equal dired-directory dir-or-list)) | |
1587 (setq found (car blist) | |
1588 blist nil) | |
1589 (setq blist (cdr blist))))) | |
1590 found))) | |
1591 | |
1592 (defun dired-initial-position (dirname) | |
1593 ;; Where point should go in a new listing of DIRNAME. | |
1594 ;; Point assumed at beginning of new subdir line. | |
1595 (end-of-line) | |
1596 (if dired-find-subdir (dired-goto-subdir dirname)) | |
1597 (if dired-trivial-filenames (dired-goto-next-nontrivial-file)) | |
1598 (dired-update-mode-line t)) | |
1599 | |
1600 (defun dired-readin (dir-or-list buffer &optional wildcard) | |
1601 ;; Read in a new dired buffer | |
1602 ;; dired-readin differs from dired-insert-subdir in that it accepts | |
1603 ;; wildcards, erases the buffer, and builds the subdir-alist anew | |
1604 ;; (including making it buffer-local and clearing it first). | |
1605 ;; default-directory and dired-internal-switches must be buffer-local | |
1606 ;; and initialized by now. | |
1607 ;; Thus we can test (equal default-directory dirname) instead of | |
1608 ;; (file-directory-p dirname) and save a filesystem transaction. | |
1609 ;; This is wrong, if dired-before-readin-hook changes default-directory | |
1610 ;; Also, we can run this hook which may want to modify the switches | |
1611 ;; based on default-directory, e.g. with efs to a SysV host | |
1612 ;; where ls won't understand -Al switches. | |
1613 (let (dirname other-dirs) | |
1614 (if (consp dir-or-list) | |
1615 (setq dir-or-list (dired-frob-dir-list dir-or-list) | |
1616 other-dirs (cdr dir-or-list) | |
1617 dir-or-list (car dir-or-list) | |
1618 dirname (car dir-or-list)) | |
1619 (setq dirname dir-or-list)) | |
1620 (setq dirname (expand-file-name dirname)) | |
1621 (if (consp dir-or-list) | |
1622 (setq dir-or-list (cons dirname (cdr dir-or-list)))) | |
1623 (save-excursion | |
1624 (set-buffer buffer) | |
1625 (run-hooks 'dired-before-readin-hook) | |
1626 (message "Reading directory %s..." dirname) | |
1627 (let (buffer-read-only) | |
1628 (widen) | |
1629 (erase-buffer) | |
1630 (dired-readin-insert dir-or-list wildcard) | |
1631 (dired-indent-listing (point-min) (point-max)) | |
1632 ;; We need this to make the root dir have a header line as all | |
1633 ;; other subdirs have: | |
1634 (goto-char (point-min)) | |
1635 (dired-insert-headerline (expand-file-name default-directory))) | |
1636 (message "Reading directory %s...done" dirname) | |
1637 (set-buffer-modified-p nil) | |
1638 ;; Must first make alist buffer local and set it to nil because | |
1639 ;; dired-build-subdir-alist will call dired-clear-alist first | |
1640 (setq dired-subdir-alist nil) | |
1641 (if (memq ?R dired-internal-switches) | |
1642 (dired-build-subdir-alist) | |
1643 ;; no need to parse the buffer if listing is not recursive | |
1644 (dired-simple-subdir-alist)) | |
1645 (if other-dirs | |
1646 (mapcar | |
1647 (function | |
1648 (lambda (x) | |
1649 (if (dired-in-this-tree (car x) dirname) | |
1650 (dired-insert-subdir x)))) | |
1651 other-dirs))))) | |
1652 | |
1653 ;;; Subroutines of dired-readin | |
1654 | |
1655 (defun dired-readin-insert (dir-or-list &optional wildcard) | |
1656 ;; Just insert listing for the passed-in directory or | |
1657 ;; directory-and-file list, assuming a clean buffer. | |
1658 (let* ((switches (dired-make-switches-string dired-internal-switches)) | |
1659 (dir-is-list (consp dir-or-list)) | |
1660 (dirname (if dir-is-list (car dir-or-list) dir-or-list))) | |
1661 (if wildcard | |
1662 (progn | |
1663 (or (file-readable-p | |
1664 (if dir-is-list | |
1665 dirname | |
1666 (directory-file-name (file-name-directory dirname)))) | |
1667 (error "Directory %s inaccessible or nonexistent" dirname)) | |
1668 ;; else assume it contains wildcards | |
1669 (dired-insert-directory dir-or-list switches t) | |
1670 (save-excursion | |
1671 ;; insert wildcard instead of total line: | |
1672 (goto-char (point-min)) | |
1673 (if dir-is-list | |
1674 (insert "list wildcard\n") | |
1675 (insert "wildcard " (file-name-nondirectory dirname) "\n")))) | |
1676 (dired-insert-directory dir-or-list switches nil t)))) | |
1677 | |
1678 (defun dired-insert-directory (dir-or-list switches &optional wildcard full-p) | |
1679 ;; Do the right thing whether dir-or-list is atomic or not. If it is, | |
1680 ;; insert all files listed in the cdr -- the car is the passed-in directory | |
1681 ;; list. | |
1682 (let ((opoint (point)) | |
1683 (insert-directory-program dired-ls-program)) | |
1684 (if (consp dir-or-list) | |
1685 (mapcar | |
1686 (function | |
1687 (lambda (x) | |
1688 (insert-directory x switches wildcard))) | |
1689 (cdr dir-or-list)) | |
1690 (insert-directory dir-or-list switches wildcard full-p)) | |
1691 (dired-insert-set-properties opoint (point))) | |
1692 (setq dired-directory dir-or-list)) | |
1693 | |
1694 (defun dired-frob-dir-list (dir-list) | |
1695 (let* ((top (file-name-as-directory (expand-file-name (car dir-list)))) | |
1696 (tail (cdr dir-list)) | |
1697 (result (list (list top))) | |
1698 elt dir) | |
1699 (setq tail | |
1700 (mapcar | |
1701 (function | |
1702 (lambda (x) | |
1703 (directory-file-name (expand-file-name x top)))) | |
1704 tail)) | |
1705 (while tail | |
1706 (setq dir (file-name-directory (car tail))) | |
1707 (if (setq elt (assoc dir result)) | |
1708 (nconc elt (list (car tail))) | |
1709 (nconc result (list (list dir (car tail))))) | |
1710 (setq tail (cdr tail))) | |
1711 result)) | |
1712 | |
1713 (defun dired-insert-headerline (dir);; also used by dired-insert-subdir | |
1714 ;; Insert DIR's headerline with no trailing slash, exactly like ls | |
1715 ;; would, and put cursor where dired-build-subdir-alist puts subdir | |
1716 ;; boundaries. | |
1717 (save-excursion (insert " " (directory-file-name dir) ":\n"))) | |
1718 | |
1719 (defun dired-verify-modtimes () | |
1720 ;; Check the modtimes of all subdirs. | |
1721 (let ((alist dired-subdir-alist) | |
1722 on-disk in-mem badies) | |
1723 (while alist | |
1724 (and (setq in-mem (nth 4 (car alist))) | |
1725 (setq on-disk (dired-file-modtime (car (car alist)))) | |
1726 (not (equal in-mem on-disk)) | |
1727 (setq badies (cons (cons (car (car alist)) | |
1728 (nth 3 (car alist))) | |
1729 badies))) | |
1730 (setq alist (cdr alist))) | |
1731 (and badies | |
1732 (let* ((ofile (dired-get-filename nil t)) | |
1733 (osub (and (null ofile) (dired-get-subdir))) | |
1734 (opoint (point)) | |
1735 (ocol (current-column))) | |
1736 (unwind-protect | |
1737 (and | |
1738 (or (memq 'revert-subdirs dired-no-confirm) | |
1739 (save-window-excursion | |
1740 (let ((flist (mapcar | |
1741 (function | |
1742 (lambda (f) | |
1743 (dired-abbreviate-file-name (car f)))) | |
1744 badies))) | |
1745 (switch-to-buffer (current-buffer)) | |
1746 (dired-mark-pop-up | |
1747 "*Stale Subdirectories*" 'revert-subdirs | |
1748 flist 'y-or-n-p | |
1749 (if (= (length flist) 1) | |
1750 (concat "Subdirectory " (car flist) | |
1751 " has changed on disk. Re-list? ") | |
1752 "Subdirectories have changed on disk. Re-list? ")) | |
1753 ))) | |
1754 (while badies | |
1755 (dired-insert-subdir (car (car badies)) | |
1756 (cdr (car badies)) nil t) | |
1757 (setq badies (cdr badies)))) | |
1758 ;; We can't use dired-save-excursion here, because we are | |
1759 ;; rewriting the entire listing, and not just changing a single | |
1760 ;; file line. | |
1761 (or (if ofile | |
1762 (dired-goto-file ofile) | |
1763 (if osub | |
1764 (dired-goto-subdir osub))) | |
1765 (progn | |
1766 (goto-char opoint) | |
1767 (beginning-of-line) | |
1768 (skip-chars-forward "^\n\r" (+ (point) ocol)))) | |
1769 (dired-update-mode-line t) | |
1770 (dired-update-mode-line-modified t)))))) | |
1771 | |
1772 (defun dired-indent-listing (start end) | |
1773 ;; Indent a dired listing. | |
1774 (let (indent-tabs-mode) | |
1775 (indent-rigidly start end 2) | |
1776 ;; Quote any null lines that shouldn't be. | |
1777 (save-excursion | |
1778 (goto-char start) | |
1779 (while (search-forward "\n\n" end t) | |
1780 (forward-char -2) | |
1781 (if (looking-at dired-subdir-regexp) | |
1782 (goto-char (match-end 3)) | |
1783 (progn | |
1784 (forward-char 1) | |
1785 (insert " "))))))) | |
1786 | |
1787 | |
1788 ;;;; ------------------------------------------------------------ | |
1789 ;;;; Reverting a dired buffer, or specific file lines within it. | |
1790 ;;;; ------------------------------------------------------------ | |
1791 | |
1792 (defun dired-revert (&optional arg noconfirm) | |
1793 ;; Reread the dired buffer. Must also be called after | |
1794 ;; dired-internal-switches have changed. | |
1795 ;; Should not fail even on completely garbaged buffers. | |
1796 ;; Preserves old cursor, marks/flags, hidden-p. | |
1797 (widen) ; just in case user narrowed | |
1798 (let ((opoint (point)) | |
1799 (ofile (dired-get-filename nil t)) | |
1800 (hidden-subdirs (dired-remember-hidden)) | |
1801 ;; switches for top-level dir | |
1802 (oswitches (or (nth 3 (nth (1- (length dired-subdir-alist)) | |
1803 dired-subdir-alist)) | |
1804 (delq ?R (copy-sequence dired-internal-switches)))) | |
1805 ;; all other subdirs | |
1806 (old-subdir-alist (cdr (reverse dired-subdir-alist))) | |
1807 (omitted-subdirs (dired-remember-omitted)) | |
1808 ;; do this after dired-remember-hidden, since this unhides | |
1809 (mark-alist (dired-remember-marks (point-min) (point-max))) | |
1810 (kill-files-p (save-excursion | |
1811 (goto-char (point)) | |
1812 (search-forward | |
1813 (concat (char-to-string ?\r) | |
1814 (regexp-quote | |
1815 (char-to-string | |
1816 dired-kill-marker-char))) | |
1817 nil t))) | |
1818 buffer-read-only) | |
1819 ;; This is bogus, as it will not handle all the ways that efs uses cache. | |
1820 ;; Better to just use the fact that revert-buffer-function is a | |
1821 ;; buffer-local variable, and reset it to something that knows about | |
1822 ;; cache. | |
1823 ;; (dired-uncache | |
1824 ;; (if (consp dired-directory) (car dired-directory) dired-directory)) | |
1825 ;; treat top level dir extra (it may contain wildcards) | |
1826 (let ((dired-after-readin-hook nil) | |
1827 ;; don't run that hook for each subdir... | |
1828 (dired-omit-files nil) | |
1829 (dired-internal-switches oswitches)) | |
1830 (dired-readin dired-directory (current-buffer) | |
1831 ;; Don't test for wildcards by checking string= | |
1832 ;; default-directory and dired-directory | |
1833 ;; in case default-directory got munged. | |
1834 (or (consp dired-directory) | |
1835 (null (file-directory-p dired-directory)))) | |
1836 ;; The R-switch will clobber sorting of subdirs. | |
1837 ;; What is the right thing to do here? | |
1838 (dired-insert-old-subdirs old-subdir-alist)) | |
1839 (dired-mark-remembered mark-alist) ; mark files that were marked | |
1840 (if kill-files-p (dired-do-hide dired-kill-marker-char)) | |
1841 (run-hooks 'dired-after-readin-hook) ; no need to narrow | |
1842 ;; omit-expunge after the readin hook | |
1843 (save-excursion | |
1844 (mapcar (function (lambda (dir) | |
1845 (if (dired-goto-subdir dir) | |
1846 (dired-omit-expunge)))) | |
1847 omitted-subdirs)) | |
1848 ;; hide subdirs that were hidden | |
1849 (save-excursion | |
1850 (mapcar (function (lambda (dir) | |
1851 (if (dired-goto-subdir dir) | |
1852 (dired-hide-subdir 1)))) | |
1853 hidden-subdirs)) | |
1854 ;; Try to get back to where we were | |
1855 (or (and ofile (dired-goto-file ofile)) | |
1856 (goto-char opoint)) | |
1857 (dired-move-to-filename) | |
1858 (dired-update-mode-line t) | |
1859 (dired-update-mode-line-modified t))) | |
1860 | |
1861 (defun dired-do-redisplay (&optional arg) | |
1862 "Redisplay all marked (or next ARG) files." | |
1863 (interactive "P") | |
1864 ;; message instead of making dired-map-over-marks show-progress is | |
1865 ;; much faster | |
1866 (dired-map-over-marks (let ((fname (dired-get-filename))) | |
1867 (dired-uncache fname nil) | |
1868 (message "Redisplaying %s..." fname) | |
1869 (dired-update-file-line fname)) | |
1870 arg) | |
1871 (dired-update-mode-line-modified t) | |
1872 (message "Redisplaying...done")) | |
1873 | |
1874 (defun dired-redisplay-subdir (&optional arg) | |
1875 "Redisplay the current subdirectory. | |
1876 With a prefix prompts for listing switches." | |
1877 (interactive "P") | |
1878 (let ((switches (and arg (dired-make-switches-list | |
1879 (read-string "Switches for listing: " | |
1880 (dired-make-switches-string | |
1881 dired-internal-switches))))) | |
1882 (dir (dired-current-directory)) | |
1883 (opoint (point)) | |
1884 (ofile (dired-get-filename nil t))) | |
1885 (or switches | |
1886 (setq switches (nth 3 (assoc dir dired-subdir-alist)))) | |
1887 (or switches | |
1888 (setq switches (delq ?R (copy-sequence dired-internal-switches)))) | |
1889 (message "Redisplaying %s..." dir) | |
1890 (dired-uncache dir t) | |
1891 (dired-insert-subdir dir switches) | |
1892 (dired-update-mode-line-modified t) | |
1893 (or (and ofile (dired-goto-file ofile)) (goto-char opoint)) | |
1894 (message "Redisplaying %s... done" dir))) | |
1895 | |
1896 (defun dired-update-file-line (file) | |
1897 ;; Delete the current line, and insert an entry for FILE. | |
1898 ;; Does not update other dired buffers. Use dired-relist-file for that. | |
1899 (let* ((start (save-excursion (skip-chars-backward "^\n\r") (point))) | |
1900 (char (char-after start))) | |
1901 (dired-save-excursion | |
1902 ;; don't remember omit marks | |
1903 (if (memq char (list ?\040 dired-omit-marker-char)) | |
1904 (setq char nil)) | |
1905 ;; Delete the current-line. Even though dired-add-entry will not | |
1906 ;; insert duplicates, the file for the current line may not be the same as | |
1907 ;; FILE. eg. dired-do-compress | |
1908 (delete-region (save-excursion (skip-chars-backward "^\n\r") (1- (point))) | |
1909 (progn (skip-chars-forward "^\n\r") (point))) | |
1910 ;; dired-add-entry inserts at the end of the previous line. | |
1911 (forward-char 1) | |
1912 (dired-add-entry file char t)))) | |
1913 | |
1914 ;;; Subroutines of dired-revert | |
1915 ;;; Some of these are also used when inserting subdirs. | |
1916 | |
1917 ;; Don't want to remember omit marks, in case omission regexps | |
1918 ;; were changed, before the dired-revert. If we don't unhide | |
1919 ;; omitted files, we won't see their marks. Therefore we use | |
1920 ;; dired-omit-unhide-region. | |
1921 | |
1922 (defun dired-remember-marks (beg end) | |
1923 ;; Return alist of files and their marks, from BEG to END. | |
1924 (if selective-display ; must unhide to make this work. | |
1925 (let (buffer-read-only) | |
1926 (subst-char-in-region (point-min) (point-max) ?\r ?\n) | |
1927 (dired-do-hide dired-omit-marker-char))) | |
1928 (let (fil chr alist) | |
1929 (save-excursion | |
1930 (goto-char beg) | |
1931 (while (re-search-forward dired-re-mark end t) | |
1932 (if (setq fil (dired-get-filename nil t)) | |
1933 (setq chr (preceding-char) | |
1934 alist (cons (cons fil chr) alist))))) | |
1935 alist)) | |
1936 | |
1937 (defun dired-mark-remembered (alist) | |
1938 ;; Mark all files remembered in ALIST. | |
1939 (let (elt fil chr) | |
1940 (while alist | |
1941 (setq elt (car alist) | |
1942 alist (cdr alist) | |
1943 fil (car elt) | |
1944 chr (cdr elt)) | |
1945 (if (dired-goto-file fil) | |
1946 (save-excursion | |
1947 (beginning-of-line) | |
1948 (dired-substitute-marker (point) (following-char) chr)))))) | |
1949 | |
1950 (defun dired-remember-hidden () | |
1951 ;; Return a list of all hidden subdirs. | |
1952 (let ((l dired-subdir-alist) dir result min) | |
1953 (while l | |
1954 (setq dir (car (car l)) | |
1955 min (dired-get-subdir-min (car l)) | |
1956 l (cdr l)) | |
1957 (if (and (>= min (point-min)) (<= min (point-max)) | |
1958 (dired-subdir-hidden-p dir)) | |
1959 (setq result (cons dir result)))) | |
1960 result)) | |
1961 | |
1962 (defun dired-insert-old-subdirs (old-subdir-alist) | |
1963 ;; Try to insert all subdirs that were displayed before | |
1964 (let (elt dir switches) | |
1965 (while old-subdir-alist | |
1966 (setq elt (car old-subdir-alist) | |
1967 old-subdir-alist (cdr old-subdir-alist) | |
1968 dir (car elt) | |
1969 switches (or (nth 3 elt) dired-internal-switches)) | |
1970 (condition-case () | |
1971 (dired-insert-subdir dir switches) | |
1972 (error nil))))) | |
1973 | |
1974 (defun dired-uncache (file dir-p) | |
1975 ;; Remove directory DIR from any directory cache. | |
1976 ;; If DIR-P is non-nil, then FILE is a directory | |
1977 (let ((handler (find-file-name-handler file 'dired-uncache))) | |
1978 (if handler | |
1979 (funcall handler 'dired-uncache file dir-p)))) | |
1980 | |
1981 | |
1982 ;;;; ------------------------------------------------------------- | |
1983 ;;;; Inserting subdirectories | |
1984 ;;;; ------------------------------------------------------------- | |
1985 | |
1986 (defun dired-maybe-insert-subdir (dirname &optional | |
1987 switches no-error-if-not-dir-p) | |
1988 "Insert this subdirectory into the same dired buffer. | |
1989 If it is already present, just move to it (type \\[dired-do-redisplay] to | |
1990 refresh), else inserts it at its natural place (as ls -lR would have done). | |
1991 With a prefix arg, you may edit the ls switches used for this listing. | |
1992 You can add `R' to the switches to expand the whole tree starting at | |
1993 this subdirectory. | |
1994 This function takes some pains to conform to ls -lR output." | |
1995 (interactive | |
1996 (list (dired-get-filename) | |
1997 (if current-prefix-arg | |
1998 (dired-make-switches-list | |
1999 (read-string "Switches for listing: " | |
2000 (dired-make-switches-string | |
2001 dired-internal-switches)))))) | |
2002 (let ((opoint (point))) | |
2003 ;; We don't need a marker for opoint as the subdir is always | |
2004 ;; inserted *after* opoint. | |
2005 (setq dirname (file-name-as-directory dirname)) | |
2006 (or (and (not switches) | |
2007 (dired-goto-subdir dirname)) | |
2008 (dired-insert-subdir dirname switches no-error-if-not-dir-p)) | |
2009 ;; Push mark so that it's easy to find back. Do this after the | |
2010 ;; insert message so that the user sees the `Mark set' message. | |
2011 (push-mark opoint))) | |
2012 | |
2013 (defun dired-insert-subdir (dir-or-list &optional | |
2014 switches no-error-if-not-dir-p no-posn) | |
2015 "Insert this subdirectory into the same dired buffer. | |
2016 If it is already present, overwrites previous entry, | |
2017 else inserts it at its natural place (as ls -lR would have done). | |
2018 With a prefix arg, you may edit the ls switches used for this listing. | |
2019 You can add `R' to the switches to expand the whole tree starting at | |
2020 this subdirectory. | |
2021 This function takes some pains to conform to ls -lR output." | |
2022 ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like | |
2023 ;; Prospero where dired-ls does the right thing, but | |
2024 ;; file-directory-p has not been redefined. | |
2025 ;; SWITCHES should be a list. | |
2026 ;; If NO-POSN is non-nil, doesn't bother position the point at | |
2027 ;; the first nontrivial file line. This can be used as an efficiency | |
2028 ;; hack when calling this from a program. | |
2029 (interactive | |
2030 (list (dired-get-filename) | |
2031 (if current-prefix-arg | |
2032 (dired-make-switches-list | |
2033 (read-string "Switches for listing: " | |
2034 (dired-make-switches-string | |
2035 dired-internal-switches)))))) | |
2036 (let ((dirname (if (consp dir-or-list) (car dir-or-list) dir-or-list))) | |
2037 (setq dirname (file-name-as-directory (expand-file-name dirname))) | |
2038 (or (dired-in-this-tree dirname (expand-file-name default-directory)) | |
2039 (error "%s: not in this directory tree" dirname)) | |
2040 (or no-error-if-not-dir-p | |
2041 (file-directory-p dirname) | |
2042 (error "Attempt to insert a non-directory: %s" dirname)) | |
2043 (if switches | |
2044 (or (dired-compatible-switches-p dired-internal-switches switches) | |
2045 (error "Cannot have subdirs with %s and %s switches together." | |
2046 (dired-make-switches-string dired-internal-switches) | |
2047 (dired-make-switches-string switches))) | |
2048 (setq switches dired-internal-switches)) | |
2049 (let ((elt (assoc dirname dired-subdir-alist)) | |
2050 mark-alist opoint-max buffer-read-only) | |
2051 (if (memq ?R switches) | |
2052 ;; avoid duplicated subdirs | |
2053 (progn | |
2054 (setq mark-alist (dired-kill-tree dirname t)) | |
2055 (dired-insert-subdir-newpos dirname)) | |
2056 (if elt | |
2057 ;; If subdir is already present, remove it and remember its marks | |
2058 (setq mark-alist (dired-insert-subdir-del elt)) | |
2059 ;; else move to new position | |
2060 (dired-insert-subdir-newpos dirname))) | |
2061 (setq opoint-max (point-max)) | |
2062 (condition-case nil | |
2063 (dired-insert-subdir-doupdate | |
2064 dirname (dired-insert-subdir-doinsert dir-or-list switches) | |
2065 switches elt mark-alist) | |
2066 (quit ; watch out for aborted inserts | |
2067 (and (= opoint-max (point-max)) | |
2068 (null elt) | |
2069 (= (preceding-char) ?\n) | |
2070 (delete-char -1)) | |
2071 (signal 'quit nil)))) | |
2072 (or no-posn (dired-initial-position dirname)))) | |
2073 | |
2074 (defun dired-do-insert-subdir () | |
2075 "Insert all marked subdirectories in situ that are not yet inserted. | |
2076 Non-directories are silently ignored." | |
2077 (interactive) | |
2078 (let ((files (or (dired-get-marked-files) | |
2079 (error "No files marked.")))) | |
2080 (while files | |
2081 (if (file-directory-p (car files)) | |
2082 (save-excursion (dired-maybe-insert-subdir (car files)))) | |
2083 (setq files (cdr files))))) | |
2084 | |
2085 ;;; Utilities for inserting subdirectories | |
2086 | |
2087 (defun dired-insert-subdir-newpos (new-dir) | |
2088 ;; Find pos for new subdir, according to tree order. | |
2089 (let ((alist dired-subdir-alist) elt dir new-pos) | |
2090 (while alist | |
2091 (setq elt (car alist) | |
2092 alist (cdr alist) | |
2093 dir (car elt)) | |
2094 (if (dired-tree-lessp dir new-dir) | |
2095 ;; Insert NEW-DIR after DIR | |
2096 (setq new-pos (dired-get-subdir-max elt) | |
2097 alist nil))) | |
2098 (goto-char new-pos)) | |
2099 (insert "\n") | |
2100 (point)) | |
2101 | |
2102 (defun dired-insert-subdir-del (element) | |
2103 ;; Erase an already present subdir (given by ELEMENT) from buffer. | |
2104 ;; Move to that buffer position. Return a mark-alist. | |
2105 (let ((begin-marker (dired-get-subdir-min element))) | |
2106 (goto-char begin-marker) | |
2107 ;; Are at beginning of subdir (and inside it!). Now determine its end: | |
2108 (goto-char (dired-subdir-max)) | |
2109 (prog1 | |
2110 (dired-remember-marks begin-marker (point)) | |
2111 (delete-region begin-marker (point))))) | |
2112 | |
2113 (defun dired-insert-subdir-doinsert (dir-or-list switches) | |
2114 ;; Insert ls output after point and put point on the correct | |
2115 ;; position for the subdir alist. | |
2116 ;; Return the boundary of the inserted text (as list of BEG and END). | |
2117 ;; SWITCHES should be a non-nil list. | |
2118 (let ((begin (point)) | |
2119 (dirname (if (consp dir-or-list) (car dir-or-list) dir-or-list)) | |
2120 end) | |
2121 (message "Reading directory %s..." dirname) | |
2122 (if (string-equal dirname (car (car (reverse dired-subdir-alist)))) | |
2123 ;; top level directory may contain wildcards: | |
2124 (let ((dired-internal-switches switches)) | |
2125 (dired-readin-insert dired-directory | |
2126 (null (file-directory-p dired-directory)))) | |
2127 (let ((switches (dired-make-switches-string switches)) | |
2128 (insert-directory-program dired-ls-program)) | |
2129 (if (consp dir-or-list) | |
2130 (progn | |
2131 (insert "list wildcard\n") | |
2132 (mapcar | |
2133 (function | |
2134 (lambda (x) | |
2135 (insert-directory x switches t))) | |
2136 (cdr dir-or-list))) | |
2137 (insert-directory dirname switches nil t)))) | |
2138 (message "Reading directory %s...done" dirname) | |
2139 (setq end (point-marker)) | |
2140 (dired-indent-listing begin end) | |
2141 (dired-insert-set-properties begin end) | |
2142 ;; call dired-insert-headerline afterwards, as under VMS dired-ls | |
2143 ;; does insert the headerline itself and the insert function just | |
2144 ;; moves point. | |
2145 ;; Need a marker for END as this inserts text. | |
2146 (goto-char begin) | |
2147 (dired-insert-headerline dirname) | |
2148 ;; point is now like in dired-build-subdir-alist | |
2149 (prog1 | |
2150 (list begin (marker-position end)) | |
2151 (set-marker end nil)))) | |
2152 | |
2153 (defun dired-insert-subdir-doupdate (dirname beg-end switches elt mark-alist) | |
2154 ;; Point is at the correct subdir alist position for ELT, | |
2155 ;; BEG-END is the subdir-region (as list of begin and end). | |
2156 ;; SWITCHES must be a non-nil list. | |
2157 (if (memq ?R switches) | |
2158 ;; This will remove ?R from switches on purpose. | |
2159 (let ((dired-internal-switches (delq ?R switches))) | |
2160 (dired-build-subdir-alist)) | |
2161 (if elt | |
2162 (progn | |
2163 (set-marker (dired-get-subdir-min elt) (point-marker)) | |
2164 (setcar (nthcdr 3 elt) switches) | |
2165 (if dired-verify-modtimes | |
2166 (dired-set-file-modtime dirname dired-subdir-alist))) | |
2167 (dired-alist-add dirname (point-marker) dired-omit-files switches))) | |
2168 (save-excursion | |
2169 (let ((begin (nth 0 beg-end)) | |
2170 (end (nth 1 beg-end))) | |
2171 (goto-char begin) | |
2172 (save-restriction | |
2173 (narrow-to-region begin end) | |
2174 ;; hook may add or delete lines, but the subdir boundary | |
2175 ;; marker floats | |
2176 (run-hooks 'dired-after-readin-hook) | |
2177 (if mark-alist (dired-mark-remembered mark-alist)) | |
2178 (dired-do-hide dired-kill-marker-char) | |
2179 (if (if elt (nth 2 elt) dired-omit-files) | |
2180 (dired-omit-expunge nil t)))))) | |
2181 | |
2182 | |
2183 ;;;; -------------------------------------------------------------- | |
2184 ;;;; Dired motion commands -- moving around in the dired buffer. | |
2185 ;;;; -------------------------------------------------------------- | |
2186 | |
2187 (defun dired-next-line (arg) | |
2188 "Move down lines then position at filename. | |
2189 Optional prefix ARG says how many lines to move; default is one line." | |
2190 (interactive "p") | |
2191 (condition-case err | |
2192 (next-line arg) | |
2193 (error | |
2194 (if (eobp) | |
2195 (error "End of buffer") | |
2196 (error "%s" err)))) | |
2197 (dired-move-to-filename) | |
2198 (dired-update-mode-line)) | |
2199 | |
2200 (defun dired-previous-line (arg) | |
2201 "Move up lines then position at filename. | |
2202 Optional prefix ARG says how many lines to move; default is one line." | |
2203 (interactive "p") | |
2204 (previous-line arg) | |
2205 (dired-move-to-filename) | |
2206 (dired-update-mode-line)) | |
2207 | |
2208 (defun dired-scroll-up (arg) | |
2209 "Dired version of scroll up. | |
2210 Scroll text of current window upward ARG lines; or near full screen if no ARG. | |
2211 When calling from a program, supply a number as argument or nil." | |
2212 (interactive "P") | |
2213 (scroll-up arg) | |
2214 (dired-move-to-filename) | |
2215 (dired-update-mode-line)) | |
2216 | |
2217 (defun dired-scroll-down (arg) | |
2218 "Dired version of scroll-down. | |
2219 Scroll text of current window down ARG lines; or near full screen if no ARG. | |
2220 When calling from a program, supply a number as argument or nil." | |
2221 (interactive "P") | |
2222 (scroll-down arg) | |
2223 (dired-move-to-filename) | |
2224 (dired-update-mode-line)) | |
2225 | |
2226 (defun dired-beginning-of-buffer (arg) | |
2227 "Dired version of `beginning of buffer'." | |
2228 (interactive "P") | |
2229 (beginning-of-buffer arg) | |
2230 (dired-update-mode-line)) | |
2231 | |
2232 (defun dired-end-of-buffer (arg) | |
2233 "Dired version of `end-of-buffer'." | |
2234 (interactive "P") | |
2235 (end-of-buffer arg) | |
2236 (while (not (or (dired-move-to-filename) (dired-get-subdir) (bobp))) | |
2237 (forward-line -1)) | |
2238 (dired-update-mode-line t)) | |
2239 | |
2240 (defun dired-next-dirline (arg &optional opoint) | |
2241 "Goto ARG'th next directory file line." | |
2242 (interactive "p") | |
2243 (if dired-re-dir | |
2244 (progn | |
2245 (dired-check-ls-l) | |
2246 (or opoint (setq opoint (point))) | |
2247 (if (if (> arg 0) | |
2248 (re-search-forward dired-re-dir nil t arg) | |
2249 (beginning-of-line) | |
2250 (re-search-backward dired-re-dir nil t (- arg))) | |
2251 (progn | |
2252 (dired-move-to-filename) ; user may type `i' or `f' | |
2253 (dired-update-mode-line)) | |
2254 (goto-char opoint) | |
2255 (error "No more subdirectories"))))) | |
2256 | |
2257 (defun dired-prev-dirline (arg) | |
2258 "Goto ARG'th previous directory file line." | |
2259 (interactive "p") | |
2260 (dired-next-dirline (- arg))) | |
2261 | |
2262 (defun dired-next-marked-file (arg &optional wrap opoint) | |
2263 "Move to the next marked file, wrapping around the end of the buffer." | |
2264 (interactive "p\np") | |
2265 (or opoint (setq opoint (point))) ; return to where interactively started | |
2266 (if (if (> arg 0) | |
2267 (re-search-forward dired-re-mark nil t arg) | |
2268 (beginning-of-line) | |
2269 (re-search-backward dired-re-mark nil t (- arg))) | |
2270 (dired-move-to-filename) | |
2271 (if (null wrap) | |
2272 (progn | |
2273 (goto-char opoint) | |
2274 (error "No next marked file")) | |
2275 (message "(Wraparound for next marked file)") | |
2276 (goto-char (if (> arg 0) (point-min) (point-max))) | |
2277 (dired-next-marked-file arg nil opoint))) | |
2278 (dired-update-mode-line)) | |
2279 | |
2280 (defun dired-prev-marked-file (arg &optional wrap) | |
2281 "Move to the previous marked file, wrapping around the end of the buffer." | |
2282 (interactive "p\np") | |
2283 (dired-next-marked-file (- arg) wrap) | |
2284 (dired-update-mode-line)) | |
2285 | |
2286 (defun dired-goto-file (file) | |
2287 "Goto file line of FILE in this dired buffer." | |
2288 ;; Return value of point on success, else nil. | |
2289 ;; FILE must be an absolute pathname. | |
2290 ;; Loses if FILE contains control chars like "\007" for which ls | |
2291 ;; either inserts "?" or "\\007" into the buffer, so we won't find | |
2292 ;; it in the buffer. | |
2293 (interactive | |
2294 (prog1 ; let push-mark display its message | |
2295 (list | |
2296 (let* ((dired-completer-buffer (current-buffer)) | |
2297 (dired-completer-switches dired-internal-switches) | |
2298 (stack (reverse | |
2299 (mapcar (function | |
2300 (lambda (x) | |
2301 (dired-abbreviate-file-name (car x)))) | |
2302 dired-subdir-alist))) | |
2303 (initial (car stack)) | |
2304 (dired-goto-file-history (cdr stack)) | |
2305 dired-completer-cache) | |
2306 (expand-file-name | |
2307 (dired-completing-read "Goto file: " | |
2308 'dired-goto-file-completer | |
2309 nil t initial 'dired-goto-file-history)))) | |
2310 (push-mark))) | |
2311 (setq file (directory-file-name file)) ; does no harm if no directory | |
2312 (let (found case-fold-search) | |
2313 (save-excursion | |
2314 (if (dired-goto-subdir (or (file-name-directory file) | |
2315 (error "Need absolute pathname for %s" | |
2316 file))) | |
2317 (let* ((base (file-name-nondirectory file)) | |
2318 ;; filenames are preceded by SPC, this makes | |
2319 ;; the search faster (e.g. for the filename "-"!). | |
2320 (search (concat " " (dired-make-filename-string base t))) | |
2321 (boundary (dired-subdir-max)) | |
2322 fn) | |
2323 (while (and (not found) (search-forward search boundary 'move)) | |
2324 ;; Match could have BASE just as initial substring or | |
2325 ;; or in permission bits or date or | |
2326 ;; not be a proper filename at all: | |
2327 (if (and (setq fn (dired-get-filename 'no-dir t)) | |
2328 (string-equal fn base)) | |
2329 ;; Must move to filename since an (actually | |
2330 ;; correct) match could have been elsewhere on the | |
2331 ;; line (e.g. "-" would match somewhere in the | |
2332 ;; permission bits). | |
2333 (setq found (dired-move-to-filename))))))) | |
2334 (and found | |
2335 ;; return value of point (i.e., FOUND): | |
2336 (prog1 | |
2337 (goto-char found) | |
2338 (dired-update-mode-line))))) | |
2339 | |
2340 ;;; Moving by subdirectories | |
2341 | |
2342 (defun dired-up-directory (arg) | |
2343 "Move to the ARG'th (prefix arg) parent directory of current directory. | |
2344 Always stays within the current tree dired buffer. Will insert new | |
2345 subdirectories if necessary." | |
2346 (interactive "p") | |
2347 (if (< arg 0) (error "Can't go up a negative number of directories!")) | |
2348 (or (zerop arg) | |
2349 (let* ((dir (dired-current-directory)) | |
2350 (n arg) | |
2351 (up dir)) | |
2352 (while (> n 0) | |
2353 (setq up (file-name-directory (directory-file-name up)) | |
2354 n (1- n))) | |
2355 (if (and (< (length up) (length dired-directory)) | |
2356 (dired-in-this-tree dired-directory up)) | |
2357 (if (or (memq 'create-top-dir dired-no-confirm) | |
2358 (y-or-n-p | |
2359 (format "Insert new top dir %s and rename buffer? " | |
2360 (dired-abbreviate-file-name up)))) | |
2361 (let ((newname (let (buff) | |
2362 (unwind-protect | |
2363 (buffer-name | |
2364 (setq buff | |
2365 (create-file-buffer | |
2366 (directory-file-name up)))) | |
2367 (kill-buffer buff)))) | |
2368 (buffer-read-only nil)) | |
2369 (push-mark) | |
2370 (widen) | |
2371 (goto-char (point-min)) | |
2372 (insert-before-markers "\n") | |
2373 (forward-char -1) | |
2374 (dired-insert-subdir-doupdate | |
2375 up (dired-insert-subdir-doinsert up dired-internal-switches) | |
2376 dired-internal-switches nil nil) | |
2377 (dired-initial-position up) | |
2378 (rename-buffer newname) | |
2379 (dired-unadvertise default-directory) | |
2380 (setq default-directory up | |
2381 dired-directory up) | |
2382 (dired-advertise))) | |
2383 (dired-maybe-insert-subdir up))))) | |
2384 | |
2385 (defun dired-down-directory () | |
2386 "Go down in the dired tree. | |
2387 Moves to the first subdirectory of the current directory, which exists in | |
2388 the dired buffer. Does not take a prefix argument." | |
2389 ;; What would a prefix mean here? | |
2390 (interactive) | |
2391 (let ((dir (dired-current-directory)) ; has slash | |
2392 (rest (reverse dired-subdir-alist)) | |
2393 pos elt) | |
2394 (while rest | |
2395 (setq elt (car rest)) | |
2396 (if (dired-in-this-tree (directory-file-name (car elt)) dir) | |
2397 (setq rest nil | |
2398 pos (dired-goto-subdir (car elt))) | |
2399 (setq rest (cdr rest)))) | |
2400 (prog1 | |
2401 (if pos | |
2402 (progn | |
2403 (push-mark) | |
2404 (goto-char pos)) | |
2405 (error "At the bottom")) | |
2406 (dired-update-mode-line t)))) | |
2407 | |
2408 (defun dired-next-subdir (arg &optional no-error-if-not-found no-skip) | |
2409 "Go to next subdirectory, regardless of level." | |
2410 ;; Use 0 arg to go to this directory's header line. | |
2411 ;; NO-SKIP prevents moving to end of header line, returning whatever | |
2412 ;; position was found in dired-subdir-alist. | |
2413 (interactive "p") | |
2414 (let ((this-dir (dired-current-directory)) | |
2415 pos index) | |
2416 ;; nth with negative arg does not return nil but the first element | |
2417 (setq index (- (length dired-subdir-alist) | |
2418 (length (memq (assoc this-dir dired-subdir-alist) | |
2419 dired-subdir-alist)) | |
2420 arg)) | |
2421 (setq pos (if (>= index 0) | |
2422 (dired-get-subdir-min (nth index dired-subdir-alist)))) | |
2423 (if pos | |
2424 (if no-skip | |
2425 (goto-char pos) | |
2426 (goto-char pos) | |
2427 (skip-chars-forward "^\r\n") | |
2428 (if (= (following-char) ?\r) | |
2429 (skip-chars-backward "." (- (point) 3))) | |
2430 (dired-update-mode-line t) | |
2431 (point)) | |
2432 (if no-error-if-not-found | |
2433 nil ; return nil if not found | |
2434 (error "%s directory" (if (> arg 0) "Last" "First")))))) | |
2435 | |
2436 (defun dired-prev-subdir (arg &optional no-error-if-not-found no-skip) | |
2437 "Go to previous subdirectory, regardless of level. | |
2438 When called interactively and not on a subdir line, go to this subdir's line." | |
2439 (interactive | |
2440 (list (if current-prefix-arg | |
2441 (prefix-numeric-value current-prefix-arg) | |
2442 ;; if on subdir start already, don't stay there! | |
2443 (if (dired-get-subdir) 1 0)))) | |
2444 (dired-next-subdir (- arg) no-error-if-not-found no-skip)) | |
2445 | |
2446 (defun dired-goto-subdir (dir) | |
2447 "Goto end of header line of DIR in this dired buffer. | |
2448 Return value of point on success, otherwise return nil. | |
2449 The next char is either \\n, or \\r if DIR is hidden." | |
2450 (interactive | |
2451 (prog1 ; let push-mark display its message | |
2452 (list | |
2453 (let* ((table (mapcar | |
2454 (function | |
2455 (lambda (x) | |
2456 (list (dired-abbreviate-file-name | |
2457 (car x))))) | |
2458 dired-subdir-alist)) | |
2459 (stack (reverse (mapcar 'car table))) | |
2460 (initial (car stack)) | |
2461 (dired-goto-file-history (cdr stack))) | |
2462 (expand-file-name | |
2463 (dired-completing-read "Goto subdirectory " table nil t | |
2464 initial 'dired-goto-file-history)))) | |
2465 (push-mark))) | |
2466 (setq dir (file-name-as-directory dir)) | |
2467 (let ((elt (assoc dir dired-subdir-alist))) | |
2468 (and elt | |
2469 ;; need to make sure that we get where we're going. | |
2470 ;; beware: narrowing might be in effect | |
2471 (eq (goto-char (dired-get-subdir-min elt)) (point)) | |
2472 (progn | |
2473 ;; dired-subdir-hidden-p and dired-add-entry depend on point being | |
2474 ;; at either \n or looking-at ...\r after this function succeeds. | |
2475 (skip-chars-forward "^\r\n") | |
2476 (if (= (preceding-char) ?.) | |
2477 (skip-chars-backward "." (- (point) 3))) | |
2478 (if (interactive-p) (dired-update-mode-line)) | |
2479 (point))))) | |
2480 | |
2481 ;;; Internals for motion commands | |
2482 | |
2483 (defun dired-update-mode-line (&optional force) | |
2484 "Updates the mode line in dired according to the position of the point. | |
2485 Normally this uses a cache of the boundaries of the current subdirectory, | |
2486 but if the optional argument FORCE is non-nil, then modeline is always | |
2487 updated and the cache is recomputed." | |
2488 (if (or force | |
2489 (>= (point) dired-curr-subdir-max) | |
2490 (< (point) dired-curr-subdir-min)) | |
2491 (let ((alist dired-subdir-alist) | |
2492 min max) | |
2493 (while (and alist (< (point) | |
2494 (setq min (dired-get-subdir-min (car alist))))) | |
2495 (setq alist (cdr alist) | |
2496 max min)) | |
2497 (setq dired-curr-subdir-max (or max (point-max-marker)) | |
2498 dired-curr-subdir-min (or min (point-min-marker)) | |
2499 dired-subdir-omit (nth 2 (car alist))) | |
2500 (dired-sort-set-modeline (nth 3 (car alist)))))) | |
2501 | |
2502 (defun dired-manual-move-to-filename (&optional raise-error bol eol) | |
2503 "In dired, move to first char of filename on this line. | |
2504 Returns position (point) or nil if no filename on this line." | |
2505 ;; This is the UNIX version. | |
2506 ;; have to be careful that we don't move to omitted files | |
2507 (let (case-fold-search) | |
2508 | |
2509 (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) | |
2510 (or bol (setq bol (progn (skip-chars-backward "^\r\n") (point)))) | |
2511 | |
2512 (if (or (memq ?l dired-internal-switches) | |
2513 (memq ?g dired-internal-switches)) | |
2514 (if (and | |
2515 (> (- eol bol) 17) ; a valid file line must have at least | |
2516 ; 17 chars. 2 leading, 10 perms, | |
2517 ; separator, node #, separator, owner, | |
2518 ; separator | |
2519 (goto-char (+ bol 17)) | |
2520 (re-search-forward dired-re-month-and-time eol t)) | |
2521 (point) | |
2522 (goto-char bol) | |
2523 (if raise-error | |
2524 (error "No file on this line") | |
2525 nil)) | |
2526 ;; else ls switches don't contain -l. | |
2527 ;; Note that even if we make dired-move-to-filename and | |
2528 ;; dired-move-to-end-of-filename (and thus dired-get-filename) | |
2529 ;; work, all commands that gleaned information from the permission | |
2530 ;; bits (like dired-mark-directories) will cease to work properly. | |
2531 (if (= bol eol) | |
2532 (if raise-error | |
2533 (error "No file on this line") | |
2534 nil) | |
2535 ;; skip marker, if any | |
2536 (goto-char bol) | |
2537 (forward-char)) | |
2538 ;; If we not going to use the l switch, and use nstd listings, | |
2539 ;; then we must bomb on files starting with spaces. | |
2540 (skip-chars-forward " \t") | |
2541 (point)))) | |
2542 | |
2543 (defun dired-manual-move-to-end-of-filename (&optional no-error bol eol) | |
2544 ;; Assumes point is at beginning of filename, | |
2545 ;; thus the rwx bit re-search-backward below will succeed in *this* | |
2546 ;; line if at all. So, it should be called only after | |
2547 ;; (dired-move-to-filename t). | |
2548 ;; On failure, signals an error (with non-nil NO-ERROR just returns nil). | |
2549 ;; This is the UNIX version. | |
2550 (let ((bof (point)) | |
2551 file-type modes-start case-fold-search) | |
2552 (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) | |
2553 (or bol (setq bol (save-excursion (skip-chars-backward "^\r\n") (point)))) | |
2554 (and | |
2555 (null no-error) | |
2556 selective-display | |
2557 (eq (char-after (1- bol)) ?\r) | |
2558 (cond | |
2559 ((dired-subdir-hidden-p (dired-current-directory)) | |
2560 (error | |
2561 (substitute-command-keys | |
2562 "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) | |
2563 ((error | |
2564 (substitute-command-keys | |
2565 "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) | |
2566 (if (or (memq ?l dired-internal-switches) | |
2567 (memq ?g dired-internal-switches)) | |
2568 (if (save-excursion | |
2569 (goto-char bol) | |
2570 (re-search-forward | |
2571 "[^ ][-r][-w][^ ][-r][-w][^ ][-r][-w][^ ][-+ 0-9+]" | |
2572 bof t)) | |
2573 (progn | |
2574 (setq modes-start (match-beginning 0) | |
2575 file-type (char-after modes-start)) | |
2576 ;; Move point to end of name: | |
2577 (if (eq file-type ?l) ; symlink | |
2578 (progn | |
2579 (if (search-forward " -> " eol t) | |
2580 (goto-char (match-beginning 0)) | |
2581 (goto-char eol)) | |
2582 (and dired-ls-F-marks-symlinks | |
2583 (eq (preceding-char) ?@) ; link really marked? | |
2584 (memq ?F dired-internal-switches) | |
2585 (forward-char -1)) | |
2586 (point)) | |
2587 ;; else not a symbolic link | |
2588 (goto-char eol) | |
2589 ;; ls -lF marks dirs, sockets and executables with exactly | |
2590 ;; one trailing character. -F may not actually be honored, | |
2591 ;; e.g. by an FTP ls in efs | |
2592 (and | |
2593 (memq ?F dired-internal-switches) | |
2594 (let ((char (preceding-char))) | |
2595 (or (and (eq char ?*) (or | |
2596 (memq | |
2597 (char-after (+ modes-start 3)) | |
2598 '(?x ?s ?t)) | |
2599 (memq | |
2600 (char-after (+ modes-start 6)) | |
2601 '(?x ?s ?t)) | |
2602 (memq | |
2603 (char-after (+ modes-start 9)) | |
2604 '(?x ?s ?t)))) | |
2605 (and (eq char ?=) (eq file-type ?s)))) | |
2606 (forward-char -1)) | |
2607 ;; Skip back over /'s unconditionally. It's not a valid | |
2608 ;; file name character. | |
2609 (skip-chars-backward "/") | |
2610 (point))) | |
2611 (and (null no-error) | |
2612 (error "No file on this line"))) | |
2613 | |
2614 ;; A brief listing | |
2615 (if (eq (point) eol) | |
2616 (and (null no-error) | |
2617 (error "No file on this line")) | |
2618 (goto-char eol) | |
2619 (if (and (memq (preceding-char) '(?@ ?* ?=)) | |
2620 (memq ?F dired-internal-switches)) | |
2621 ;; A guess, since without a long listing, we can't be sure. | |
2622 (forward-char -1)) | |
2623 (skip-chars-backward "/") | |
2624 (point))))) | |
2625 | |
2626 (defun dired-goto-next-nontrivial-file () | |
2627 ;; Position point on first nontrivial file after point. | |
2628 ;; Does not move into the next sudir. | |
2629 ;; If point is on a file line, moves to that file. | |
2630 ;; This does not move to omitted files. | |
2631 (skip-chars-backward "^\n\r") | |
2632 (if (= (preceding-char) ?\r) | |
2633 (forward-line 1)) | |
2634 (let ((max (dired-subdir-max)) | |
2635 file) | |
2636 (while (and (or (not (setq file (dired-get-filename 'no-dir t))) | |
2637 (string-match dired-trivial-filenames file)) | |
2638 (< (point) max)) | |
2639 (forward-line 1))) | |
2640 (dired-move-to-filename)) | |
2641 | |
2642 (defun dired-goto-next-file () | |
2643 ;; Doesn't move out of current subdir. Does go to omitted files. | |
2644 ;; Returns the starting position of the file, or nil if none found. | |
2645 (let ((max (dired-subdir-max)) | |
2646 found) | |
2647 (while (and (null (setq found (dired-move-to-filename))) (< (point) max)) | |
2648 (skip-chars-forward "^\n\r") | |
2649 (forward-char 1)) | |
2650 found)) | |
2651 | |
2652 ;; fluid vars used by dired-goto-file-completer | |
2653 (defvar dired-completer-buffer nil) | |
2654 (defvar dired-completer-switches nil) | |
2655 (defvar dired-completer-cache nil) | |
2656 | |
2657 (defun dired-goto-file-completer (string pred action) | |
2658 (save-excursion | |
2659 (set-buffer dired-completer-buffer) | |
2660 (let* ((saved-md (match-data)) | |
2661 (file (file-name-nondirectory string)) | |
2662 (dir (file-name-directory string)) | |
2663 (xstring (expand-file-name string)) | |
2664 (xdir (file-name-directory xstring)) | |
2665 (exact (dired-goto-file xstring))) | |
2666 (unwind-protect | |
2667 (if (dired-goto-subdir xdir) | |
2668 (let ((table (cdr (assoc xdir dired-completer-cache))) | |
2669 fn result max) | |
2670 (or table | |
2671 (progn | |
2672 (setq table (make-vector 37 0)) | |
2673 (mapcar (function | |
2674 (lambda (ent) | |
2675 (setq ent (directory-file-name | |
2676 (car ent))) | |
2677 (if (string-equal | |
2678 (file-name-directory ent) xdir) | |
2679 (intern | |
2680 (concat | |
2681 (file-name-nondirectory ent) "/") | |
2682 table)))) | |
2683 dired-subdir-alist) | |
2684 (or (looking-at "\\.\\.\\.\n\r") | |
2685 (progn | |
2686 (setq max (dired-subdir-max)) | |
2687 (while (and | |
2688 (< (point) max) | |
2689 (not | |
2690 (setq fn | |
2691 (dired-get-filename 'no-dir t)))) | |
2692 (forward-line 1)) | |
2693 (if fn | |
2694 (progn | |
2695 (or (intern-soft (concat fn "/") table) | |
2696 (intern fn table)) | |
2697 (forward-line 1) | |
2698 (while (setq fn | |
2699 (dired-get-filename 'no-dir t)) | |
2700 (or (intern-soft (concat fn "/") table) | |
2701 (intern fn table)) | |
2702 (forward-line 1)))))) | |
2703 (setq dired-completer-cache (cons | |
2704 (cons xdir table) | |
2705 dired-completer-cache)))) | |
2706 (cond | |
2707 ((null action) | |
2708 (setq result (try-completion file table)) | |
2709 (if exact | |
2710 (if (stringp result) | |
2711 string | |
2712 t) | |
2713 (if (stringp result) | |
2714 (concat dir result) | |
2715 result))) | |
2716 ((eq action t) | |
2717 (setq result (all-completions file table)) | |
2718 (if exact (cons "." result) result)) | |
2719 ((eq 'lambda action) | |
2720 (and (or exact (intern-soft file table))))))) | |
2721 (store-match-data saved-md))))) | |
2722 | |
2723 (defun dired-really-goto-file (file) | |
2724 ;; Goes to a file, even if it needs to insert it parent directory. | |
2725 (or (dired-goto-file file) | |
2726 (progn ; refresh and try again | |
2727 (dired-insert-subdir (file-name-directory file)) | |
2728 (dired-goto-file file)))) | |
2729 | |
2730 (defun dired-between-files () | |
2731 ;; Point must be at beginning of line | |
2732 (save-excursion (not (dired-move-to-filename nil (point))))) | |
2733 | |
2734 (defun dired-repeat-over-lines (arg function) | |
2735 ;; This version skips non-file lines. | |
2736 ;; Skips file lines hidden with selective display. | |
2737 ;; BACKWARDS means move backwards after each action. This is not the same | |
2738 ;; as a negative arg, as that skips the current line. | |
2739 (beginning-of-line) | |
2740 (let* ((advance (cond ((> arg 0) 1) ((< arg 0) -1) (t nil))) | |
2741 (check-fun (if (eq advance 1) 'eobp 'bobp)) | |
2742 (n (if (< arg 0) (- arg) arg)) | |
2743 (wall (funcall check-fun)) | |
2744 (done wall)) | |
2745 (while (not done) | |
2746 (if advance | |
2747 (progn | |
2748 (while (not (or (save-excursion (dired-move-to-filename)) | |
2749 (setq wall (funcall check-fun)))) | |
2750 (forward-line advance)) | |
2751 (or wall | |
2752 (progn | |
2753 (save-excursion (funcall function)) | |
2754 (forward-line advance) | |
2755 (while (not (or (save-excursion (dired-move-to-filename)) | |
2756 (setq wall (funcall check-fun)))) | |
2757 (forward-line advance)) | |
2758 (setq done (or (zerop (setq n (1- n))) wall))))) | |
2759 (if (save-excursion (dired-move-to-filename)) | |
2760 (save-excursion (funcall function))) | |
2761 (setq done t)))) | |
2762 (dired-move-to-filename) | |
2763 ;; Note that if possible the point has now been moved to the beginning of | |
2764 ;; the file name. | |
2765 (dired-update-mode-line)) | |
2766 | |
2767 | |
2768 ;;;; ---------------------------------------------------------------- | |
2769 ;;;; Miscellaneous dired commands | |
2770 ;;;; ---------------------------------------------------------------- | |
2771 | |
2772 (defun dired-quit () | |
2773 "Bury the current dired buffer." | |
2774 (interactive) | |
2775 (bury-buffer)) | |
2776 | |
2777 (defun dired-undo () | |
2778 "Undo in a dired buffer. | |
2779 This doesn't recover lost files, it is just normal undo with temporarily | |
2780 writeable buffer. You can use it to recover marks, killed lines or subdirs." | |
2781 (interactive) | |
2782 (let ((lines (count-lines (point-min) (point-max))) | |
2783 buffer-read-only) | |
2784 (undo) | |
2785 ;; reset dired-subdir-alist, if a dir may have been affected | |
2786 ;; Is there a better way to guess this? | |
2787 (setq lines (- (count-lines (point-min) (point-max)) lines)) | |
2788 (if (or (>= lines 2) (<= lines -2)) | |
2789 (dired-build-subdir-alist))) | |
2790 (dired-update-mode-line-modified t) | |
2791 (dired-update-mode-line t)) | |
2792 | |
2793 | |
2794 ;;;; -------------------------------------------------------- | |
2795 ;;;; Immediate actions on files: visiting, viewing, etc. | |
2796 ;;;; -------------------------------------------------------- | |
2797 | |
2798 (defun dired-find-file () | |
2799 "In dired, visit the file or directory named on this line." | |
2800 (interactive) | |
2801 (find-file (dired-get-filename))) | |
2802 | |
2803 (defun dired-view-file () | |
2804 "In dired, examine a file in view mode, returning to dired when done. | |
2805 When file is a directory, show it in this buffer if it is inserted; | |
2806 otherwise, display it in another buffer." | |
2807 (interactive) | |
2808 (let ((file (dired-get-filename))) | |
2809 (if (file-directory-p file) | |
2810 (or (dired-goto-subdir file) | |
2811 (dired file)) | |
2812 (view-file file)))) | |
2813 | |
2814 (defun dired-find-file-other-window (&optional display) | |
2815 "In dired, visit this file or directory in another window. | |
2816 With a prefix, the file is displayed, but the window is not selected." | |
2817 (interactive "P") | |
2818 (if display | |
2819 (dired-display-file) | |
2820 (find-file-other-window (dired-get-filename)))) | |
2821 | |
2822 ;; Only for Emacs 19 | |
2823 (defun dired-find-file-other-frame () | |
2824 "In dired, visit this file or directory in another frame." | |
2825 (interactive) | |
2826 (find-file-other-frame (dired-get-filename))) | |
2827 | |
2828 (defun dired-display-file () | |
2829 "In dired, displays this file or directory in the other window." | |
2830 (interactive) | |
2831 (display-buffer (find-file-noselect (dired-get-filename)))) | |
2832 | |
2833 ;; After an idea by wurgler@zippysun.math.uakron.edu (Tom Wurgler). | |
2834 (defun dired-do-find-file (&optional arg) | |
2835 "Visit all marked files at once, and display them simultaneously. | |
2836 See also function `simultaneous-find-file'. | |
2837 If you want to keep the dired buffer displayed, type \\[split-window-vertically] first. | |
2838 If you want just the marked files displayed and nothing else, type \\[delete-other-windows] first." | |
2839 (interactive "P") | |
2840 (dired-simultaneous-find-file (dired-get-marked-files nil arg))) | |
2841 | |
2842 (defun dired-simultaneous-find-file (file-list) | |
2843 "Visit all files in FILE-LIST and display them simultaneously. | |
2844 | |
2845 The current window is split across all files in FILE-LIST, as evenly | |
2846 as possible. Remaining lines go to the bottommost window. | |
2847 | |
2848 The number of files that can be displayed this way is restricted by | |
2849 the height of the current window and the variable `window-min-height'." | |
2850 ;; It is usually too clumsy to specify FILE-LIST interactively | |
2851 ;; unless via dired (dired-do-find-file). | |
2852 (let ((size (/ (window-height) (length file-list)))) | |
2853 (or (<= window-min-height size) | |
2854 (error "Too many files to visit simultaneously")) | |
2855 (find-file (car file-list)) | |
2856 (setq file-list (cdr file-list)) | |
2857 (while file-list | |
2858 ;; Split off vertically a window of the desired size | |
2859 ;; The upper window will have SIZE lines. We select the lower | |
2860 ;; (larger) window because we want to split that again. | |
2861 (select-window (split-window nil size)) | |
2862 (find-file (car file-list)) | |
2863 (setq file-list (cdr file-list))))) | |
2864 | |
2865 (defun dired-create-directory (directory) | |
2866 "Create a directory called DIRECTORY." | |
2867 (interactive | |
2868 (list (read-file-name "Create directory: " | |
2869 (dired-abbreviate-file-name | |
2870 (dired-current-directory))))) | |
2871 (let ((expanded (expand-file-name directory))) | |
2872 (make-directory expanded) | |
2873 ;; Because this function is meant to be called interactively, it moves | |
2874 ;; the point. | |
2875 (dired-goto-file expanded))) | |
2876 | |
2877 (defun dired-recover-file () | |
2878 "Recovers file from its autosave file. | |
2879 If the file is an autosave file, then recovers its associated file instead." | |
2880 (interactive) | |
2881 (let* ((file (dired-get-filename)) | |
2882 (name (file-name-nondirectory file)) | |
2883 (asp (auto-save-file-name-p name)) | |
2884 (orig (and | |
2885 asp | |
2886 (if (fboundp 'auto-save-original-name) | |
2887 (auto-save-original-name file) | |
2888 (error | |
2889 "Need auto-save package to compute original file name.")))) | |
2890 (buff (if asp | |
2891 (and orig (get-file-buffer orig)) | |
2892 (get-file-buffer file)))) | |
2893 (and | |
2894 buff | |
2895 (buffer-modified-p buff) | |
2896 (or | |
2897 (yes-or-no-p | |
2898 (format | |
2899 "Recover file will erase the modified buffer %s. Do it? " | |
2900 (buffer-name buff))) | |
2901 (error "Recover file aborted."))) | |
2902 (if asp | |
2903 (if orig | |
2904 (recover-file orig) | |
2905 (find-file file)) | |
2906 (recover-file file)))) | |
2907 | |
2908 | |
2909 ;;;; -------------------------------------------------------------------- | |
2910 ;;;; Functions for extracting and manipulating file names | |
2911 ;;;; -------------------------------------------------------------------- | |
2912 | |
2913 (defun dired-make-filename-string (filename &optional reverse) | |
2914 ;; Translates the way that a file name appears in a buffer, to | |
2915 ;; how it is used in a path name. This is useful for non-unix | |
2916 ;; support in efs. | |
2917 filename) | |
2918 | |
2919 (defun dired-get-filename (&optional localp no-error-if-not-filep) | |
2920 "In dired, return name of file mentioned on this line. | |
2921 Value returned normally includes the directory name. | |
2922 Optional arg LOCALP with value `no-dir' means don't include directory | |
2923 name in result. A value of t means use path name relative to | |
2924 `default-directory', which still may contain slashes if in a subdirectory. | |
2925 Optional arg NO-ERROR-IF-NOT-FILEP means return nil if no filename on | |
2926 this line, otherwise an error occurs." | |
2927 | |
2928 ;; Compute bol & eol once, rather than twice inside move-to-filename | |
2929 ;; and move-to-end-of-filename | |
2930 (let ((eol (save-excursion (skip-chars-forward "^\n\r") (point))) | |
2931 (bol (save-excursion (skip-chars-backward "^\r\n") (point))) | |
2932 case-fold-search file p1 p2) | |
2933 (save-excursion | |
2934 (and | |
2935 (setq p1 (dired-move-to-filename (not no-error-if-not-filep) bol eol)) | |
2936 (setq p2 (dired-move-to-end-of-filename no-error-if-not-filep bol eol)) | |
2937 (setq file (buffer-substring p1 p2)) | |
2938 ;; Check if ls quoted the names, and unquote them. | |
2939 ;; Using read to unquote is much faster than substituting | |
2940 ;; \007 (4 chars) -> ^G (1 char) etc. in a lisp loop. | |
2941 (cond ((memq ?b dired-internal-switches) ; System V ls | |
2942 ;; This case is about 20% slower than without -b. | |
2943 (setq file | |
2944 (read | |
2945 (concat "\"" | |
2946 ;; some ls -b don't escape quotes, argh! | |
2947 ;; This is not needed for GNU ls, though. | |
2948 (or (dired-string-replace-match | |
2949 "\\([^\\]\\)\"" file "\\1\\\\\"") | |
2950 file) | |
2951 "\"")))) | |
2952 ;; If you do this, update dired-compatible-switches-p | |
2953 ;; ((memq ?Q dired-internal-switches) ; GNU ls | |
2954 ;; (setq file (read file))) | |
2955 ))) | |
2956 (and file | |
2957 (if (eq localp 'no-dir) | |
2958 (dired-make-filename-string file) | |
2959 (concat (dired-current-directory localp) | |
2960 (dired-make-filename-string file)))))) | |
2961 | |
2962 (defun dired-make-relative (file &optional dir no-error) | |
2963 ;; Convert FILE (an *absolute* pathname) to a pathname relative to DIR. | |
2964 ;; FILE must be absolute, or this function will return nonsense. | |
2965 ;; If FILE is not in a subdir of DIR, an error is signalled, | |
2966 ;; unless NO-ERROR is t. Then, ".."'s are inserted to give | |
2967 ;; a relative representation of FILE wrto DIR | |
2968 ;; eg. FILE = /vol/tex/bin/foo DIR = /vol/local/bin/ | |
2969 ;; results in ../../tex/bin/foo | |
2970 ;; DIR must be expanded. | |
2971 ;; DIR defaults to default-directory. | |
2972 ;; DIR must be file-name-as-directory, as with all directory args in | |
2973 ;; elisp code. | |
2974 (or dir (setq dir (expand-file-name default-directory))) | |
2975 (let ((flen (length file)) | |
2976 (dlen (length dir))) | |
2977 (if (and (> flen dlen) | |
2978 (string-equal (substring file 0 dlen) dir)) | |
2979 (substring file dlen) | |
2980 ;; Need to insert ..'s | |
2981 (or no-error (error "%s: not in directory tree growing at %s" file dir)) | |
2982 (if (string-equal file dir) | |
2983 "./" | |
2984 (let ((index 1) | |
2985 (count 0)) | |
2986 (while (and (string-match "/" dir index) | |
2987 (<= (match-end 0) flen) | |
2988 (string-equal (substring file index (match-end 0)) | |
2989 (substring dir index (match-end 0)))) | |
2990 (setq index (match-end 0))) | |
2991 (setq file (substring file index)) | |
2992 (if (and (/= flen index) | |
2993 (not (string-match "/" file)) | |
2994 (< flen dlen) | |
2995 (string-equal file (substring dir index flen)) | |
2996 (= (aref dir flen) ?/)) | |
2997 (setq file "." | |
2998 count -1)) | |
2999 ;; count how many slashes remain in dir. | |
3000 (while (string-match "/" dir index) | |
3001 (setq index (match-end 0) | |
3002 count (1+ count))) | |
3003 (apply 'concat (nconc (make-list count "../") (list file)))))))) | |
3004 | |
3005 ;;; Functions for manipulating file names. | |
3006 ;; | |
3007 ;; Used by file tranformers. | |
3008 ;; Define here rather than in dired-shell.el, as it wouldn't be | |
3009 ;; unreasonable to use these elsewhere. | |
3010 | |
3011 (defun dired-file-name-base (fn) | |
3012 "Returns the base name of FN. | |
3013 This is the file without directory part, and extension. See the variable | |
3014 `dired-filename-re-ext'." | |
3015 (setq fn (file-name-nondirectory fn)) | |
3016 (if (string-match dired-filename-re-ext fn 1) | |
3017 (substring fn 0 (match-beginning 0)) | |
3018 fn)) | |
3019 | |
3020 (defun dired-file-name-extension (fn) | |
3021 "Returns the extension for file name FN. | |
3022 See the variable dired-filename-re-ext'." | |
3023 (setq fn (file-name-nondirectory fn)) | |
3024 (if (string-match dired-filename-re-ext fn 1) | |
3025 (substring fn (match-beginning 0)) | |
3026 "")) | |
3027 | |
3028 (defun dired-file-name-sans-rcs-extension (fn) | |
3029 "Returns the file name FN without its RCS extension \",v\"." | |
3030 (setq fn (file-name-nondirectory fn)) | |
3031 (if (string-match ",v$" fn 1) | |
3032 (substring fn 0 (match-beginning 0)) | |
3033 fn)) | |
3034 | |
3035 (defun dired-file-name-sans-compress-extension (fn) | |
3036 "Returns the file name FN without the extension from compress or gzip." | |
3037 (setq fn (file-name-nondirectory fn)) | |
3038 (if (string-match "\\.\\([zZ]\\|gz\\)$" fn 1) | |
3039 (substring fn (match-beginning 0)) | |
3040 fn)) | |
3041 | |
3042 | |
3043 ;;;; --------------------------------------------------------------------- | |
3044 ;;;; Working with directory trees. | |
3045 ;;;; --------------------------------------------------------------------- | |
3046 ;;; | |
3047 ;;; This where code for the dired-subdir-alist is. | |
3048 | |
3049 ;;; Utility functions for dired-subdir-alist | |
3050 | |
3051 (defun dired-normalize-subdir (dir) | |
3052 ;; Prepend default-directory to DIR if relative path name. | |
3053 ;; dired-get-filename must be able to make a valid filename from a | |
3054 ;; file and its directory DIR. | |
3055 ;; Fully expand everything. | |
3056 (file-name-as-directory | |
3057 (if (file-name-absolute-p dir) | |
3058 (expand-file-name dir) | |
3059 (expand-file-name dir (expand-file-name default-directory))))) | |
3060 | |
3061 (defun dired-get-subdir () | |
3062 ;;"Return the subdir name on this line, or nil if not on a headerline." | |
3063 ;; Look up in the alist whether this is a headerline. | |
3064 (save-excursion | |
3065 (let ((cur-dir (dired-current-directory))) | |
3066 (beginning-of-line) ; alist stores b-o-l positions | |
3067 (and (zerop (- (point) | |
3068 (dired-get-subdir-min (assoc cur-dir | |
3069 dired-subdir-alist)))) | |
3070 cur-dir)))) | |
3071 | |
3072 (defun dired-get-subdir-max (elt) | |
3073 ;; returns subdir max. | |
3074 (let ((pos (- (length dired-subdir-alist) | |
3075 (length (member elt dired-subdir-alist))))) | |
3076 (if (zerop pos) | |
3077 (point-max) | |
3078 (1- (dired-get-subdir-min (nth (1- pos) dired-subdir-alist)))))) | |
3079 | |
3080 (defun dired-clear-alist () | |
3081 ;; Set all markers in dired-subdir-alist to nil. Set the alist to nil too. | |
3082 (while dired-subdir-alist | |
3083 (set-marker (dired-get-subdir-min (car dired-subdir-alist)) nil) | |
3084 (setq dired-subdir-alist (cdr dired-subdir-alist)))) | |
3085 | |
3086 (defun dired-unsubdir (dir) | |
3087 ;; Remove DIR from the alist | |
3088 (setq dired-subdir-alist | |
3089 (delq (assoc dir dired-subdir-alist) dired-subdir-alist))) | |
3090 | |
3091 (defun dired-simple-subdir-alist () | |
3092 ;; Build and return `dired-subdir-alist' assuming just the top level | |
3093 ;; directory to be inserted. Don't parse the buffer. | |
3094 (setq dired-subdir-alist | |
3095 (list (list (expand-file-name default-directory) | |
3096 (point-min-marker) dired-omit-files | |
3097 dired-internal-switches nil))) | |
3098 (if dired-verify-modtimes | |
3099 (dired-set-file-modtime (expand-file-name default-directory) | |
3100 dired-subdir-alist))) | |
3101 | |
3102 (defun dired-build-subdir-alist () | |
3103 "Build `dired-subdir-alist' by parsing the buffer and return its new value." | |
3104 (interactive) | |
3105 (let ((o-alist dired-subdir-alist) | |
3106 (count 0) | |
3107 subdir) | |
3108 (dired-clear-alist) | |
3109 (save-excursion | |
3110 (goto-char (point-min)) | |
3111 (while (re-search-forward dired-subdir-regexp nil t) | |
3112 (setq count (1+ count)) | |
3113 (apply 'dired-alist-add-1 | |
3114 (setq subdir (buffer-substring (match-beginning 2) | |
3115 (match-end 2))) | |
3116 ;; Put subdir boundary between lines. | |
3117 (set-marker (make-marker) (match-end 1)) | |
3118 (let ((elt (assoc subdir o-alist))) | |
3119 (if elt | |
3120 (list (nth 2 elt) (nth 3 elt)) | |
3121 (list dired-omit-files dired-internal-switches))))) | |
3122 (if (interactive-p) | |
3123 (message "%d director%s." count (if (= 1 count) "y" "ies"))) | |
3124 ;; We don't need to sort it because it is in buffer order per | |
3125 ;; constructionem. Return new alist: | |
3126 ;; pointers for current-subdir may be stale | |
3127 dired-subdir-alist))) | |
3128 | |
3129 (defun dired-alist-add (dir new-marker &optional omit switches) | |
3130 ;; Add new DIR at NEW-MARKER. Sort alist. | |
3131 (dired-alist-add-1 dir new-marker omit switches) | |
3132 (dired-alist-sort)) | |
3133 | |
3134 (defun dired-alist-add-1 (dir new-marker &optional omit switches) | |
3135 ;; Add new DIR at NEW-MARKER. Don't sort. | |
3136 (let ((dir (dired-normalize-subdir dir))) | |
3137 (setq dired-subdir-alist | |
3138 (cons (list dir new-marker omit switches nil) dired-subdir-alist)) | |
3139 (if dired-verify-modtimes | |
3140 (dired-set-file-modtime dir dired-subdir-alist)))) | |
3141 | |
3142 (defun dired-alist-sort () | |
3143 ;; Keep the alist sorted on buffer position. | |
3144 (setq dired-subdir-alist | |
3145 (sort dired-subdir-alist | |
3146 (function (lambda (elt1 elt2) | |
3147 (> (dired-get-subdir-min elt1) | |
3148 (dired-get-subdir-min elt2))))))) | |
3149 | |
3150 ;;; Utilities for working with subdirs in the dired buffer | |
3151 | |
3152 ;; This function is the heart of tree dired. | |
3153 ;; It is called for each retrieved filename. | |
3154 ;; It could stand to be faster, though it's mostly function call | |
3155 ;; overhead. Avoiding to funcall seems to save about 10% in | |
3156 ;; dired-get-filename. Make it a defsubst? | |
3157 (defun dired-current-directory (&optional localp) | |
3158 "Return the name of the subdirectory to which this line belongs. | |
3159 This returns a string with trailing slash, like `default-directory'. | |
3160 Optional argument means return a file name relative to `default-directory'. | |
3161 In this it returns \"\" for the top directory." | |
3162 (let* ((here (point)) | |
3163 (dir (catch 'done | |
3164 (mapcar (function | |
3165 (lambda (x) | |
3166 (if (<= (dired-get-subdir-min x) here) | |
3167 (throw 'done (car x))))) | |
3168 dired-subdir-alist)))) | |
3169 (if (listp dir) (error "dired-subdir-alist seems to be mangled")) | |
3170 (if localp | |
3171 (let ((def-dir (expand-file-name default-directory))) | |
3172 (if (string-equal dir def-dir) | |
3173 "" | |
3174 (dired-make-relative dir def-dir))) | |
3175 dir))) | |
3176 | |
3177 ;; Subdirs start at the beginning of their header lines and end just | |
3178 ;; before the beginning of the next header line (or end of buffer). | |
3179 | |
3180 (defun dired-subdir-min () | |
3181 ;; Returns the minimum position of the current subdir | |
3182 (save-excursion | |
3183 (if (not (dired-prev-subdir 0 t t)) | |
3184 (error "Not in a subdir!") | |
3185 (point)))) | |
3186 | |
3187 (defun dired-subdir-max () | |
3188 ;; Returns the maximum position of the current subdir | |
3189 (save-excursion | |
3190 (if (dired-next-subdir 1 t t) | |
3191 (1- (point)) ; Do not include separating empty line. | |
3192 (point-max)))) | |
3193 | |
3194 | |
3195 ;;;; -------------------------------------------------------- | |
3196 ;;;; Deleting files | |
3197 ;;;; -------------------------------------------------------- | |
3198 | |
3199 (defun dired-flag-file-deletion (arg) | |
3200 "In dired, flag the current line's file for deletion. | |
3201 With prefix arg, repeat over several lines. | |
3202 | |
3203 If on a subdir headerline, mark all its files except `.' and `..'." | |
3204 (interactive "p") | |
3205 (dired-mark arg dired-del-marker)) | |
3206 | |
3207 (defun dired-flag-file-deletion-backup (arg) | |
3208 "Flag current file for deletion, and move to previous line. | |
3209 With a prefix ARG, repeats this ARG times." | |
3210 (interactive "p") | |
3211 ;; Use dired-mark-file and not dired-mark, as this function | |
3212 ;; should do nothing special on subdir headers. | |
3213 (dired-mark-file (- arg) dired-del-marker)) | |
3214 | |
3215 (defun dired-flag-subdir-files () | |
3216 "Flag all the files in the current subdirectory for deletion." | |
3217 (interactive) | |
3218 (dired-mark-subdir-files dired-del-marker)) | |
3219 | |
3220 (defun dired-unflag (arg) | |
3221 "In dired, remove a deletion flag from the current line's file. | |
3222 Optional prefix ARG says how many lines to unflag." | |
3223 (interactive "p") | |
3224 (let (buffer-read-only) | |
3225 (dired-repeat-over-lines | |
3226 arg | |
3227 (function | |
3228 (lambda () | |
3229 (if (char-equal (following-char) dired-del-marker) | |
3230 (progn | |
3231 (setq dired-del-flags-number (max (1- dired-del-flags-number) 0)) | |
3232 (dired-substitute-marker (point) dired-del-marker ?\ ))))))) | |
3233 (dired-update-mode-line-modified)) | |
3234 | |
3235 (defun dired-backup-unflag (arg) | |
3236 "In dired, move up lines and remove deletion flag there. | |
3237 Optional prefix ARG says how many lines to unflag; default is one line." | |
3238 (interactive "p") | |
3239 (dired-unflag (- arg))) | |
3240 | |
3241 (defun dired-update-marker-counters (char &optional remove) | |
3242 (or (memq char '(?\ ?\n ?\r)) | |
3243 (let ((counter (cond | |
3244 ((char-equal char dired-del-marker) | |
3245 'dired-del-flags-number) | |
3246 ((char-equal char dired-marker-char) | |
3247 'dired-marks-number) | |
3248 ('dired-other-marks-number)))) | |
3249 (if remove | |
3250 (set counter (max (1- (symbol-value counter)) 0)) | |
3251 (set counter (1+ (symbol-value counter))))))) | |
3252 | |
3253 (defun dired-update-mode-line-modified (&optional check) | |
3254 ;; Updates the value of mode-line-modified in dired. | |
3255 ;; Currently assumes that it's of the form "-%%-", where % sometimes | |
3256 ;; gets replaced by %. Should allow some sort of config flag. | |
3257 ;; SET is t to set to -DD-, nil to set to -%%-, and 'check means | |
3258 ;; examine the buffer to find out. | |
3259 (if check | |
3260 (save-excursion | |
3261 (let (char) | |
3262 (goto-char (point-min)) | |
3263 (setq dired-del-flags-number 0 | |
3264 dired-marks-number 0 | |
3265 dired-other-marks-number 0) | |
3266 (while (not (eobp)) | |
3267 (setq char (following-char)) | |
3268 (cond | |
3269 ((char-equal char dired-del-marker) | |
3270 (setq dired-del-flags-number (1+ dired-del-flags-number))) | |
3271 ((char-equal char dired-marker-char) | |
3272 (setq dired-marks-number (1+ dired-marks-number))) | |
3273 ((memq char '(?\ ?\n ?\r)) | |
3274 nil) | |
3275 ((setq dired-other-marks-number (1+ dired-other-marks-number)))) | |
3276 (forward-line 1))))) | |
3277 (setq mode-line-modified | |
3278 (format dired-mode-line-modified | |
3279 (if (zerop dired-del-flags-number) | |
3280 "--" | |
3281 (format "%d%c" dired-del-flags-number dired-del-marker)) | |
3282 (if (zerop dired-marks-number) | |
3283 "--" | |
3284 (format "%d%c" dired-marks-number dired-marker-char)) | |
3285 (if (zerop dired-other-marks-number) | |
3286 "-" | |
3287 (int-to-string dired-other-marks-number)))) | |
3288 (set-buffer-modified-p (buffer-modified-p))) | |
3289 | |
3290 (defun dired-do-deletions (&optional nomessage) | |
3291 (dired-expunge-deletions)) | |
3292 | |
3293 (defun dired-expunge-deletions () | |
3294 "In dired, delete the files flagged for deletion." | |
3295 (interactive) | |
3296 (let ((files (let ((dired-marker-char dired-del-marker)) | |
3297 (dired-map-over-marks (cons (dired-get-filename) (point)) | |
3298 t)))) | |
3299 (if files | |
3300 (progn | |
3301 (dired-internal-do-deletions files nil dired-del-marker) | |
3302 ;; In case the point gets left somewhere strange -- hope that | |
3303 ;; this doesn't cause asynch troubles later. | |
3304 (beginning-of-line) | |
3305 (dired-goto-next-nontrivial-file) | |
3306 (dired-update-mode-line-modified t)) ; play safe, it's cheap | |
3307 (message "(No deletions requested)")))) | |
3308 | |
3309 (defun dired-do-delete (&optional arg) | |
3310 "Delete all marked (or next ARG) files." | |
3311 ;; This is more consistent with the file marking feature than | |
3312 ;; dired-expunge-deletions. | |
3313 (interactive "P") | |
3314 (dired-internal-do-deletions | |
3315 ;; this may move point if ARG is an integer | |
3316 (dired-map-over-marks (cons (dired-get-filename) (point)) | |
3317 arg) | |
3318 arg) | |
3319 (beginning-of-line) | |
3320 (dired-goto-next-nontrivial-file)) | |
3321 | |
3322 (defun dired-internal-do-deletions (l arg &optional marker-char) | |
3323 ;; L is an alist of files to delete, with their buffer positions. | |
3324 ;; ARG is the prefix arg. | |
3325 ;; Filenames are absolute (VMS needs this for logical search paths). | |
3326 ;; (car L) *must* be the *last* (bottommost) file in the dired buffer. | |
3327 ;; That way as changes are made in the buffer they do not shift the | |
3328 ;; lines still to be changed, so the (point) values in L stay valid. | |
3329 ;; Also, for subdirs in natural order, a subdir's files are deleted | |
3330 ;; before the subdir itself - the other way around would not work. | |
3331 (save-excursion | |
3332 (let ((files (mapcar (function car) l)) | |
3333 (count (length l)) | |
3334 (succ 0) | |
3335 (cdir (dired-current-directory)) | |
3336 failures) | |
3337 ;; canonicalize file list for pop up | |
3338 (setq files (nreverse (mapcar (function | |
3339 (lambda (fn) | |
3340 (dired-make-relative fn cdir t))) | |
3341 files))) | |
3342 (if (or (memq 'delete dired-no-confirm) | |
3343 (dired-mark-pop-up | |
3344 " *Files Flagged for Deletion*" 'delete files | |
3345 dired-deletion-confirmer | |
3346 (format "Delete %s " | |
3347 (dired-mark-prompt arg files marker-char)))) | |
3348 (save-excursion | |
3349 ;; files better be in reverse order for this loop! | |
3350 (while l | |
3351 (goto-char (cdr (car l))) | |
3352 (condition-case err | |
3353 (let ((fn (car (car l)))) | |
3354 ;; This test is equivalent to | |
3355 ;; (and (file-directory-p fn) | |
3356 ;; (not (file-symlink-p fn))) | |
3357 ;; but more efficient | |
3358 (if (if (eq t (car (file-attributes fn))) | |
3359 (if (<= (length (directory-files fn)) 2) | |
3360 (progn (delete-directory fn) t) | |
3361 (and (or | |
3362 (memq 'recursive-delete dired-no-confirm) | |
3363 (funcall | |
3364 dired-deletion-confirmer | |
3365 (format "\ | |
3366 Recursively delete directory and files within %s? " | |
3367 (dired-make-relative fn)))) | |
3368 (progn | |
3369 (dired-recursive-delete-directory fn) | |
3370 t))) | |
3371 (progn (delete-file fn) t)) | |
3372 (progn | |
3373 (setq succ (1+ succ)) | |
3374 (message "%s of %s deletions" succ count) | |
3375 (dired-clean-up-after-deletion fn)))) | |
3376 (error;; catch errors from failed deletions | |
3377 (dired-log (buffer-name (current-buffer)) "%s\n" err) | |
3378 (setq failures (cons (car (car l)) failures)))) | |
3379 (setq l (cdr l))))) | |
3380 (if failures | |
3381 (dired-log-summary | |
3382 (buffer-name (current-buffer)) | |
3383 (format "%d of %d deletion%s failed:" (length failures) count | |
3384 (dired-plural-s count)) | |
3385 failures) | |
3386 (if (zerop succ) | |
3387 (message "(No deletions performed)") | |
3388 (message "%d deletion%s done" succ (dired-plural-s succ))))))) | |
3389 | |
3390 (defun dired-recursive-delete-directory (fn) | |
3391 ;; Recursively deletes directory FN, and all of its contents. | |
3392 (let* ((fn (expand-file-name fn)) | |
3393 (handler (find-file-name-handler | |
3394 fn 'dired-recursive-delete-directory))) | |
3395 (if handler | |
3396 (funcall handler 'dired-recursive-delete-directory fn) | |
3397 (progn | |
3398 (or (file-exists-p fn) | |
3399 (signal | |
3400 'file-error | |
3401 (list "Removing old file name" "no such directory" fn))) | |
3402 ;; Which is better, -r or -R? | |
3403 (call-process "rm" nil nil nil "-r" (directory-file-name fn)) | |
3404 (and (file-exists-p fn) | |
3405 (error "Failed to recusively delete %s" fn)))))) | |
3406 | |
3407 (defun dired-clean-up-after-deletion (fn) | |
3408 ;; Offer to kill buffer of deleted file FN. | |
3409 (let ((buf (get-file-buffer fn))) | |
3410 (and buf | |
3411 (or (memq 'kill-file-buffer dired-no-confirm) | |
3412 (funcall (function yes-or-no-p) | |
3413 (format "Kill buffer of %s, too? " | |
3414 (file-name-nondirectory fn)))) | |
3415 (save-excursion ; you never know where kill-buffer leaves you | |
3416 (kill-buffer buf))))) | |
3417 | |
3418 ;;; Cleaning a directory -- flagging backups for deletion | |
3419 | |
3420 (defun dired-clean-directory (keep &optional marker msg) | |
3421 "Flag numerical backups for deletion. | |
3422 Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest. | |
3423 Positive prefix arg KEEP overrides `dired-kept-versions'; | |
3424 Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive. | |
3425 | |
3426 To clear the flags on these files, you can use \\[dired-flag-backup-files] | |
3427 with a prefix argument." | |
3428 (interactive "P") | |
3429 (setq keep (if keep (prefix-numeric-value keep) dired-kept-versions)) | |
3430 (let* ((early-retention (if (< keep 0) (- keep) kept-old-versions)) | |
3431 (late-retention (if (<= keep 0) dired-kept-versions keep)) | |
3432 (msg (or msg | |
3433 (format | |
3434 "Cleaning numerical backups (keeping %d late, %d old)" | |
3435 late-retention early-retention))) | |
3436 (trample-marker (or marker dired-del-marker)) | |
3437 (file-version-assoc-list)) | |
3438 (message "%s..." msg) | |
3439 ;; Do this after messaging, as it may take a while. | |
3440 (setq file-version-assoc-list (dired-collect-file-versions)) | |
3441 ;; Sort each VERSION-NUMBER-LIST, | |
3442 ;; and remove the versions to be deleted. | |
3443 (let ((fval file-version-assoc-list)) | |
3444 (while fval | |
3445 (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<))) | |
3446 (v-count (length sorted-v-list))) | |
3447 (if (> v-count (+ early-retention late-retention)) | |
3448 (rplacd (nthcdr early-retention sorted-v-list) | |
3449 (nthcdr (- v-count late-retention) | |
3450 sorted-v-list))) | |
3451 (rplacd (car fval) | |
3452 (cdr sorted-v-list))) | |
3453 (setq fval (cdr fval)))) | |
3454 ;; Look at each file. If it is a numeric backup file, | |
3455 ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion. | |
3456 (dired-map-dired-file-lines (function | |
3457 (lambda (fn) | |
3458 (dired-trample-file-versions | |
3459 fn file-version-assoc-list | |
3460 trample-marker)))) | |
3461 (message "%s...done" msg))) | |
3462 | |
3463 (defun dired-collect-file-versions () | |
3464 ;; If it looks like a file has versions, return a list of the versions. | |
3465 ;; The return value is ((FILENAME . (VERSION1 VERSION2 ...)) ...) | |
3466 (let (result) | |
3467 (dired-map-dired-file-lines | |
3468 (function | |
3469 (lambda (fn) | |
3470 (let* ((base-versions | |
3471 (concat (file-name-nondirectory fn) ".~")) | |
3472 (bv-length (length base-versions)) | |
3473 (possibilities (file-name-all-completions | |
3474 base-versions | |
3475 (file-name-directory fn)))) | |
3476 (if possibilities | |
3477 (setq result (cons (cons fn | |
3478 (mapcar 'backup-extract-version | |
3479 possibilities)) result))))))) | |
3480 result)) | |
3481 | |
3482 (defun dired-trample-file-versions (fn alist marker) | |
3483 ;; ALIST is an alist of filenames and versions used to determine | |
3484 ;; if each file should be flagged for deletion. | |
3485 ;; This version using file-name-sans-versions is probably a lot slower | |
3486 ;; than Sebastian's original, but it is more easily adaptable to non-unix. | |
3487 (let ((base (file-name-sans-versions fn)) | |
3488 base-version-list bv-length) | |
3489 (and (not (string-equal base fn)) | |
3490 (setq base-version-list (assoc base alist)) | |
3491 (setq bv-length (string-match "[0-9]" fn (length base))) | |
3492 (not (memq (backup-extract-version fn) base-version-list)) | |
3493 (progn (skip-chars-backward "^\n\r") | |
3494 (bolp)) ; make sure the preceding char isn't \r. | |
3495 (dired-substitute-marker (point) (following-char) marker)))) | |
3496 | |
3497 (defun dired-map-dired-file-lines (fun) | |
3498 ;; Perform FUN with point at the end of each non-directory line. | |
3499 ;; FUN takes one argument, the filename (complete pathname). | |
3500 (dired-check-ls-l) | |
3501 (save-excursion | |
3502 (let (file buffer-read-only) | |
3503 (goto-char (point-min)) | |
3504 (while (not (eobp)) | |
3505 (save-excursion | |
3506 (and (not (and dired-re-dir (looking-at dired-re-dir))) | |
3507 (not (memq (following-char) '(?\n ?\n))) | |
3508 (setq file (dired-get-filename nil t)) ; nil on non-file | |
3509 (progn (skip-chars-forward "^\n\r") | |
3510 (funcall fun file)))) | |
3511 (forward-line 1))))) ; this guarantees that we don't | |
3512 ; operate on omitted files. | |
3513 | |
3514 | |
3515 ;;;; ----------------------------------------------------------- | |
3516 ;;;; Confirmations and prompting the user. | |
3517 ;;;; ----------------------------------------------------------- | |
3518 | |
3519 (defun dired-plural-s (count) | |
3520 (if (= 1 count) "" "s")) | |
3521 | |
3522 (defun dired-mark-prompt (arg files &optional marker-char) | |
3523 ;; Return a string for use in a prompt, either the current file | |
3524 ;; name, or the marker and a count of marked files. | |
3525 (let ((count (length files))) | |
3526 (if (= count 1) | |
3527 (car files) | |
3528 ;; more than 1 file: | |
3529 (if (integerp arg) | |
3530 (cond ((zerop arg) "[no files]") | |
3531 ((> arg 0) "[following]") | |
3532 ((< arg 0) "[preceding]")) | |
3533 (char-to-string (or marker-char dired-marker-char)))))) | |
3534 | |
3535 (defun dired-pop-to-buffer (buf) | |
3536 ;; Pop up buffer BUF. | |
3537 ;; Make its window fit its contents. | |
3538 (let ((window (selected-window)) | |
3539 target-lines w2) | |
3540 (cond ;; if split-window-threshold is enabled, use the largest window | |
3541 ((and (> (window-height (setq w2 (get-largest-window))) | |
3542 split-height-threshold) | |
3543 (= (frame-width) (window-width w2))) | |
3544 (setq window w2)) | |
3545 ;; if the least-recently-used window is big enough, use it | |
3546 ((and (> (window-height (setq w2 (get-lru-window))) | |
3547 (* 2 window-min-height)) | |
3548 (= (frame-width) (window-width w2))) | |
3549 (setq window w2))) | |
3550 (save-excursion | |
3551 (set-buffer buf) | |
3552 (goto-char (point-max)) | |
3553 (skip-chars-backward "\n\r\t ") | |
3554 (setq target-lines (count-lines (point-min) (point))) | |
3555 ;; Don't forget to count the last line. | |
3556 (if (not (bolp)) | |
3557 (setq target-lines (1+ target-lines)))) | |
3558 (if (<= (window-height window) (* 2 window-min-height)) | |
3559 ;; At this point, every window on the frame is too small to split. | |
3560 (setq w2 (display-buffer buf)) | |
3561 (setq w2 (split-window | |
3562 window | |
3563 (max window-min-height | |
3564 (- (window-height window) | |
3565 (1+ (max window-min-height target-lines))))))) | |
3566 (set-window-buffer w2 buf) | |
3567 (if (< (1- (window-height w2)) target-lines) | |
3568 (progn | |
3569 (select-window w2) | |
3570 (enlarge-window (- target-lines (1- (window-height w2)))))) | |
3571 (set-window-start w2 1))) | |
3572 | |
3573 (defun dired-mark-pop-up (bufname op-symbol files function &rest args) | |
3574 ;; Args BUFNAME OP-SYMBOL FILES FUNCTION &rest ARGS. | |
3575 ;; Return FUNCTION's result on ARGS after popping up a window (in a buffer | |
3576 ;; named BUFNAME, nil gives \" *Marked Files*\") showing the marked | |
3577 ;; files. Uses function `dired-pop-to-buffer' to do that. | |
3578 ;; FUNCTION should not manipulate files. | |
3579 ;; It should only read input (an argument or confirmation). | |
3580 ;; The window is not shown if there is just one file or | |
3581 ;; OP-SYMBOL is a member of the list in `dired-no-confirm'. | |
3582 ;; FILES is the list of marked files. | |
3583 (if (memq op-symbol dired-no-confirm) | |
3584 (apply function args) | |
3585 (or bufname (setq bufname " *Marked Files*")) | |
3586 (if (<= (length files) 1) | |
3587 (apply function args) | |
3588 (save-excursion | |
3589 (let ((standard-output (set-buffer (get-buffer-create bufname)))) | |
3590 (erase-buffer) | |
3591 (dired-format-columns-of-files files) | |
3592 (dired-remove-text-properties (point-min) (point-max)) | |
3593 (setq mode-line-format (format " %s [%d files]" | |
3594 bufname (length files))))) | |
3595 (save-window-excursion | |
3596 (dired-pop-to-buffer bufname) | |
3597 (apply function args))))) | |
3598 | |
3599 (defun dired-column-widths (columns list &optional across) | |
3600 ;; Returns the column widths for breaking LIST into | |
3601 ;; COLUMNS number of columns. | |
3602 (cond | |
3603 ((null list) | |
3604 nil) | |
3605 ((= columns 1) | |
3606 (list (apply 'max (mapcar 'length list)))) | |
3607 ((let* ((len (length list)) | |
3608 (col-length (/ len columns)) | |
3609 (remainder (% len columns)) | |
3610 (i 0) | |
3611 (j 0) | |
3612 (max-width 0) | |
3613 widths padding) | |
3614 (if (zerop remainder) | |
3615 (setq padding 0) | |
3616 (setq col-length (1+ col-length) | |
3617 padding (- columns remainder))) | |
3618 (setq list (nconc (copy-sequence list) (make-list padding nil))) | |
3619 (setcdr (nthcdr (1- (+ len padding)) list) list) | |
3620 (while (< i columns) | |
3621 (while (< j col-length) | |
3622 (setq max-width (max max-width (length (car list))) | |
3623 list (if across (nthcdr columns list) (cdr list)) | |
3624 j (1+ j))) | |
3625 (setq widths (cons (+ max-width 2) widths) | |
3626 max-width 0 | |
3627 j 0 | |
3628 i (1+ i)) | |
3629 (if across (setq list (cdr list)))) | |
3630 (setcar widths (- (car widths) 2)) | |
3631 (nreverse widths))))) | |
3632 | |
3633 (defun dired-calculate-columns (list &optional across) | |
3634 ;; Returns a list of integers which are the column widths that best pack | |
3635 ;; LIST, a list of strings, onto the screen. | |
3636 (and list | |
3637 (let* ((width (1- (window-width))) | |
3638 (columns (max 1 (/ width | |
3639 (+ 2 (apply 'max (mapcar 'length list)))))) | |
3640 col-list last-col-list) | |
3641 (while (<= (apply '+ (setq col-list | |
3642 (dired-column-widths columns list across))) | |
3643 width) | |
3644 (setq columns (1+ columns) | |
3645 last-col-list col-list)) | |
3646 (or last-col-list col-list)))) | |
3647 | |
3648 (defun dired-format-columns-of-files (files &optional across) | |
3649 ;; Returns the number of lines used. | |
3650 ;; If ACROSS is non-nil, sorts across rather than down the buffer, like | |
3651 ;; ls -x | |
3652 (and files | |
3653 (let* ((columns (dired-calculate-columns files across)) | |
3654 (ncols (length columns)) | |
3655 (ncols1 (1- ncols)) | |
3656 (nfiles (length files)) | |
3657 (nrows (+ (/ nfiles ncols) | |
3658 (if (zerop (% nfiles ncols)) 0 1))) | |
3659 (space-left (- (window-width) (apply '+ columns) 1)) | |
3660 (i 0) | |
3661 (j 0) | |
3662 file padding stretch float-stretch) | |
3663 (if (zerop ncols1) | |
3664 (setq stretch 0 | |
3665 float-stretch 0) | |
3666 (setq stretch (/ space-left ncols1) | |
3667 float-stretch (% space-left ncols1))) | |
3668 (setq files (nconc (copy-sequence files) ; fill up with empty fns | |
3669 (make-list (- (* ncols nrows) nfiles) ""))) | |
3670 (setcdr (nthcdr (1- (length files)) files) files) ; make circular | |
3671 (while (< j nrows) | |
3672 (while (< i ncols) | |
3673 (princ (setq file (car files))) | |
3674 (setq padding (- (nth i columns) (length file))) | |
3675 (or (= i ncols1) | |
3676 (progn | |
3677 (setq padding (+ padding stretch)) | |
3678 (if (< i float-stretch) (setq padding (1+ padding))))) | |
3679 (princ (make-string padding ?\ )) | |
3680 (setq files (if across (cdr files) (nthcdr nrows files)) | |
3681 i (1+ i))) | |
3682 (princ "\n") | |
3683 (setq i 0 | |
3684 j (1+ j)) | |
3685 (or across (setq files (cdr files)))) | |
3686 nrows))) | |
3687 | |
3688 (defun dired-query (qs-var qs-prompt &rest qs-args) | |
3689 ;; Query user and return nil or t. | |
3690 ;; Store answer in symbol VAR (which must initially be bound to nil). | |
3691 ;; Format PROMPT with ARGS. | |
3692 ;; Binding variable help-form will help the user who types C-h. | |
3693 (let* ((char (symbol-value qs-var)) | |
3694 (action (cdr (assoc char dired-query-alist)))) | |
3695 (cond ((eq 'yes action) | |
3696 t) ; accept, and don't ask again | |
3697 ((eq 'no action) | |
3698 nil) ; skip, and don't ask again | |
3699 (t;; no lasting effects from last time we asked - ask now | |
3700 (let ((qprompt (concat qs-prompt | |
3701 (if help-form | |
3702 (format " [yn!q or %s] " | |
3703 (key-description | |
3704 (char-to-string help-char))) | |
3705 " [ynq or !] "))) | |
3706 (dired-in-query t) | |
3707 elt) | |
3708 ;; Actually it looks nicer without cursor-in-echo-area - you can | |
3709 ;; look at the dired buffer instead of at the prompt to decide. | |
3710 (apply 'message qprompt qs-args) | |
3711 (setq char (set qs-var (read-char))) | |
3712 (while (not (setq elt (assoc char dired-query-alist))) | |
3713 (message "Invalid char - type %c for help." help-char) | |
3714 (ding) | |
3715 (sit-for 1) | |
3716 (apply 'message qprompt qs-args) | |
3717 (setq char (set qs-var (read-char)))) | |
3718 (memq (cdr elt) '(t y yes))))))) | |
3719 | |
3720 (defun dired-mark-confirm (op-symbol operation arg) | |
3721 ;; Request confirmation from the user that the operation described | |
3722 ;; by OP-SYMBOL is to be performed on the marked files. | |
3723 ;; Confirmation consists in a y-or-n question with a file list | |
3724 ;; pop-up unless OP-SYMBOL is a member of `dired-no-confirm'. | |
3725 ;; OPERATION is a string describing the operation. Used for prompting | |
3726 ;; the user. | |
3727 ;; The files used are determined by ARG (like in dired-get-marked-files). | |
3728 (or (memq op-symbol dired-no-confirm) | |
3729 (let ((files (dired-get-marked-files t arg))) | |
3730 (dired-mark-pop-up nil op-symbol files (function y-or-n-p) | |
3731 (concat operation " " | |
3732 (dired-mark-prompt arg files) "? "))))) | |
3733 | |
3734 (defun dired-mark-read-file-name (prompt dir op-symbol arg files) | |
3735 (dired-mark-pop-up | |
3736 nil op-symbol files | |
3737 (function read-file-name) | |
3738 (format prompt (dired-mark-prompt arg files)) dir)) | |
3739 | |
3740 (defun dired-mark-read-string (prompt initial op-symbol arg files | |
3741 &optional history-sym) | |
3742 ;; Reading arguments with history. | |
3743 ;; Read arguments for a mark command of type OP-SYMBOL, | |
3744 ;; perhaps popping up the list of marked files. | |
3745 ;; ARG is the prefix arg and indicates whether the files came from | |
3746 ;; marks (ARG=nil) or a repeat factor (integerp ARG). | |
3747 ;; If the current file was used, the list has but one element and ARG | |
3748 ;; does not matter. (It is non-nil, non-integer in that case, namely '(4)). | |
3749 ;; PROMPT for a string, with INITIAL input. | |
3750 (dired-mark-pop-up | |
3751 nil op-symbol files | |
3752 (function | |
3753 (lambda (prompt initial) | |
3754 (let ((hist (or history-sym | |
3755 (cdr (assq op-symbol dired-op-history-alist)) | |
3756 'dired-history))) | |
3757 (dired-read-with-history prompt initial hist)))) | |
3758 (format prompt (dired-mark-prompt arg files)) initial)) | |
3759 | |
3760 | |
3761 ;;;; ---------------------------------------------------------- | |
3762 ;;;; Marking files. | |
3763 ;;;; ---------------------------------------------------------- | |
3764 | |
3765 (defun dired-mark (arg &optional char) | |
3766 "Mark the current (or next ARG) files. | |
3767 If on a subdir headerline, mark all its files except `.' and `..'. | |
3768 | |
3769 Use \\[dired-unmark-all-files] to remove all marks, | |
3770 and \\[dired-unmark] to remove the mark of the current file." | |
3771 (interactive "p") | |
3772 (if (dired-get-subdir) | |
3773 (dired-mark-subdir-files char) | |
3774 (dired-mark-file arg char))) | |
3775 | |
3776 (defun dired-mark-file (arg &optional char) | |
3777 "Mark ARG files starting from the current file line. | |
3778 Optional CHAR indicates a marker character to use." | |
3779 (let (buffer-read-only) | |
3780 (if (memq (or char dired-marker-char) '(?\ ?\n ?\r)) | |
3781 (error "Invalid marker charcter %c" dired-marker-char)) | |
3782 (or char (setq char dired-marker-char)) | |
3783 (dired-repeat-over-lines | |
3784 arg | |
3785 (function | |
3786 (lambda () | |
3787 (dired-update-marker-counters (following-char) t) | |
3788 (dired-substitute-marker (point) (following-char) char) | |
3789 (dired-update-marker-counters char)))) | |
3790 (dired-update-mode-line-modified))) | |
3791 | |
3792 (defun dired-mark-subdir-files (&optional char) | |
3793 "Mark all files except `.' and `..'." | |
3794 (interactive) | |
3795 (save-excursion | |
3796 (dired-mark-files-in-region (dired-subdir-min) (dired-subdir-max) char))) | |
3797 | |
3798 (defun dired-unmark (arg) | |
3799 "Unmark the current (or next ARG) files. | |
3800 If looking at a subdir, unmark all its files except `.' and `..'." | |
3801 (interactive "p") | |
3802 (let (buffer-read-only) | |
3803 (dired-repeat-over-lines | |
3804 arg | |
3805 (function | |
3806 (lambda () | |
3807 (let ((char (following-char))) | |
3808 (or (memq char '(?\ ?\n ?\r)) | |
3809 (progn | |
3810 (cond | |
3811 ((char-equal char dired-marker-char) | |
3812 (setq dired-marks-number (max (1- dired-marks-number) 0))) | |
3813 ((char-equal char dired-del-marker) | |
3814 (setq dired-del-flags-number | |
3815 (max (1- dired-del-flags-number) 0))) | |
3816 ((setq dired-other-marks-number | |
3817 (max (1- dired-other-marks-number) 0)))) | |
3818 (dired-substitute-marker (point) char ?\ ))))))) | |
3819 (dired-update-mode-line-modified))) | |
3820 | |
3821 (defun dired-mark-prefix (&optional arg) | |
3822 "Mark the next ARG files with the next character typed. | |
3823 If ARG is negative, marks the previous files." | |
3824 (interactive "p") | |
3825 (if (sit-for echo-keystrokes) | |
3826 (cond | |
3827 ((or (= arg 1) (zerop arg)) | |
3828 (message "Mark with character?")) | |
3829 ((< arg 0) | |
3830 (message "Mark %d file%s moving backwards?" | |
3831 (- arg) (dired-plural-s (- arg)))) | |
3832 ((> arg 1) | |
3833 (message "Mark %d following files with character?" arg)))) | |
3834 (dired-mark arg (read-char))) | |
3835 | |
3836 (defun dired-change-marks (old new) | |
3837 "Change all OLD marks to NEW marks. | |
3838 OLD and NEW are both characters used to mark files. | |
3839 With a prefix, prompts for a mark to toggle. In other words, all unmarked | |
3840 files receive that mark, and all files currently marked with that mark become | |
3841 unmarked." | |
3842 ;; When used in a lisp program, setting NEW to nil means toggle the mark OLD. | |
3843 (interactive | |
3844 (let* ((cursor-in-echo-area t) | |
3845 (old nil) | |
3846 (new nil) | |
3847 (markers (dired-mark-list)) | |
3848 (default (cond ((null markers) | |
3849 (error "No markers in buffer")) | |
3850 ((= (length markers) 1) | |
3851 (setq old (car markers))) | |
3852 ((memq dired-marker-char markers) | |
3853 dired-marker-char) | |
3854 ;; picks the last one in the buffer. reasonable? | |
3855 ((car markers))))) | |
3856 (or old (setq old | |
3857 (progn | |
3858 (if current-prefix-arg | |
3859 (message "Toggle mark (default %c): " default) | |
3860 (message "Change old mark (default %c): " default)) | |
3861 (read-char)))) | |
3862 (if (memq old '(?\ ?\n ?\r)) (setq old default)) | |
3863 (or current-prefix-arg | |
3864 (setq new (progn | |
3865 (message | |
3866 "Change %c marks to new mark (RET means abort): " old) | |
3867 (read-char)))) | |
3868 (list old new))) | |
3869 (let ((old-count (cond | |
3870 ((char-equal old dired-marker-char) | |
3871 'dired-marks-number) | |
3872 ((char-equal old dired-del-marker) | |
3873 'dired-del-flags-number) | |
3874 ('dired-other-marks-number)))) | |
3875 (if new | |
3876 (or (memq new '(?\ ?\n ?\r)) | |
3877 ;; \n and \r aren't valid marker chars. Assume that if the | |
3878 ;; user hits return, he meant to abort the command. | |
3879 (let ((string (format "\n%c" old)) | |
3880 (new-count (cond | |
3881 ((char-equal new dired-marker-char) | |
3882 'dired-marks-number) | |
3883 ((char-equal new dired-del-marker) | |
3884 'dired-del-flags-number) | |
3885 ('dired-other-marks-number))) | |
3886 (buffer-read-only nil)) | |
3887 (save-excursion | |
3888 (goto-char (point-min)) | |
3889 (while (search-forward string nil t) | |
3890 (if (char-equal (preceding-char) old) | |
3891 (progn | |
3892 (dired-substitute-marker (1- (point)) old new) | |
3893 (set new-count (1+ (symbol-value new-count))) | |
3894 (set old-count (max (1- (symbol-value old-count)) 0)))) | |
3895 )))) | |
3896 (save-excursion | |
3897 (let ((ucount 0) | |
3898 (mcount 0) | |
3899 (buffer-read-only nil)) | |
3900 (goto-char (point-min)) | |
3901 (while (not (eobp)) | |
3902 (or (dired-between-files) | |
3903 (looking-at dired-re-dot) | |
3904 (cond | |
3905 ((= (following-char) ?\ ) | |
3906 (setq mcount (1+ mcount)) | |
3907 (set old-count (1+ (symbol-value old-count))) | |
3908 (dired-substitute-marker (point) ?\ old)) | |
3909 ((= (following-char) old) | |
3910 (setq ucount (1+ ucount)) | |
3911 (set old-count (max (1- (symbol-value old-count)) 0)) | |
3912 (dired-substitute-marker (point) old ?\ )))) | |
3913 (forward-line 1)) | |
3914 (message "Unmarked %d file%s; marked %d file%s with %c." | |
3915 ucount (dired-plural-s ucount) mcount | |
3916 (dired-plural-s mcount) old))))) | |
3917 (dired-update-mode-line-modified)) | |
3918 | |
3919 (defun dired-unmark-all-files (flag &optional arg) | |
3920 "Remove a specific mark or any mark from every file. | |
3921 With prefix arg, query for each marked file. | |
3922 Type \\[help-command] at that time for help. | |
3923 With a zero prefix, only counts the number of marks." | |
3924 (interactive | |
3925 (let* ((cursor-in-echo-area t) | |
3926 executing-kbd-macro) ; for XEmacs | |
3927 (list (and (not (eq current-prefix-arg 0)) | |
3928 (progn (message "Remove marks (RET means all): ") (read-char))) | |
3929 current-prefix-arg))) | |
3930 (save-excursion | |
3931 (let* ((help-form "\ | |
3932 Type SPC or `y' to unflag one file, DEL or `n' to skip to next, | |
3933 `!' to unflag all remaining files with no more questions.") | |
3934 (allp (memq flag '(?\n ?\r))) | |
3935 (count-p (eq arg 0)) | |
3936 (count (if (or allp count-p) | |
3937 (mapcar | |
3938 (function | |
3939 (lambda (elt) | |
3940 (cons elt 0))) | |
3941 (nreverse (dired-mark-list))) | |
3942 0)) | |
3943 (msg "") | |
3944 (no-query (or (not arg) count-p)) | |
3945 buffer-read-only case-fold-search query) | |
3946 (goto-char (point-min)) | |
3947 (if (or allp count-p) | |
3948 (while (re-search-forward dired-re-mark nil t) | |
3949 (if (or no-query | |
3950 (dired-query 'query "Unmark file `%s'? " | |
3951 (dired-get-filename t))) | |
3952 (let ((ent (assq (preceding-char) count))) | |
3953 (if ent (setcdr ent (1+ (cdr ent)))) | |
3954 (or count-p (dired-substitute-marker | |
3955 (- (point) 1) (preceding-char) ?\ )))) | |
3956 (forward-line 1)) | |
3957 (while (search-forward (format "\n%c" flag) nil t) | |
3958 (if (or no-query | |
3959 (dired-query 'query "Unmark file `%s'? " | |
3960 (dired-get-filename t))) | |
3961 (progn | |
3962 (dired-substitute-marker (match-beginning 0) flag ?\ ) | |
3963 (setq count (1+ count)))))) | |
3964 (if (or allp count-p) | |
3965 (mapcar | |
3966 (function | |
3967 (lambda (elt) | |
3968 (or (zerop (cdr elt)) | |
3969 (setq msg (format "%s%s%d %c%s" | |
3970 msg | |
3971 (if (zerop (length msg)) | |
3972 " " | |
3973 ", ") | |
3974 (cdr elt) | |
3975 (car elt) | |
3976 (if (= 1 (cdr elt)) "" "'s")))))) | |
3977 count) | |
3978 (or (zerop count) | |
3979 (setq msg (format " %d %c%s" | |
3980 count flag (if (= 1 count) "" "'s"))))) | |
3981 (if (zerop (length msg)) | |
3982 (setq msg " none") | |
3983 (or count-p (dired-update-mode-line-modified t))) | |
3984 (message "%s:%s" (if count-p "Number of marks" "Marks removed") msg)))) | |
3985 | |
3986 (defun dired-get-marked-files (&optional localp arg) | |
3987 "Return the marked files' names as list of strings. | |
3988 The list is in the same order as the buffer, that is, the car is the | |
3989 first marked file. | |
3990 Values returned are normally absolute pathnames. | |
3991 Optional arg LOCALP as in `dired-get-filename'. | |
3992 Optional second argument ARG forces to use other files. If ARG is an | |
3993 integer, use the next ARG files. If ARG is otherwise non-nil, use | |
3994 current file. Usually ARG comes from the current prefix arg." | |
3995 (save-excursion | |
3996 (nreverse (dired-map-over-marks (dired-get-filename localp) arg)))) | |
3997 | |
3998 ;;; Utility functions for marking files | |
3999 | |
4000 (defun dired-mark-files-in-region (start end &optional char) | |
4001 (let (buffer-read-only) | |
4002 (if (> start end) | |
4003 (error "start > end")) | |
4004 (goto-char start) ; assumed at beginning of line | |
4005 (or char (setq char dired-marker-char)) | |
4006 (while (< (point) end) | |
4007 ;; Skip subdir line and following garbage like the `total' line: | |
4008 (while (and (< (point) end) (dired-between-files)) | |
4009 (forward-line 1)) | |
4010 (if (and (/= (following-char) char) | |
4011 (not (looking-at dired-re-dot)) | |
4012 (save-excursion | |
4013 (dired-move-to-filename nil (point)))) | |
4014 (progn | |
4015 (dired-update-marker-counters (following-char) t) | |
4016 (dired-substitute-marker (point) (following-char) char) | |
4017 (dired-update-marker-counters char))) | |
4018 (forward-line 1))) | |
4019 (dired-update-mode-line-modified)) | |
4020 | |
4021 (defun dired-mark-list () | |
4022 ;; Returns a list of all marks currently used in the buffer. | |
4023 (let ((result nil) | |
4024 char) | |
4025 (save-excursion | |
4026 (goto-char (point-min)) | |
4027 (while (not (eobp)) | |
4028 (and (not (memq (setq char (following-char)) '(?\ ?\n ?\r))) | |
4029 (not (memq char result)) | |
4030 (setq result (cons char result))) | |
4031 (forward-line 1))) | |
4032 result)) | |
4033 | |
4034 ;;; Dynamic markers | |
4035 | |
4036 (defun dired-set-current-marker-string () | |
4037 "Computes and returns `dired-marker-string'." | |
4038 (prog1 | |
4039 (setq dired-marker-string | |
4040 (if dired-marker-stack | |
4041 (let* ((n (+ (length dired-marker-stack) 5)) | |
4042 (str (make-string n ?\ )) | |
4043 (list dired-marker-stack) | |
4044 (pointer dired-marker-stack-pointer)) | |
4045 (setq n (1- n)) | |
4046 (aset str n ?\]) | |
4047 (setq n (1- n)) | |
4048 (while list | |
4049 (aset str n (car list)) | |
4050 (if (zerop pointer) | |
4051 (progn | |
4052 (setq n (1- n)) | |
4053 (aset str n dired-marker-stack-cursor))) | |
4054 (setq n (1- n) | |
4055 pointer (1- pointer) | |
4056 list (cdr list))) | |
4057 (aset str n dired-default-marker) | |
4058 (if (zerop pointer) | |
4059 (aset str 2 dired-marker-stack-cursor)) | |
4060 (aset str 1 ?\[) | |
4061 str) | |
4062 "")) | |
4063 (set-buffer-modified-p (buffer-modified-p)))) | |
4064 | |
4065 (defun dired-set-marker-char (c) | |
4066 "Set the marker character to something else. | |
4067 Use \\[dired-restore-marker-char] to restore the previous value." | |
4068 (interactive "cNew marker character: ") | |
4069 (and (memq c '(?\ ?\n ?\r)) (error "invalid marker char %c" c)) | |
4070 (setq dired-marker-stack (cons c dired-marker-stack) | |
4071 dired-marker-stack-pointer 0 | |
4072 dired-marker-char c) | |
4073 (dired-update-mode-line-modified t) | |
4074 (dired-set-current-marker-string)) | |
4075 | |
4076 (defun dired-restore-marker-char () | |
4077 "Restore the marker character to its previous value. | |
4078 Uses `dired-default-marker' if the marker stack is empty." | |
4079 (interactive) | |
4080 (setq dired-marker-stack (cdr dired-marker-stack) | |
4081 dired-marker-char (car dired-marker-stack) | |
4082 dired-marker-stack-pointer (min dired-marker-stack-pointer | |
4083 (length dired-marker-stack))) | |
4084 (or dired-marker-char | |
4085 (setq dired-marker-char dired-default-marker)) | |
4086 (dired-set-current-marker-string) | |
4087 (dired-update-mode-line-modified t) | |
4088 (or dired-marker-stack (message "Marker is %c" dired-marker-char))) | |
4089 | |
4090 (defun dired-marker-stack-left (n) | |
4091 "Moves the marker stack cursor to the left." | |
4092 (interactive "p") | |
4093 (let ((len (1+ (length dired-marker-stack)))) | |
4094 (or dired-marker-stack (error "Dired marker stack is empty.")) | |
4095 (setq dired-marker-stack-pointer | |
4096 (% (+ dired-marker-stack-pointer n) len)) | |
4097 (if (< dired-marker-stack-pointer 0) | |
4098 (setq dired-marker-stack-pointer (+ dired-marker-stack-pointer | |
4099 len))) | |
4100 (dired-set-current-marker-string) | |
4101 (setq dired-marker-char | |
4102 (if (= dired-marker-stack-pointer (1- len)) | |
4103 dired-default-marker | |
4104 (nth dired-marker-stack-pointer dired-marker-stack)))) | |
4105 (dired-update-mode-line-modified t)) | |
4106 | |
4107 (defun dired-marker-stack-right (n) | |
4108 "Moves the marker stack cursor to the right." | |
4109 (interactive "p") | |
4110 (dired-marker-stack-left (- n))) | |
4111 | |
4112 ;;; Commands to mark or flag files based on their characteristics or names. | |
4113 | |
4114 (defun dired-mark-symlinks (&optional unflag-p) | |
4115 "Mark all symbolic links. | |
4116 With prefix argument, unflag all those files." | |
4117 (interactive "P") | |
4118 (dired-check-ls-l) | |
4119 (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) | |
4120 (dired-mark-if (looking-at dired-re-sym) "symbolic link")) | |
4121 (dired-update-mode-line-modified t)) | |
4122 | |
4123 (defun dired-mark-directories (&optional unflag-p) | |
4124 "Mark all directory file lines except `.' and `..'. | |
4125 With prefix argument, unflag all those files." | |
4126 (interactive "P") | |
4127 (if dired-re-dir | |
4128 (progn | |
4129 (dired-check-ls-l) | |
4130 (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) | |
4131 (dired-mark-if (and (looking-at dired-re-dir) | |
4132 (not (looking-at dired-re-dot))) | |
4133 "directory file")))) | |
4134 (dired-update-mode-line-modified t)) | |
4135 | |
4136 (defun dired-mark-executables (&optional unflag-p) | |
4137 "Mark all executable files. | |
4138 With prefix argument, unflag all those files." | |
4139 (interactive "P") | |
4140 (if dired-re-exe | |
4141 (progn | |
4142 (dired-check-ls-l) | |
4143 (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) | |
4144 (dired-mark-if (looking-at dired-re-exe) "executable file")))) | |
4145 (dired-update-mode-line-modified t)) | |
4146 | |
4147 (defun dired-flag-backup-files (&optional unflag-p) | |
4148 "Flag all backup files (names ending with `~') for deletion. | |
4149 With prefix argument, unflag these files." | |
4150 (interactive "P") | |
4151 (dired-check-ls-l) | |
4152 (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))) | |
4153 (dired-mark-if | |
4154 (and (not (and dired-re-dir (looking-at dired-re-dir))) | |
4155 (let ((fn (dired-get-filename t t))) | |
4156 (if fn (backup-file-name-p fn)))) | |
4157 "backup file")) | |
4158 (dired-update-mode-line-modified t)) | |
4159 | |
4160 (defun dired-flag-auto-save-files (&optional unflag-p) | |
4161 "Flag for deletion files whose names suggest they are auto save files. | |
4162 A prefix argument says to unflag those files instead." | |
4163 (interactive "P") | |
4164 (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))) | |
4165 (dired-mark-if | |
4166 ;; It is less than general to check for ~ here, | |
4167 ;; but it's the only way this runs fast enough. | |
4168 (and (save-excursion (end-of-line) | |
4169 (eq (preceding-char) ?#)) | |
4170 (not (and dired-re-dir (looking-at dired-re-dir))) | |
4171 (let ((fn (dired-get-filename t t))) | |
4172 (if fn (auto-save-file-name-p | |
4173 (file-name-nondirectory fn))))) | |
4174 "auto save file")) | |
4175 (dired-update-mode-line-modified t)) | |
4176 | |
4177 (defun dired-mark-rcs-files (&optional unflag-p) | |
4178 "Mark all files that are under RCS control. | |
4179 With prefix argument, unflag all those files. | |
4180 Mentions RCS files for which a working file was not found in this buffer. | |
4181 Type \\[dired-why] to see them again." | |
4182 ;; Returns failures, or nil on success. | |
4183 ;; Finding those with locks would require to peek into the ,v file, | |
4184 ;; depends slightly on the RCS version used and should be done | |
4185 ;; together with the Emacs RCS interface. | |
4186 ;; Unfortunately, there is no definitive RCS interface yet. | |
4187 (interactive "P") | |
4188 (message "%sarking RCS controlled files..." (if unflag-p "Unm" "M")) | |
4189 (let ((dired-marker-char (if unflag-p ?\ dired-marker-char)) | |
4190 rcs-files wf failures count total) | |
4191 (mapcar ; loop over subdirs | |
4192 (function | |
4193 (lambda (dir) | |
4194 (or (equal (file-name-nondirectory (directory-file-name dir)) | |
4195 "RCS") | |
4196 ;; skip inserted RCS subdirs | |
4197 (setq rcs-files | |
4198 (append (directory-files dir t ",v$") ; *,v and RCS/*,v | |
4199 (let ((rcs-dir (expand-file-name "RCS" dir))) | |
4200 (if (file-directory-p rcs-dir) | |
4201 (mapcar ; working files from ./RCS are in ./ | |
4202 (function | |
4203 (lambda (x) | |
4204 (expand-file-name x dir))) | |
4205 (directory-files | |
4206 (file-name-as-directory rcs-dir) | |
4207 nil ",v$")))) | |
4208 rcs-files))))) | |
4209 (mapcar (function car) dired-subdir-alist)) | |
4210 (setq total (length rcs-files)) | |
4211 (while rcs-files | |
4212 (setq wf (substring (car rcs-files) 0 -2) | |
4213 rcs-files (cdr rcs-files)) | |
4214 (save-excursion (if (dired-goto-file wf) | |
4215 (dired-mark 1) ; giving a prefix avoids checking | |
4216 ; for subdir line. | |
4217 (setq failures (cons wf failures))))) | |
4218 (dired-update-mode-line-modified t) | |
4219 (if (null failures) | |
4220 (message "%d RCS file%s %smarked." | |
4221 total (dired-plural-s total) (if unflag-p "un" "")) | |
4222 (setq count (length failures)) | |
4223 (dired-log-summary (buffer-name (current-buffer)) | |
4224 "RCS working file not found %s" failures) | |
4225 (message "%d RCS file%s: %d %smarked - %d not found %s." | |
4226 total (dired-plural-s total) (- total count) | |
4227 (if unflag-p "un" "") count failures)) | |
4228 failures)) | |
4229 | |
4230 | |
4231 ;;;; ------------------------------------------------------------ | |
4232 ;;;; Logging failures | |
4233 ;;;; ------------------------------------------------------------ | |
4234 | |
4235 (defun dired-why () | |
4236 "Pop up a buffer with error log output from Dired. | |
4237 A group of errors from a single command ends with a formfeed. | |
4238 Thus, use \\[backward-page] to find the beginning of a group of errors." | |
4239 (interactive) | |
4240 (if (get-buffer dired-log-buffer) | |
4241 (let ((owindow (selected-window)) | |
4242 (window (display-buffer (get-buffer dired-log-buffer)))) | |
4243 (unwind-protect | |
4244 (progn | |
4245 (select-window window) | |
4246 (goto-char (point-max)) | |
4247 (recenter -1)) | |
4248 (select-window owindow))))) | |
4249 | |
4250 (defun dired-log (buffer-name log &rest args) | |
4251 ;; Log a message or the contents of a buffer. | |
4252 ;; BUFFER-NAME is the name of the dired buffer to which the message applies. | |
4253 ;; If LOG is a string and there are more args, it is formatted with | |
4254 ;; those ARGS. Usually the LOG string ends with a \n. | |
4255 ;; End each bunch of errors with (dired-log t): this inserts | |
4256 ;; current time and buffer, and a \f (formfeed). | |
4257 (or (stringp buffer-name) (setq buffer-name (buffer-name buffer-name))) | |
4258 (let ((obuf (current-buffer))) | |
4259 (unwind-protect ; want to move point | |
4260 (progn | |
4261 (set-buffer (get-buffer-create dired-log-buffer)) | |
4262 (goto-char (point-max)) | |
4263 (let (buffer-read-only) | |
4264 (cond ((stringp log) | |
4265 (insert (if args | |
4266 (apply (function format) log args) | |
4267 log))) | |
4268 ((bufferp log) | |
4269 (insert-buffer log)) | |
4270 ((eq t log) | |
4271 (insert "\n\t" (current-time-string) | |
4272 "\tBuffer `" buffer-name "'\n\f\n"))))) | |
4273 (set-buffer obuf)))) | |
4274 | |
4275 (defun dired-log-summary (buffer-name string failures) | |
4276 (message (if failures "%s--type y for details %s" | |
4277 "%s--type y for details") | |
4278 string failures) | |
4279 ;; Log a summary describing a bunch of errors. | |
4280 (dired-log buffer-name (concat "\n" string)) | |
4281 (if failures (dired-log buffer-name "\n%s" failures)) | |
4282 (dired-log buffer-name t)) | |
4283 | |
4284 | |
4285 ;;;; ------------------------------------------------------- | |
4286 ;;;; Sort mode of dired buffers. | |
4287 ;;;; ------------------------------------------------------- | |
4288 | |
4289 (defun dired-sort-type (list) | |
4290 ;; Returns the sort type of LIST, as a symbol. | |
4291 (let* ((list (reverse list)) | |
4292 (alist (sort | |
4293 (mapcar (function | |
4294 (lambda (x) | |
4295 (cons (length (memq (car x) list)) (cdr x)))) | |
4296 dired-sort-type-alist) | |
4297 (function | |
4298 (lambda (x y) | |
4299 (> (car x) (car y)))))) | |
4300 (winner (car alist))) | |
4301 (if (zerop (car winner)) | |
4302 'name | |
4303 (cdr winner)))) | |
4304 | |
4305 (defun dired-sort-set-modeline (&optional switches) | |
4306 ;; Set modeline display according to dired-internal-switches. | |
4307 ;; Modeline display of "by name" or "by date" guarantees the user a | |
4308 ;; match with the corresponding regexps. Non-matching switches are | |
4309 ;; shown literally. | |
4310 (or switches (setq switches dired-internal-switches)) | |
4311 (setq dired-sort-mode | |
4312 (if dired-show-ls-switches | |
4313 (concat " " (dired-make-switches-string | |
4314 (or switches dired-internal-switches))) | |
4315 (concat " by " (and (memq ?r switches) "rev-") | |
4316 (symbol-name (dired-sort-type switches))))) | |
4317 ;; update mode line | |
4318 (set-buffer-modified-p (buffer-modified-p))) | |
4319 | |
4320 (defun dired-sort-toggle-or-edit (&optional arg) | |
4321 "Toggle between sort by date/name for the current subdirectory. | |
4322 | |
4323 With a 0 prefix argument, simply reports on the current switches. | |
4324 | |
4325 With a prefix 1 allows the ls switches for the current subdirectory to be | |
4326 edited. | |
4327 | |
4328 With a prefix 2 allows the default ls switches for newly inserted | |
4329 subdirectories to be edited. | |
4330 | |
4331 With a prefix \\[universal-argument] allows you to sort the entire | |
4332 buffer by either name or date. | |
4333 | |
4334 With a prefix \\[universal-argument] \\[universal-argument] allows the default switches | |
4335 for the entire buffer to be edited, and then reverts the buffer so that all | |
4336 subdirectories are sorted according to these switches. | |
4337 | |
4338 Note that although dired allows different ls switches to be used for | |
4339 different subdirectories, certain combinations of ls switches are incompatible. | |
4340 If incompatible switches are detected, dired will offer to revert the buffer | |
4341 to force the ls switches for all subdirectories to a single value. If you | |
4342 refuse to revert the buffer, any change of ls switches will be aborted." | |
4343 (interactive "P") | |
4344 (cond | |
4345 ((eq arg 0) | |
4346 ;; Report on switches | |
4347 (message "Switches for current subdir: %s. Default for buffer: %s." | |
4348 (dired-make-switches-string | |
4349 (nth 3 (assoc (dired-current-directory) dired-subdir-alist))) | |
4350 (dired-make-switches-string dired-internal-switches))) | |
4351 ((null arg) | |
4352 ;; Toggle between sort by date/name. | |
4353 (let* ((dir (dired-current-directory)) | |
4354 (curr (nth 3 (assoc dir dired-subdir-alist)))) | |
4355 (dired-sort-other | |
4356 (if (eq (dired-sort-type curr) 'name) | |
4357 (cons ?t curr) | |
4358 (mapcar (function | |
4359 (lambda (x) | |
4360 (setq curr | |
4361 (delq (car x) curr)))) | |
4362 dired-sort-type-alist) | |
4363 curr) | |
4364 nil dir))) | |
4365 ((eq arg 1) | |
4366 ;; Edit switches for current subdir. | |
4367 (let* ((dir (dired-current-directory)) | |
4368 (switch-string | |
4369 (read-string | |
4370 "New ls switches for current subdir (must contain -l): " | |
4371 (dired-make-switches-string | |
4372 (nth 3 (assoc dir dired-subdir-alist))))) | |
4373 (switches (dired-make-switches-list switch-string))) | |
4374 (if (dired-compatible-switches-p switches dired-internal-switches) | |
4375 (dired-sort-other switches nil dir) | |
4376 (if (or | |
4377 (memq 'sort-revert dired-no-confirm) | |
4378 (y-or-n-p | |
4379 (format | |
4380 "Switches %s incompatible with default %s. Revert buffer? " | |
4381 switch-string | |
4382 (dired-make-switches-string dired-internal-switches)))) | |
4383 (dired-sort-other switches nil nil) | |
4384 (error "Switches unchanged. Remain as %s." switch-string))))) | |
4385 ((eq arg 2) | |
4386 ;; Set new defaults for subdirs inserted in the future. | |
4387 (let* ((switch-string | |
4388 (read-string | |
4389 "Default ls switches for new subdirs (must contain -l): " | |
4390 (dired-make-switches-string dired-internal-switches))) | |
4391 (switches (dired-make-switches-list switch-string)) | |
4392 (alist dired-subdir-alist) | |
4393 x bad-switches) | |
4394 (while alist | |
4395 (setq x (nth 3 (car alist)) | |
4396 alist (cdr alist)) | |
4397 (or (dired-compatible-switches-p x switches) | |
4398 (member x bad-switches) | |
4399 (setq bad-switches (cons x bad-switches)))) | |
4400 (if bad-switches | |
4401 (if (or (memq 'sort-revert dired-no-confirm) | |
4402 (y-or-n-p | |
4403 (format | |
4404 "Switches %s incompatible with %s. Revert buffer? " | |
4405 switch-string (mapconcat 'dired-make-switches-string | |
4406 bad-switches ", ")))) | |
4407 (dired-sort-other switches nil nil) | |
4408 (error "Default switches unchanged. Remain as %s." | |
4409 (dired-make-switches-string dired-internal-switches))) | |
4410 (dired-sort-other switches t nil)))) | |
4411 ((or (equal arg '(4)) (eq arg 'date) (eq arg 'name)) | |
4412 ;; Toggle the entire buffer name/data. | |
4413 (let ((cursor-in-echo-area t) | |
4414 (switches (copy-sequence dired-internal-switches)) | |
4415 (type (and (symbolp arg) arg)) | |
4416 char) | |
4417 (while (null type) | |
4418 (message "Sort entire buffer according to (n)ame or (d)ate? ") | |
4419 (setq char (read-char) | |
4420 type (cond | |
4421 ((char-equal char ?d) 'date) | |
4422 ((char-equal char ?n) 'name) | |
4423 (t (message "Type one of n or d.") (sit-for 1) nil)))) | |
4424 (mapcar (function | |
4425 (lambda (x) | |
4426 (setq switches | |
4427 (delq (car x) switches)))) | |
4428 dired-sort-type-alist) | |
4429 (dired-sort-other | |
4430 (if (eq type 'date) (cons ?t switches) switches) nil nil))) | |
4431 ((equal arg '(16)) | |
4432 ;; Edit the switches for the entire buffer. | |
4433 (dired-sort-other | |
4434 (dired-make-switches-list | |
4435 (read-string | |
4436 "Change ls switches for entire buffer to (must contain -l): " | |
4437 (dired-make-switches-string dired-internal-switches))) | |
4438 nil nil)) | |
4439 (t | |
4440 ;; No idea what's going on. | |
4441 (error | |
4442 "Invalid prefix. See %s dired-sort-toggle-or-edit." | |
4443 (substitute-command-keys | |
4444 (if (featurep 'ehelp) | |
4445 "\\[electric-describe-function]" | |
4446 "\\[describe-function]")))))) | |
4447 | |
4448 (defun dired-sort-other (switches &optional no-revert subdir) | |
4449 ;; Specify new ls SWITCHES for current dired buffer. | |
4450 ;; With optional second arg NO-REVERT, don't refresh the listing afterwards. | |
4451 ;; If subdir is non-nil, only changes the switches for the | |
4452 ;; sudirectory. | |
4453 (if subdir | |
4454 (let ((elt (assoc subdir dired-subdir-alist))) | |
4455 (if elt (setcar (nthcdr 3 elt) switches))) | |
4456 (setq dired-internal-switches switches)) | |
4457 (or no-revert | |
4458 (cond | |
4459 | |
4460 (subdir | |
4461 (let ((ofile (dired-get-filename nil t)) | |
4462 (opoint (point))) | |
4463 (message "Relisting %s..." subdir) | |
4464 (dired-insert-subdir subdir switches) | |
4465 (message "Relisting %s... done" subdir) | |
4466 (or (and ofile (dired-goto-file ofile)) (goto-char opoint)))) | |
4467 | |
4468 ((memq ?R switches) | |
4469 ;; We are replacing a buffer with a giant recursive listing. | |
4470 (let ((opoint (point)) | |
4471 (ofile (dired-get-filename nil t)) | |
4472 (hidden-subdirs (dired-remember-hidden)) | |
4473 (mark-alist (dired-remember-marks (point-min) (point-max))) | |
4474 (kill-files-p (save-excursion | |
4475 (goto-char (point)) | |
4476 (search-forward | |
4477 (concat (char-to-string ?\r) | |
4478 (regexp-quote | |
4479 (char-to-string | |
4480 dired-kill-marker-char))) | |
4481 nil t))) | |
4482 (omit-files (nth 2 (nth (1- (length dired-subdir-alist)) | |
4483 dired-subdir-alist))) | |
4484 buffer-read-only) | |
4485 (dired-readin dired-directory (current-buffer) | |
4486 (or (consp dired-directory) | |
4487 (null (file-directory-p dired-directory)))) | |
4488 (dired-mark-remembered mark-alist) ; mark files that were marked | |
4489 (if kill-files-p (dired-do-hide dired-kill-marker-char)) | |
4490 (if omit-files | |
4491 (dired-omit-expunge nil t)) | |
4492 ;; hide subdirs that were hidden | |
4493 (save-excursion | |
4494 (mapcar (function (lambda (dir) | |
4495 (if (dired-goto-subdir dir) | |
4496 (dired-hide-subdir 1)))) | |
4497 hidden-subdirs)) | |
4498 ;; Try to get back to where we were | |
4499 (or (and ofile (dired-goto-file ofile)) | |
4500 (goto-char opoint)) | |
4501 (dired-move-to-filename))) | |
4502 | |
4503 (t | |
4504 ;; Clear all switches in the subdir alist | |
4505 (setq dired-subdir-alist | |
4506 (mapcar (function | |
4507 (lambda (x) | |
4508 (setcar (nthcdr 3 x) nil) | |
4509 x)) | |
4510 dired-subdir-alist)) | |
4511 (revert-buffer nil t)))) | |
4512 (dired-update-mode-line t)) | |
4513 | |
4514 (defun dired-compatible-switches-p (list1 list2) | |
4515 ;; Returns t if list1 and list2 are allowed as switches in the same | |
4516 ;; dired buffer. | |
4517 (and (eq (null (or (memq ?l list1) (memq ?o list1) (memq ?g list1))) | |
4518 (null (or (memq ?l list2) (memq ?o list2) (memq ?g list2)))) | |
4519 (eq (null (memq ?F list1)) (null (memq ?F list2))) | |
4520 (eq (null (memq ?p list1)) (null (memq ?p list2))) | |
4521 (eq (null (memq ?b list1)) (null (memq ?b list2))))) | |
4522 | |
4523 (defun dired-check-ls-l (&optional switches) | |
4524 ;; Check for long-style listings | |
4525 (let ((switches (or switches dired-internal-switches))) | |
4526 (or (memq ?l switches) (memq ?o switches) (memq ?g switches) | |
4527 (error "Dired needs -l, -o, or -g in ls switches")))) | |
4528 | |
4529 | |
4530 ;;;; -------------------------------------------------------------- | |
4531 ;;;; Creating new files. | |
4532 ;;;; -------------------------------------------------------------- | |
4533 ;;; | |
4534 ;;; The dired-create-files paradigm is used for copying, renaming, | |
4535 ;;; compressing, and making hard and soft links. | |
4536 | |
4537 (defun dired-file-marker (file) | |
4538 ;; Return FILE's marker, or nil if unmarked. | |
4539 (save-excursion | |
4540 (and (dired-goto-file file) | |
4541 (progn | |
4542 (skip-chars-backward "^\n\r") | |
4543 (and (not (= ?\040 (following-char))) | |
4544 (following-char)))))) | |
4545 | |
4546 ;; The basic function for half a dozen variations on cp/mv/ln/ln -s. | |
4547 (defun dired-create-files (file-creator operation fn-list name-constructor | |
4548 &optional marker-char query | |
4549 implicit-to) | |
4550 ;; Create a new file for each from a list of existing files. The user | |
4551 ;; is queried, dired buffers are updated, and at the end a success or | |
4552 ;; failure message is displayed | |
4553 | |
4554 ;; FILE-CREATOR must accept three args: oldfile newfile ok-if-already-exists | |
4555 ;; It is called for each file and must create newfile, the entry of | |
4556 ;; which will be added. The user will be queried if the file already | |
4557 ;; exists. If oldfile is removed by FILE-CREATOR (i.e, it is a | |
4558 ;; rename), it is FILE-CREATOR's responsibility to update dired | |
4559 ;; buffers. FILE-CREATOR must abort by signalling a file-error if it | |
4560 ;; could not create newfile. The error is caught and logged. | |
4561 | |
4562 ;; OPERATION (a capitalized string, e.g. `Copy') describes the | |
4563 ;; operation performed. It is used for error logging. | |
4564 | |
4565 ;; FN-LIST is the list of files to copy (full absolute pathnames). | |
4566 | |
4567 ;; NAME-CONSTRUCTOR returns a newfile for every oldfile, or nil to | |
4568 ;; skip. If it skips files, it is supposed to tell why (using dired-log). | |
4569 | |
4570 ;; Optional MARKER-CHAR is a character with which to mark every | |
4571 ;; newfile's entry, or t to use the current marker character if the | |
4572 ;; oldfile was marked. | |
4573 | |
4574 ;; QUERY is a function to use to prompt the user about creating a file. | |
4575 ;; It accepts two args, the from and to files, | |
4576 ;; and must return nil or t. If QUERY is nil, then no user | |
4577 ;; confirmation will be requested. | |
4578 | |
4579 ;; If IMPLICIT-TO is non-nil, then the file constructor does not take | |
4580 ;; a to-file arg. e.g. compress. | |
4581 | |
4582 (let ((success-count 0) | |
4583 (total (length fn-list)) | |
4584 failures skipped overwrite-query) | |
4585 ;; Fluid vars used for storing responses of previous queries must be | |
4586 ;; initialized. | |
4587 (dired-save-excursion | |
4588 (setq dired-overwrite-backup-query nil | |
4589 dired-file-creator-query nil) | |
4590 (mapcar | |
4591 (function | |
4592 (lambda (from) | |
4593 (let ((to (funcall name-constructor from))) | |
4594 (if to | |
4595 (if (equal to from) | |
4596 (progn | |
4597 (dired-log (buffer-name (current-buffer)) | |
4598 "Cannot %s to same file: %s\n" | |
4599 (downcase operation) from) | |
4600 (setq skipped (cons (dired-make-relative from) skipped))) | |
4601 (if (or (null query) | |
4602 (funcall query from to)) | |
4603 (let* ((overwrite (let (jka-compr-enabled) | |
4604 ;; Don't let jka-compr fool us. | |
4605 (file-exists-p to))) | |
4606 ;; for dired-handle-overwrite | |
4607 (dired-overwrite-confirmed | |
4608 (and overwrite | |
4609 (let ((help-form '(format "\ | |
4610 Type SPC or `y' to overwrite file `%s', | |
4611 DEL or `n' to skip to next, | |
4612 ESC or `q' to not overwrite any of the remaining files, | |
4613 `!' to overwrite all remaining files with no more questions." to))) | |
4614 (dired-query 'overwrite-query | |
4615 "Overwrite %s?" to)))) | |
4616 ;; must determine if FROM is marked before | |
4617 ;; file-creator gets a chance to delete it | |
4618 ;; (in case of a move). | |
4619 (actual-marker-char | |
4620 (cond ((integerp marker-char) marker-char) | |
4621 (marker-char (dired-file-marker from)) | |
4622 (t nil)))) | |
4623 (if (and overwrite (null dired-overwrite-confirmed)) | |
4624 (setq skipped (cons (dired-make-relative from) | |
4625 skipped)) | |
4626 (condition-case err | |
4627 (let ((dired-unhandle-add-files | |
4628 (cons to dired-unhandle-add-files))) | |
4629 (if implicit-to | |
4630 (funcall file-creator from | |
4631 dired-overwrite-confirmed) | |
4632 (funcall file-creator from to | |
4633 dired-overwrite-confirmed)) | |
4634 (setq success-count (1+ success-count)) | |
4635 (message "%s: %d of %d" | |
4636 operation success-count total) | |
4637 (dired-add-file to actual-marker-char)) | |
4638 (file-error ; FILE-CREATOR aborted | |
4639 (progn | |
4640 (setq failures (cons (dired-make-relative from) | |
4641 failures)) | |
4642 (dired-log (buffer-name (current-buffer)) | |
4643 "%s `%s' to `%s' failed:\n%s\n" | |
4644 operation from to err)))))) | |
4645 (setq skipped (cons (dired-make-relative from) skipped)))) | |
4646 (setq skipped (cons (dired-make-relative from) skipped)))))) | |
4647 fn-list) | |
4648 (cond | |
4649 (failures | |
4650 (dired-log-summary | |
4651 (buffer-name (current-buffer)) | |
4652 (format "%s failed for %d of %d file%s" | |
4653 operation (length failures) total | |
4654 (dired-plural-s total)) failures)) | |
4655 (skipped | |
4656 (dired-log-summary | |
4657 (buffer-name (current-buffer)) | |
4658 (format "%s: %d of %d file%s skipped" | |
4659 operation (length skipped) total | |
4660 (dired-plural-s total)) skipped)) | |
4661 (t | |
4662 (message "%s: %s file%s." | |
4663 operation success-count (dired-plural-s success-count))))))) | |
4664 | |
4665 (defun dired-do-create-files (op-symbol file-creator operation arg | |
4666 &optional marker-char | |
4667 prompter how-to) | |
4668 ;; Create a new file for each marked file. | |
4669 ;; Prompts user for target, which is a directory in which to create | |
4670 ;; the new files. Target may be a plain file if only one marked | |
4671 ;; file exists. | |
4672 ;; OP-SYMBOL is the symbol for the operation. Function `dired-mark-pop-up' | |
4673 ;; will determine wether pop-ups are appropriate for this OP-SYMBOL. | |
4674 ;; FILE-CREATOR and OPERATION as in dired-create-files. | |
4675 ;; ARG as in dired-get-marked-files. | |
4676 ;; PROMPTER is a function of one-arg, the list of files, to return a prompt | |
4677 ;; to use for dired-read-file-name. If it is nil, then a default prompt | |
4678 ;; will be used. | |
4679 ;; Optional arg MARKER-CHAR as in dired-create-files. | |
4680 ;; Optional arg HOW-TO determines how to treat target: | |
4681 ;; If HOW-TO is not given (or nil), and target is a directory, the | |
4682 ;; file(s) are created inside the target directory. If target | |
4683 ;; is not a directory, there must be exactly one marked file, | |
4684 ;; else error. | |
4685 ;; If HOW-TO is t, then target is not modified. There must be | |
4686 ;; exactly one marked file, else error. | |
4687 ;; Else HOW-TO is assumed to be a function of one argument, target, | |
4688 ;; that looks at target and returns a value for the into-dir | |
4689 ;; variable. The function dired-into-dir-with-symlinks is provided | |
4690 ;; for the case (common when creating symlinks) that symbolic | |
4691 ;; links to directories are not to be considered as directories | |
4692 ;; (as file-directory-p would if HOW-TO had been nil). | |
4693 | |
4694 (let* ((fn-list (dired-get-marked-files nil arg)) | |
4695 (fn-count (length fn-list)) | |
4696 (cdir (dired-current-directory)) | |
4697 (target (expand-file-name | |
4698 (dired-mark-read-file-name | |
4699 (if prompter | |
4700 (funcall prompter fn-list) | |
4701 (concat operation " %s to: ")) | |
4702 (dired-dwim-target-directory) | |
4703 op-symbol arg (mapcar (function | |
4704 (lambda (fn) | |
4705 (dired-make-relative fn cdir t))) | |
4706 fn-list)))) | |
4707 (into-dir (cond ((null how-to) (file-directory-p target)) | |
4708 ((eq how-to t) nil) | |
4709 (t (funcall how-to target))))) | |
4710 (if (and (> fn-count 1) | |
4711 (not into-dir)) | |
4712 (error "Marked %s: target must be a directory: %s" operation target)) | |
4713 ;; rename-file bombs when moving directories unless we do this: | |
4714 (or into-dir (setq target (directory-file-name target))) | |
4715 (dired-create-files | |
4716 file-creator operation fn-list | |
4717 (if into-dir ; target is a directory | |
4718 (list 'lambda '(from) | |
4719 (list 'expand-file-name '(file-name-nondirectory from) target)) | |
4720 (list 'lambda '(from) target)) | |
4721 marker-char))) | |
4722 | |
4723 (defun dired-into-dir-with-symlinks (target) | |
4724 (and (file-directory-p target) | |
4725 (not (file-symlink-p target)))) | |
4726 ;; This may not always be what you want, especially if target is your | |
4727 ;; home directory and it happens to be a symbolic link, as is often the | |
4728 ;; case with NFS and automounters. Or if you want to make symlinks | |
4729 ;; into directories that themselves are only symlinks, also quite | |
4730 ;; common. | |
4731 ;; So we don't use this function as value for HOW-TO in | |
4732 ;; dired-do-symlink, which has the minor disadvantage of | |
4733 ;; making links *into* a symlinked-dir, when you really wanted to | |
4734 ;; *overwrite* that symlink. In that (rare, I guess) case, you'll | |
4735 ;; just have to remove that symlink by hand before making your marked | |
4736 ;; symlinks. | |
4737 | |
4738 (defun dired-handle-overwrite (to) | |
4739 ;; Save old version of a to be overwritten file TO. | |
4740 ;; `dired-overwrite-confirmed' and `dired-overwrite-backup-query' | |
4741 ;; are fluid vars from dired-create-files. | |
4742 (if (and dired-backup-if-overwrite | |
4743 dired-overwrite-confirmed | |
4744 (or (eq 'always dired-backup-if-overwrite) | |
4745 (dired-query 'dired-overwrite-backup-query | |
4746 (format "Make backup for existing file `%s'? " to)))) | |
4747 (let ((backup (car (find-backup-file-name to)))) | |
4748 (rename-file to backup 0)))) ; confirm overwrite of old backup | |
4749 | |
4750 (defun dired-dwim-target-directory () | |
4751 ;; Try to guess which target directory the user may want. | |
4752 ;; If there is a dired buffer displayed in the next window, use | |
4753 ;; its current subdir, else use current subdir of this dired buffer. | |
4754 ;; non-dired buffer may want to profit from this function, e.g. vm-uudecode | |
4755 (let* ((this-dir (and (eq major-mode 'dired-mode) | |
4756 (dired-current-directory))) | |
4757 (dwimmed | |
4758 (if dired-dwim-target | |
4759 (let* ((other-buf (window-buffer (next-window))) | |
4760 (other-dir (save-excursion | |
4761 (set-buffer other-buf) | |
4762 (and (eq major-mode 'dired-mode) | |
4763 (dired-current-directory))))) | |
4764 (or other-dir this-dir)) | |
4765 this-dir))) | |
4766 (and dwimmed (dired-abbreviate-file-name dwimmed)))) | |
4767 | |
4768 (defun dired-get-target-directory () | |
4769 "Writes a copy of the current subdirectory into an active minibuffer." | |
4770 (interactive) | |
4771 (let ((mb (dired-get-active-minibuffer-window))) | |
4772 (if mb | |
4773 (let ((dir (dired-current-directory))) | |
4774 (select-window mb) | |
4775 (set-buffer (window-buffer mb)) | |
4776 (erase-buffer) | |
4777 (insert dir)) | |
4778 (error "No active minibuffer")))) | |
4779 | |
4780 ;;; Copying files | |
4781 | |
4782 (defun dired-do-copy (&optional arg) | |
4783 "Copy all marked (or next ARG) files, or copy the current file. | |
4784 When operating on just the current file, you specify the new name. | |
4785 When operating on multiple or marked files, you specify a directory | |
4786 and the files are copied into that directory, retaining the same file names. | |
4787 | |
4788 A zero prefix argument copies nothing. But it toggles the | |
4789 variable `dired-copy-preserve-time' (which see)." | |
4790 (interactive "P") | |
4791 (if (not (zerop (prefix-numeric-value arg))) | |
4792 (dired-do-create-files 'copy (function dired-copy-file) | |
4793 (if dired-copy-preserve-time "Copy [-p]" "Copy") | |
4794 arg dired-keep-marker-copy) | |
4795 (setq dired-copy-preserve-time (not dired-copy-preserve-time)) | |
4796 (if dired-copy-preserve-time | |
4797 (message "Copy will preserve time.") | |
4798 (message "Copied files will get current date.")))) | |
4799 | |
4800 (defun dired-copy-file (from to ok-flag) | |
4801 (dired-handle-overwrite to) | |
4802 (copy-file from to ok-flag dired-copy-preserve-time)) | |
4803 | |
4804 ;;; Renaming/moving files | |
4805 | |
4806 (defun dired-do-rename (&optional arg) | |
4807 "Rename current file or all marked (or next ARG) files. | |
4808 When renaming just the current file, you specify the new name. | |
4809 When renaming multiple or marked files, you specify a directory. | |
4810 | |
4811 A zero ARG moves no files but toggles `dired-dwim-target' (which see)." | |
4812 (interactive "P") | |
4813 (if (not (zerop (prefix-numeric-value arg))) | |
4814 (dired-do-create-files 'move (function dired-rename-file) | |
4815 "Move" arg dired-keep-marker-rename | |
4816 (function | |
4817 (lambda (list) | |
4818 (if (= (length list) 1) | |
4819 "Rename %s to: " | |
4820 "Move %s to: ")))) | |
4821 (setq dired-dwim-target (not dired-dwim-target)) | |
4822 (message "dired-dwim-target is %s." (if dired-dwim-target "ON" "OFF")))) | |
4823 | |
4824 (defun dired-rename-file (from to ok-flag) | |
4825 (dired-handle-overwrite to) | |
4826 (let ((insert (assoc (file-name-as-directory from) dired-subdir-alist))) | |
4827 (rename-file from to ok-flag) ; error is caught in -create-files | |
4828 ;; Silently rename the visited file of any buffer visiting this file. | |
4829 (dired-rename-update-buffers from to insert))) | |
4830 | |
4831 (defun dired-rename-update-buffers (from to &optional insert) | |
4832 (if (get-file-buffer from) | |
4833 (save-excursion | |
4834 (set-buffer (get-file-buffer from)) | |
4835 (let ((modflag (buffer-modified-p))) | |
4836 (set-visited-file-name to) ; kills write-file-hooks | |
4837 (set-buffer-modified-p modflag))) | |
4838 ;; It's a directory. More work to do. | |
4839 (let ((blist (buffer-list)) | |
4840 (from-dir (file-name-as-directory from)) | |
4841 (to-dir (file-name-as-directory to))) | |
4842 (save-excursion | |
4843 (while blist | |
4844 (set-buffer (car blist)) | |
4845 (setq blist (cdr blist)) | |
4846 (cond | |
4847 (buffer-file-name | |
4848 (if (dired-in-this-tree buffer-file-name from-dir) | |
4849 (let ((modflag (buffer-modified-p))) | |
4850 (unwind-protect | |
4851 (set-visited-file-name | |
4852 (concat to-dir (substring buffer-file-name | |
4853 (length from-dir)))) | |
4854 (set-buffer-modified-p modflag))))) | |
4855 (dired-directory | |
4856 (if (string-equal from-dir (expand-file-name default-directory)) | |
4857 ;; If top level directory was renamed, lots of things | |
4858 ;; have to be updated. | |
4859 (progn | |
4860 (dired-unadvertise from-dir) | |
4861 (setq default-directory to-dir | |
4862 dired-directory | |
4863 ;; Need to beware of wildcards. | |
4864 (expand-file-name | |
4865 (file-name-nondirectory dired-directory) | |
4866 to-dir)) | |
4867 (let ((new-name (file-name-nondirectory | |
4868 (directory-file-name dired-directory)))) | |
4869 ;; Try to rename buffer, but just leave old name if new | |
4870 ;; name would already exist (don't try appending "<%d>") | |
4871 ;; Why? --sandy 19-8-94 | |
4872 (or (get-buffer new-name) | |
4873 (rename-buffer new-name))) | |
4874 (dired-advertise)) | |
4875 (and insert | |
4876 (assoc (file-name-directory (directory-file-name to)) | |
4877 dired-subdir-alist) | |
4878 (dired-insert-subdir to)))))))))) | |
4879 | |
4880 ;;; Making symbolic links | |
4881 | |
4882 (defun dired-do-symlink (&optional arg) | |
4883 "Make symbolic links to current file or all marked (or next ARG) files. | |
4884 When operating on just the current file, you specify the new name. | |
4885 When operating on multiple or marked files, you specify a directory | |
4886 and new symbolic links are made in that directory | |
4887 with the same names that the files currently have." | |
4888 (interactive "P") | |
4889 (dired-do-create-files 'symlink (function make-symbolic-link) | |
4890 "SymLink" arg dired-keep-marker-symlink)) | |
4891 | |
4892 ;; Relative symlinks: | |
4893 ;; make-symbolic no longer expands targets (as of at least 18.57), | |
4894 ;; so the code to call ln has been removed. | |
4895 | |
4896 (defun dired-do-relsymlink (&optional arg) | |
4897 "Symlink all marked (or next ARG) files into a directory, | |
4898 or make a symbolic link to the current file. | |
4899 This creates relative symbolic links like | |
4900 | |
4901 foo -> ../bar/foo | |
4902 | |
4903 not absolute ones like | |
4904 | |
4905 foo -> /ugly/path/that/may/change/any/day/bar/foo" | |
4906 (interactive "P") | |
4907 (dired-do-create-files 'relsymlink (function dired-make-relative-symlink) | |
4908 "RelSymLink" arg dired-keep-marker-symlink)) | |
4909 | |
4910 (defun dired-make-relative-symlink (target linkname | |
4911 &optional ok-if-already-exists) | |
4912 "Make a relative symbolic link pointing to TARGET with name LINKNAME. | |
4913 Three arguments: FILE1 FILE2 &optional OK-IF-ALREADY-EXISTS | |
4914 The link is relative (if possible), for example | |
4915 | |
4916 \"/vol/tex/bin/foo\" \"/vol/local/bin/foo\" | |
4917 | |
4918 results in | |
4919 | |
4920 \"../../tex/bin/foo\" \"/vol/local/bin/foo\"" | |
4921 (interactive | |
4922 (let ((target (read-string "Make relative symbolic link to file: "))) | |
4923 (list | |
4924 target | |
4925 (read-file-name (format "Make relsymlink to file %s: " target)) | |
4926 0))) | |
4927 (let* ((target (expand-file-name target)) | |
4928 (linkname (expand-file-name linkname)) | |
4929 (handler (or (find-file-name-handler | |
4930 linkname 'dired-make-relative-symlink) | |
4931 (find-file-name-handler | |
4932 target 'dired-make-relative-symlink)))) | |
4933 (if handler | |
4934 (funcall handler 'dired-make-relative-symlink target linkname | |
4935 ok-if-already-exists) | |
4936 (setq target (directory-file-name target) | |
4937 linkname (directory-file-name linkname)) | |
4938 (make-symbolic-link | |
4939 (dired-make-relative target (file-name-directory linkname) t) | |
4940 linkname ok-if-already-exists)))) | |
4941 | |
4942 ;;; Hard links -- adding names to files | |
4943 | |
4944 (defun dired-do-hardlink (&optional arg) | |
4945 "Add names (hard links) current file or all marked (or next ARG) files. | |
4946 When operating on just the current file, you specify the new name. | |
4947 When operating on multiple or marked files, you specify a directory | |
4948 and new hard links are made in that directory | |
4949 with the same names that the files currently have." | |
4950 (interactive "P") | |
4951 (dired-do-create-files 'hardlink (function add-name-to-file) | |
4952 "HardLink" arg dired-keep-marker-hardlink)) | |
4953 | |
4954 | |
4955 ;;;; --------------------------------------------------------------- | |
4956 ;;;; Running process on marked files | |
4957 ;;;; --------------------------------------------------------------- | |
4958 ;;; | |
4959 ;;; Commands for shell processes are in dired-shell.el. | |
4960 | |
4961 ;;; Internal functions for running subprocesses, | |
4962 ;;; checking and logging of their errors. | |
4963 | |
4964 (defun dired-call-process (program discard &rest arguments) | |
4965 ;; Run PROGRAM with output to current buffer unless DISCARD is t. | |
4966 ;; Remaining arguments are strings passed as command arguments to PROGRAM. | |
4967 ;; Returns program's exit status, as an integer. | |
4968 ;; This is a separate function so that efs can redefine it. | |
4969 (let ((return | |
4970 (apply 'call-process program nil (not discard) nil arguments))) | |
4971 (if (and (not (equal shell-file-name program)) | |
4972 (integerp return)) | |
4973 return | |
4974 ;; Fudge return code by looking for errors in current buffer. | |
4975 (if (zerop (buffer-size)) 0 1)))) | |
4976 | |
4977 (defun dired-check-process (msg program &rest arguments) | |
4978 ;; Display MSG while running PROGRAM, and check for output. | |
4979 ;; Remaining arguments are strings passed as command arguments to PROGRAM. | |
4980 ;; On error, insert output in a log buffer and return the | |
4981 ;; offending ARGUMENTS or PROGRAM. | |
4982 ;; Caller can cons up a list of failed args. | |
4983 ;; Else returns nil for success. | |
4984 (let ((err-buffer (get-buffer-create " *dired-check-process output*")) | |
4985 (dir default-directory)) | |
4986 (message "%s..." msg) | |
4987 (save-excursion | |
4988 ;; Get a clean buffer for error output: | |
4989 (set-buffer err-buffer) | |
4990 (erase-buffer) | |
4991 (setq default-directory dir) ; caller's default-directory | |
4992 (if (not | |
4993 (eq 0 (apply (function dired-call-process) program nil arguments))) | |
4994 (progn | |
4995 (dired-log (buffer-name (current-buffer)) | |
4996 (concat program " " (prin1-to-string arguments) "\n")) | |
4997 (dired-log (buffer-name (current-buffer)) err-buffer) | |
4998 (or arguments program t)) | |
4999 (kill-buffer err-buffer) | |
5000 (message "%s...done" msg) | |
5001 nil)))) | |
5002 | |
5003 ;;; Changing file attributes | |
5004 | |
5005 (defun dired-do-chxxx (attribute-name program op-symbol arg) | |
5006 ;; Change file attributes (mode, group, owner) of marked files and | |
5007 ;; refresh their file lines. | |
5008 ;; ATTRIBUTE-NAME is a string describing the attribute to the user. | |
5009 ;; PROGRAM is the program used to change the attribute. | |
5010 ;; OP-SYMBOL is the type of operation (for use in dired-mark-pop-up). | |
5011 ;; ARG describes which files to use, like in dired-get-marked-files. | |
5012 (let* ((files (dired-get-marked-files t arg)) | |
5013 (new-attribute | |
5014 (dired-mark-read-string | |
5015 (concat "Change " attribute-name " of %s to: ") | |
5016 nil op-symbol arg files)) | |
5017 (operation (concat program " " new-attribute)) | |
5018 (failures | |
5019 (dired-bunch-files 10000 (function dired-check-process) | |
5020 (list operation program new-attribute) | |
5021 files))) | |
5022 (dired-do-redisplay arg);; moves point if ARG is an integer | |
5023 (if failures | |
5024 (dired-log-summary (buffer-name (current-buffer)) | |
5025 (format "%s: error" operation) nil)))) | |
5026 | |
5027 (defun dired-do-chmod (&optional arg) | |
5028 "Change the mode of the marked (or next ARG) files. | |
5029 This calls chmod, thus symbolic modes like `g+w' are allowed." | |
5030 (interactive "P") | |
5031 (dired-do-chxxx "Mode" "chmod" 'chmod arg)) | |
5032 | |
5033 (defun dired-do-chgrp (&optional arg) | |
5034 "Change the group of the marked (or next ARG) files." | |
5035 (interactive "P") | |
5036 (dired-do-chxxx "Group" "chgrp" 'chgrp arg)) | |
5037 | |
5038 (defun dired-do-chown (&optional arg) | |
5039 "Change the owner of the marked (or next ARG) files." | |
5040 (interactive "P") | |
5041 (dired-do-chxxx "Owner" dired-chown-program 'chown arg)) | |
5042 | |
5043 ;;; Utilities for running processes on marked files. | |
5044 | |
5045 ;; Process all the files in FILES in batches of a convenient size, | |
5046 ;; by means of (FUNCALL FUNCTION ARGS... SOME-FILES...). | |
5047 ;; Batches are chosen to need less than MAX chars for the file names, | |
5048 ;; allowing 3 extra characters of separator per file name. | |
5049 (defun dired-bunch-files (max function args files) | |
5050 (let (pending | |
5051 (pending-length 0) | |
5052 failures) | |
5053 ;; Accumulate files as long as they fit in MAX chars, | |
5054 ;; then process the ones accumulated so far. | |
5055 (while files | |
5056 (let* ((thisfile (car files)) | |
5057 (thislength (+ (length thisfile) 3)) | |
5058 (rest (cdr files))) | |
5059 ;; If we have at least 1 pending file | |
5060 ;; and this file won't fit in the length limit, process now. | |
5061 (if (and pending (> (+ thislength pending-length) max)) | |
5062 (setq failures | |
5063 (nconc (apply function (append args pending)) | |
5064 failures) | |
5065 pending nil | |
5066 pending-length 0)) | |
5067 ;; Do (setq pending (cons thisfile pending)) | |
5068 ;; but reuse the cons that was in `files'. | |
5069 (setcdr files pending) | |
5070 (setq pending files) | |
5071 (setq pending-length (+ thislength pending-length)) | |
5072 (setq files rest))) | |
5073 (nconc (apply function (append args pending)) | |
5074 failures))) | |
5075 | |
5076 | |
5077 ;;;; --------------------------------------------------------------- | |
5078 ;;;; Calculating data or properties for marked files. | |
5079 ;;;; --------------------------------------------------------------- | |
5080 | |
5081 (defun dired-do-total-size (&optional arg) | |
5082 "Show total size of all marked (or next ARG) files." | |
5083 (interactive "P") | |
5084 (let* ((result (dired-map-over-marks (dired-get-file-size) arg)) | |
5085 (total (apply (function +) result)) | |
5086 (num (length result))) | |
5087 (message "%d bytes (%d kB) in %s file%s" | |
5088 total (/ total 1024) num (dired-plural-s num)) | |
5089 total)) | |
5090 | |
5091 (defun dired-get-file-size () | |
5092 ;; Returns the file size in bytes of the current file, as an integer. | |
5093 ;; Assumes that it is on a valid file line. It's the caller's responsibility | |
5094 ;; to ensure this. Assumes that match 0 for dired-re-month-and-time is | |
5095 ;; at the end of the file size. | |
5096 (dired-move-to-filename t) | |
5097 ;; dired-move-to-filename must leave match-beginning 0 at the start of | |
5098 ;; the date. | |
5099 (goto-char (match-beginning 0)) | |
5100 (skip-chars-backward " ") | |
5101 (string-to-int (buffer-substring (point) | |
5102 (progn (skip-chars-backward "0-9") | |
5103 (point))))) | |
5104 | |
5105 (defun dired-copy-filenames-as-kill (&optional arg) | |
5106 "Copy names of marked (or next ARG) files into the kill ring. | |
5107 The names are separated by a space, and may be copied into other buffers | |
5108 with \\[yank]. The list of names is also stored in the variable | |
5109 `dired-marked-files' for possible manipulation in the *scratch* buffer. | |
5110 | |
5111 With a 0 prefix argument, use the pathname relative to the top-level dired | |
5112 directory for each marked file. | |
5113 | |
5114 With a prefix \\[universal-argument], use the complete pathname of each | |
5115 marked file. | |
5116 | |
5117 With a prefix \\[universal-argument] \\[universal-argument], copy the complete | |
5118 file line. In this case, the lines are separated by newlines. | |
5119 | |
5120 If on a subdirectory headerline and no prefix argument given, use the | |
5121 subdirectory name instead." | |
5122 (interactive "P") | |
5123 (let (res) | |
5124 (cond | |
5125 ((and (null arg) (setq res (dired-get-subdir))) | |
5126 (kill-new res) | |
5127 (message "Copied %s into kill ring." res)) | |
5128 ((equal arg '(16)) | |
5129 (setq dired-marked-files | |
5130 (dired-map-over-marks | |
5131 (concat " " ; Don't copy the mark. | |
5132 (buffer-substring | |
5133 (progn (beginning-of-line) (1+ (point))) | |
5134 (progn (skip-chars-forward "^\n\r") (point)))) | |
5135 nil)) | |
5136 (let ((len (length dired-marked-files))) | |
5137 (kill-new (concat | |
5138 (mapconcat 'identity dired-marked-files "\n") | |
5139 "\n")) | |
5140 (message "Copied %d file line%s into kill ring." | |
5141 len (dired-plural-s len)))) | |
5142 (t | |
5143 (setq dired-marked-files | |
5144 (cond | |
5145 ((null arg) | |
5146 (dired-get-marked-files 'no-dir)) | |
5147 ((eq arg 0) | |
5148 (dired-get-marked-files t)) | |
5149 ((integerp arg) | |
5150 (dired-get-marked-files 'no-dir arg)) | |
5151 ((equal arg '(4)) | |
5152 (dired-get-marked-files)) | |
5153 (t (error "Invalid prefix %s" arg)))) | |
5154 (let ((len (length dired-marked-files))) | |
5155 (kill-new (mapconcat 'identity dired-marked-files " ")) | |
5156 (message "Copied %d file name%s into kill ring." | |
5157 len (dired-plural-s len))))))) | |
5158 | |
5159 | |
5160 ;;;; ----------------------------------------------------------- | |
5161 ;;;; Killing subdirectories | |
5162 ;;;; ----------------------------------------------------------- | |
5163 ;;; | |
5164 ;;; These commands actually remove text from the dired buffer. | |
5165 | |
5166 (defun dired-kill-subdir (&optional remember-marks tree) | |
5167 "Remove all lines of current subdirectory. | |
5168 Lower levels are unaffected. If given a prefix when called interactively, | |
5169 kills the entire directory tree below the current subdirectory." | |
5170 ;; With optional REMEMBER-MARKS, return a mark-alist. | |
5171 (interactive (list nil current-prefix-arg)) | |
5172 (let ((cur-dir (dired-current-directory))) | |
5173 (if (string-equal cur-dir (expand-file-name default-directory)) | |
5174 (error "Attempt to kill top level directory")) | |
5175 (if tree | |
5176 (dired-kill-tree cur-dir remember-marks) | |
5177 (let ((beg (dired-subdir-min)) | |
5178 (end (dired-subdir-max)) | |
5179 buffer-read-only) | |
5180 (prog1 | |
5181 (if remember-marks (dired-remember-marks beg end)) | |
5182 (goto-char beg) | |
5183 (or (bobp) (forward-char -1)) ; gobble separator | |
5184 (delete-region (point) end) | |
5185 (dired-unsubdir cur-dir) | |
5186 (dired-update-mode-line) | |
5187 (dired-update-mode-line-modified t)))))) | |
5188 | |
5189 (defun dired-kill-tree (dirname &optional remember-marks) | |
5190 "Kill all proper subdirs of DIRNAME, excluding DIRNAME itself. | |
5191 With optional arg REMEMBER-MARKS, return an alist of marked files." | |
5192 (interactive "DKill tree below directory: ") | |
5193 (let ((s-alist dired-subdir-alist) dir m-alist) | |
5194 (while s-alist | |
5195 (setq dir (car (car s-alist)) | |
5196 s-alist (cdr s-alist)) | |
5197 (if (and (not (string-equal dir dirname)) | |
5198 (dired-in-this-tree dir dirname) | |
5199 (dired-goto-subdir dir)) | |
5200 (setq m-alist (nconc (dired-kill-subdir remember-marks) m-alist)))) | |
5201 (dired-update-mode-line) | |
5202 (dired-update-mode-line-modified t) | |
5203 m-alist)) | |
5204 | |
5205 | |
5206 ;;;; ------------------------------------------------------------ | |
5207 ;;;; Killing file lines | |
5208 ;;;; ------------------------------------------------------------ | |
5209 ;;; | |
5210 ;;; Uses selective diplay, rather than removing lines from the buffer. | |
5211 | |
5212 (defun dired-do-kill-file-lines (&optional arg) | |
5213 "Kill all marked file lines, or those indicated by the prefix argument. | |
5214 Killing file lines means hiding them with selective display. Giving | |
5215 a zero prefix redisplays all killed file lines." | |
5216 (interactive "P") | |
5217 (or selective-display | |
5218 (error "selective-display must be t for file line killing to work!")) | |
5219 (if (eq arg 0) | |
5220 (dired-do-unhide dired-kill-marker-char | |
5221 "Successfully resuscitated %d file line%s." | |
5222 dired-keep-marker-kill) | |
5223 (let ((files | |
5224 (length | |
5225 (dired-map-over-marks | |
5226 (progn | |
5227 (beginning-of-line) | |
5228 (subst-char-in-region (1- (point)) (point) ?\n ?\r) | |
5229 (dired-substitute-marker (point) (following-char) | |
5230 dired-kill-marker-char) | |
5231 (dired-update-marker-counters dired-marker-char t) | |
5232 t) | |
5233 arg)))) | |
5234 ;; Beware of extreme apparent save-excursion lossage here. | |
5235 (let ((opoint (point))) | |
5236 (skip-chars-backward "^\n\r") | |
5237 (if (= (preceding-char) ?\n) | |
5238 (goto-char opoint) | |
5239 (setq opoint (- opoint (point))) | |
5240 (beginning-of-line) | |
5241 (skip-chars-forward "^\n\r" (+ (point) opoint)))) | |
5242 (dired-update-mode-line-modified) | |
5243 (message "Killed %d file line%s." files (dired-plural-s files))))) | |
5244 | |
5245 | |
5246 ;;;; ---------------------------------------------------------------- | |
5247 ;;;; Omitting files. | |
5248 ;;;; ---------------------------------------------------------------- | |
5249 | |
5250 ;; Marked files are never omitted. | |
5251 ;; Adapted from code submitted by: | |
5252 ;; Michael D. Ernst, mernst@theory.lcs.mit.edu, 1/11/91 | |
5253 ;; Changed to work with selective display by Sandy Rutherford, 13/12/92. | |
5254 ;; For historical reasons, we still use the term expunge, although nothing | |
5255 ;; is expunged from the buffer. | |
5256 | |
5257 (defun dired-omit-toggle (&optional arg) | |
5258 "Toggle between displaying and omitting files matching | |
5259 `dired-omit-files-regexp' in the current subdirectory. | |
5260 With a positive prefix, omits files in the entire tree dired buffer. | |
5261 With a negative prefix, forces all files in the tree dired buffer to be | |
5262 displayed." | |
5263 (interactive "P") | |
5264 (if arg | |
5265 (let ((arg (prefix-numeric-value arg))) | |
5266 (if (>= arg 0) | |
5267 (dired-omit-expunge nil t) | |
5268 (dired-do-unhide dired-omit-marker-char "") | |
5269 (mapcar | |
5270 (function | |
5271 (lambda (elt) | |
5272 (setcar (nthcdr 2 elt) nil))) | |
5273 dired-subdir-alist))) | |
5274 (if (dired-current-subdir-omitted-p) | |
5275 (save-restriction | |
5276 (narrow-to-region (dired-subdir-min) (dired-subdir-max)) | |
5277 (dired-do-unhide dired-omit-marker-char "") | |
5278 (setcar (nthcdr 2 (assoc | |
5279 (dired-current-directory) dired-subdir-alist)) | |
5280 nil) | |
5281 (setq dired-subdir-omit nil)) | |
5282 (dired-omit-expunge) | |
5283 (setq dired-subdir-omit t))) | |
5284 (dired-update-mode-line t)) | |
5285 | |
5286 (defun dired-current-subdir-omitted-p () | |
5287 ;; Returns t if the current subdirectory is omited. | |
5288 (nth 2 (assoc (dired-current-directory) dired-subdir-alist))) | |
5289 | |
5290 (defun dired-remember-omitted () | |
5291 ;; Returns a list of omitted subdirs. | |
5292 (let ((alist dired-subdir-alist) | |
5293 result elt) | |
5294 (while alist | |
5295 (setq elt (car alist) | |
5296 alist (cdr alist)) | |
5297 (if (nth 2 elt) | |
5298 (setq result (cons (car elt) result)))) | |
5299 result)) | |
5300 | |
5301 (defun dired-omit-expunge (&optional regexp full-buffer) | |
5302 ;; Hides all unmarked files matching REGEXP. | |
5303 ;; If REGEXP is nil or not specified, uses `dired-omit-files-regexp', | |
5304 ;; and also omits filenames ending in `dired-omit-extensions'. | |
5305 ;; If REGEXP is the empty string, this function is a no-op. | |
5306 (let ((omit-re (or regexp (dired-omit-regexp))) | |
5307 (alist dired-subdir-alist) | |
5308 elt min) | |
5309 (if (null omit-re) | |
5310 0 | |
5311 (if full-buffer | |
5312 (prog1 | |
5313 (dired-omit-region (point-min) (point-max) omit-re) | |
5314 ;; Set omit property in dired-subdir-alist | |
5315 (while alist | |
5316 (setq elt (car alist) | |
5317 min (dired-get-subdir-min elt) | |
5318 alist (cdr alist)) | |
5319 (if (and (<= (point-min) min) (>= (point-max) min)) | |
5320 (setcar (nthcdr 2 elt) t)))) | |
5321 (prog1 | |
5322 (dired-omit-region (dired-subdir-min) (dired-subdir-max) omit-re) | |
5323 (setcar | |
5324 (nthcdr 2 (assoc (dired-current-directory) | |
5325 dired-subdir-alist)) | |
5326 t)))))) | |
5327 | |
5328 (defun dired-omit-region (start end regexp) | |
5329 ;; Omits files matching regexp in region. Returns count. | |
5330 (save-restriction | |
5331 (narrow-to-region start end) | |
5332 (let ((hidden-subdirs (dired-remember-hidden)) | |
5333 buffer-read-only count) | |
5334 (or selective-display | |
5335 (error "selective-display must be t for file omission to work!")) | |
5336 (dired-omit-unhide-region start end) | |
5337 (let ((dired-marker-char dired-omit-marker-char) | |
5338 ;; since all subdirs are now unhidden, this fakes | |
5339 ;; dired-move-to-end-of-filename into working faster | |
5340 (selective-display nil)) | |
5341 (or dired-omit-silent | |
5342 dired-in-query (message "Omitting...")) | |
5343 (if (dired-mark-unmarked-files regexp nil nil 'no-dir) | |
5344 (setq count (dired-do-hide | |
5345 dired-marker-char | |
5346 (and (memq dired-omit-silent '(nil 0)) | |
5347 (not dired-in-query) | |
5348 "Omitted %d line%s."))) | |
5349 (or dired-omit-silent dired-in-query | |
5350 (message "(Nothing to omit)")))) | |
5351 (save-excursion ;hide subdirs that were hidden | |
5352 (mapcar (function (lambda (dir) | |
5353 (if (dired-goto-subdir dir) | |
5354 (dired-hide-subdir 1)))) | |
5355 hidden-subdirs)) | |
5356 count))) | |
5357 | |
5358 (defun dired-omit-unhide-region (beg end) | |
5359 ;; Unhides hidden, but not marked files in the region. | |
5360 (save-excursion | |
5361 (save-restriction | |
5362 (narrow-to-region beg end) | |
5363 (goto-char (point-min)) | |
5364 (while (search-forward "\r" nil t) | |
5365 (and (char-equal (following-char) ?\ ) | |
5366 (subst-char-in-region (1- (point)) (point) ?\r ?\n)))))) | |
5367 | |
5368 (defun dired-do-unhide (char &optional fmt marker) | |
5369 ;; Unhides files marked with CHAR. Optional FMT is a message | |
5370 ;; to be displayed. Note that after unhiding, we will need to re-hide | |
5371 ;; files belonging to hidden subdirs. | |
5372 (save-excursion | |
5373 (goto-char (point-min)) | |
5374 (let ((count 0) | |
5375 (string (concat "\r" (char-to-string char))) | |
5376 (hidden-subdirs (dired-remember-hidden)) | |
5377 (new (if marker (concat "\n" (char-to-string marker)) "\n ")) | |
5378 buffer-read-only) | |
5379 (while (search-forward string nil t) | |
5380 (replace-match new) | |
5381 (setq count (1+ count))) | |
5382 (or (equal "" fmt) | |
5383 (message (or fmt "Unhid %d line%s.") count (dired-plural-s count))) | |
5384 (goto-char (point-min)) | |
5385 (mapcar (function (lambda (dir) | |
5386 (if (dired-goto-subdir dir) | |
5387 (dired-hide-subdir 1 t)))) | |
5388 hidden-subdirs) | |
5389 (if marker (dired-update-mode-line-modified t)) | |
5390 count))) | |
5391 | |
5392 (defun dired-do-hide (char &optional fmt) | |
5393 ;; Hides files marked with CHAR. Otional FMT is a message | |
5394 ;; to be displayed. FMT is a format string taking args the number | |
5395 ;; of hidden file lines, and dired-plural-s. | |
5396 (save-excursion | |
5397 (goto-char (point-min)) | |
5398 (let ((count 0) | |
5399 (string (concat "\n" (char-to-string char))) | |
5400 buffer-read-only) | |
5401 (while (search-forward string nil t) | |
5402 (subst-char-in-region (match-beginning 0) | |
5403 (1+ (match-beginning 0)) ?\n ?\r t) | |
5404 (setq count (1+ count))) | |
5405 (if fmt | |
5406 (message fmt count (dired-plural-s count))) | |
5407 count))) | |
5408 | |
5409 (defun dired-omit-regexp () | |
5410 (let (rgxp) | |
5411 (if dired-omit-extensions | |
5412 (setq rgxp (concat | |
5413 ".\\(" | |
5414 (mapconcat 'regexp-quote dired-omit-extensions "\\|") | |
5415 "\\)$"))) | |
5416 (if dired-omit-regexps | |
5417 (setq rgxp | |
5418 (concat | |
5419 rgxp | |
5420 (and rgxp "\\|") | |
5421 (mapconcat 'identity dired-omit-regexps "\\|")))) | |
5422 rgxp)) | |
5423 | |
5424 (defun dired-mark-unmarked-files (regexp msg &optional unflag-p localp) | |
5425 ;; Marks unmarked files matching REGEXP, displaying MSG. | |
5426 ;; REGEXP is matched against the complete pathname, unless localp is | |
5427 ;; specified. | |
5428 ;; Does not re-mark files which already have a mark. | |
5429 ;; Returns t if any work was done, nil otherwise. | |
5430 (let ((dired-marker-char (if unflag-p ?\ dired-marker-char)) | |
5431 fn) | |
5432 (dired-mark-if | |
5433 (and | |
5434 ;; not already marked | |
5435 (eq (following-char) ?\ ) | |
5436 ;; uninteresting | |
5437 (setq fn (dired-get-filename localp t)) | |
5438 (string-match regexp fn)) | |
5439 msg))) | |
5440 | |
5441 (defun dired-add-omit-regexp (rgxp &optional how) | |
5442 "Adds a new regular expression to the list of omit regular expresions. | |
5443 With a non-zero numeric prefix argument, deletes a regular expresion from | |
5444 the list. | |
5445 | |
5446 With a prefix argument \\[universal-argument], adds a new extension to | |
5447 the list of file name extensions omitted. | |
5448 With a prefix argument \\[universal-argument] \\[universal-argument], deletes | |
5449 a file name extension from the list. | |
5450 | |
5451 With a prefix 0, reports on the current omit regular expressions and | |
5452 extensions." | |
5453 (interactive | |
5454 (list | |
5455 (cond | |
5456 ((null current-prefix-arg) | |
5457 (read-string "New omit regular expression: ")) | |
5458 ((equal '(4) current-prefix-arg) | |
5459 (read-string "New omit extension (\".\" is not implicit): ")) | |
5460 ((equal '(16) current-prefix-arg) | |
5461 (completing-read | |
5462 "Remove from omit extensions (type SPACE for options): " | |
5463 (mapcar 'list dired-omit-extensions) nil t)) | |
5464 ((eq 0 current-prefix-arg) | |
5465 nil) | |
5466 (t | |
5467 (completing-read | |
5468 "Remove from omit regexps (type SPACE for options): " | |
5469 (mapcar 'list dired-omit-regexps) nil t))) | |
5470 current-prefix-arg)) | |
5471 (let (remove) | |
5472 (cond | |
5473 ((null how) | |
5474 (if (member rgxp dired-omit-regexps) | |
5475 (progn | |
5476 (describe-variable 'dired-omit-regexps) | |
5477 (error "%s is already included in the list." rgxp)) | |
5478 (setq dired-omit-regexps (cons rgxp dired-omit-regexps)))) | |
5479 ((equal how '(4)) | |
5480 (if (member rgxp dired-omit-extensions) | |
5481 (progn | |
5482 (describe-variable 'dired-omit-extensions) | |
5483 (error "%s is already included in list." rgxp)) | |
5484 (setq dired-omit-extensions (cons rgxp dired-omit-extensions)))) | |
5485 ((equal how '(16)) | |
5486 (let ((tail (member rgxp dired-omit-extensions))) | |
5487 (if tail | |
5488 (setq dired-omit-extensions | |
5489 (delq (car tail) dired-omit-extensions) | |
5490 remove t) | |
5491 (setq remove 'ignore)))) | |
5492 ((eq 0 how) | |
5493 (setq remove 'ignore) | |
5494 (if (featurep 'ehelp) | |
5495 (with-electric-help | |
5496 (function | |
5497 (lambda () | |
5498 (princ "Omit extensions (dired-omit-extensions <V>):\n") | |
5499 (dired-format-columns-of-files dired-omit-extensions) | |
5500 (princ "\n") | |
5501 (princ "Omit regular expressions (dired-omit-regexps <V>):\n") | |
5502 (dired-format-columns-of-files dired-omit-regexps) | |
5503 nil))) | |
5504 (with-output-to-temp-buffer "*Help*" | |
5505 (princ "Omit extensions (dired-omit-extensions <V>):\n") | |
5506 (dired-format-columns-of-files dired-omit-extensions) | |
5507 (princ "\n") | |
5508 (princ "Omit regular expressions (dired-omit-regexps <V>):\n") | |
5509 (dired-format-columns-of-files dired-omit-regexps) | |
5510 (print-help-return-message)))) | |
5511 (t | |
5512 (let ((tail (member rgxp dired-omit-regexps))) | |
5513 (if tail | |
5514 (setq dired-omit-regexps (delq (car tail) dired-omit-regexps) | |
5515 remove t) | |
5516 (setq remove 'ignore))))) | |
5517 (or (eq remove 'ignore) | |
5518 (save-excursion | |
5519 (mapcar | |
5520 (function | |
5521 (lambda (dir) | |
5522 (if (dired-goto-subdir dir) | |
5523 (progn | |
5524 (if remove | |
5525 (save-restriction | |
5526 (narrow-to-region | |
5527 (dired-subdir-min) (dired-subdir-max)) | |
5528 (dired-do-unhide dired-omit-marker-char ""))) | |
5529 (dired-omit-expunge))))) | |
5530 (dired-remember-omitted)))))) | |
5531 | |
5532 | |
5533 | |
5534 ;;;; ---------------------------------------------------------------- | |
5535 ;;;; Directory hiding. | |
5536 ;;;; ---------------------------------------------------------------- | |
5537 ;;; | |
5538 ;;; To indicate a hidden subdir, we actually insert "..." in the buffer. | |
5539 ;;; Aside from giving the look of ellipses (even though | |
5540 ;;; selective-display-ellipses is nil), it allows us to tell the difference | |
5541 ;;; between a dir with a single omitted file, and a hidden subdir with one | |
5542 ;;; file. | |
5543 | |
5544 (defun dired-subdir-hidden-p (dir) | |
5545 (save-excursion | |
5546 (and selective-display | |
5547 (dired-goto-subdir dir) | |
5548 (looking-at "\\.\\.\\.\r")))) | |
5549 | |
5550 (defun dired-unhide-subdir () | |
5551 (let (buffer-read-only) | |
5552 (goto-char (dired-subdir-min)) | |
5553 (skip-chars-forward "^\n\r") | |
5554 (skip-chars-backward "." (- (point) 3)) | |
5555 (if (looking-at "\\.\\.\\.\r") (delete-char 4)) | |
5556 (dired-omit-unhide-region (point) (dired-subdir-max)))) | |
5557 | |
5558 (defun dired-hide-check () | |
5559 (or selective-display | |
5560 (error "selective-display must be t for subdir hiding to work!"))) | |
5561 | |
5562 (defun dired-hide-subdir (arg &optional really) | |
5563 "Hide or unhide the current subdirectory and move to next directory. | |
5564 Optional prefix arg is a repeat factor. | |
5565 Use \\[dired-hide-all] to (un)hide all directories. | |
5566 With the optional argument REALLY, we always hide | |
5567 the subdir, regardless of dired-subdir-hidden-p." | |
5568 ;; The arg REALLY is needed because when we unhide | |
5569 ;; omitted files in a hidden subdir, we want to | |
5570 ;; re-hide the subdir, regardless of whether dired | |
5571 ;; thinks it's already hidden. | |
5572 (interactive "p") | |
5573 (dired-hide-check) | |
5574 (dired-save-excursion | |
5575 (while (>= (setq arg (1- arg)) 0) | |
5576 (let* ((cur-dir (dired-current-directory)) | |
5577 (hidden-p (and (null really) | |
5578 (dired-subdir-hidden-p cur-dir))) | |
5579 (elt (assoc cur-dir dired-subdir-alist)) | |
5580 (end-pos (1- (dired-get-subdir-max elt))) | |
5581 buffer-read-only) | |
5582 ;; keep header line visible, hide rest | |
5583 (goto-char (dired-get-subdir-min elt)) | |
5584 (skip-chars-forward "^\n\r") | |
5585 (skip-chars-backward "." (- (point) 3)) | |
5586 (if hidden-p | |
5587 (progn | |
5588 (if (looking-at "\\.\\.\\.\r") | |
5589 (progn | |
5590 (delete-char 3) | |
5591 (setq end-pos (- end-pos 3)))) | |
5592 (dired-omit-unhide-region (point) end-pos)) | |
5593 (if (looking-at "\\.\\.\\.\r") | |
5594 (goto-char (match-end 0)) | |
5595 (insert "...") | |
5596 (setq end-pos (+ end-pos 3))) | |
5597 (subst-char-in-region (point) end-pos ?\n ?\r))) | |
5598 (dired-next-subdir 1 t)))) | |
5599 | |
5600 (defun dired-hide-all (arg) | |
5601 "Hide all subdirectories, leaving only their header lines. | |
5602 If there is already something hidden, make everything visible again. | |
5603 Use \\[dired-hide-subdir] to (un)hide a particular subdirectory." | |
5604 (interactive "P") | |
5605 (dired-hide-check) | |
5606 (let (buffer-read-only) | |
5607 (dired-save-excursion | |
5608 (if (let ((alist dired-subdir-alist) | |
5609 (hidden nil)) | |
5610 (while (and alist (null hidden)) | |
5611 (setq hidden (dired-subdir-hidden-p (car (car alist))) | |
5612 alist (cdr alist))) | |
5613 hidden) | |
5614 ;; unhide | |
5615 (let ((alist dired-subdir-alist)) | |
5616 (while alist | |
5617 (goto-char (dired-get-subdir-min (car alist))) | |
5618 (skip-chars-forward "^\n\r") | |
5619 (delete-region (point) (progn (skip-chars-backward ".") (point))) | |
5620 (setq alist (cdr alist))) | |
5621 (dired-omit-unhide-region (point-min) (point-max))) | |
5622 ;; hide | |
5623 (let ((alist dired-subdir-alist)) | |
5624 (while alist | |
5625 (dired-goto-subdir (car (car alist))) | |
5626 (dired-hide-subdir 1 t) | |
5627 (setq alist (cdr alist)))))))) | |
5628 | |
5629 | |
5630 ;;;; ----------------------------------------------------------------- | |
5631 ;;;; Automatic dired buffer maintenance. | |
5632 ;;;; ----------------------------------------------------------------- | |
5633 ;;; | |
5634 ;;; Keeping Dired buffers in sync with the filesystem and with each | |
5635 ;;; other. | |
5636 ;;; When used with efs on remote directories, buffer maintainence is | |
5637 ;;; done asynch. | |
5638 | |
5639 (defun dired-buffers-for-dir (dir-or-list &optional check-wildcard) | |
5640 ;; Return a list of buffers that dired DIR-OR-LIST | |
5641 ;; (top level or in-situ subdir). | |
5642 ;; The list is in reverse order of buffer creation, most recent last. | |
5643 ;; As a side effect, killed dired buffers for DIR are removed from | |
5644 ;; dired-buffers. If DIR-OR-LIST is a wildcard or list, returns any | |
5645 ;; dired buffers for which DIR-OR-LIST is equal to `dired-directory'. | |
5646 ;; If check-wildcard is non-nil, only returns buffers which contain dir-or-list | |
5647 ;; exactly, including the wildcard part. | |
5648 (let ((alist dired-buffers) | |
5649 (as-dir (and (stringp dir-or-list) | |
5650 (file-name-as-directory dir-or-list))) | |
5651 result buff elt) | |
5652 (while alist | |
5653 (setq buff (cdr (setq elt (car alist))) | |
5654 alist (cdr alist)) | |
5655 ;; dired-in-this-tree is not fast. It doesn't pay to use this to check | |
5656 ;; whether the buffer is a good candidate. | |
5657 (if (buffer-name buff) | |
5658 (save-excursion | |
5659 (set-buffer buff) | |
5660 (if (or (equal dir-or-list dired-directory) ; the wildcard case. | |
5661 (and as-dir | |
5662 (not (and check-wildcard | |
5663 (string-equal | |
5664 as-dir | |
5665 (expand-file-name default-directory)))) | |
5666 (assoc as-dir dired-subdir-alist))) | |
5667 (setq result (cons buff result)))) | |
5668 ;; else buffer is killed - clean up: | |
5669 (setq dired-buffers (delq elt dired-buffers)))) | |
5670 (or dired-buffers (dired-remove-from-file-name-handler-alist)) | |
5671 result)) | |
5672 | |
5673 (defun dired-advertise () | |
5674 ;; Advertise in variable `dired-buffers' that we dired `default-directory'. | |
5675 ;; With wildcards we actually advertise too much. | |
5676 ;; Also makes sure that we are installed in the file-name-handler-alist | |
5677 (prog1 | |
5678 (let ((ddir (expand-file-name default-directory))) | |
5679 (if (memq (current-buffer) (dired-buffers-for-dir ddir)) | |
5680 t ; we have already advertised ourselves | |
5681 (setq dired-buffers | |
5682 (cons (cons ddir (current-buffer)) | |
5683 dired-buffers)))) | |
5684 ;; Do this last, otherwise the call to dired-buffers-for-dir will | |
5685 ;; remove dired-handler-fn from the file-name-handler-alist. | |
5686 ;; Strictly speaking, we only need to do this in th else branch of | |
5687 ;; the if statement. We do it unconditionally as a sanity check. | |
5688 (dired-check-file-name-handler-alist))) | |
5689 | |
5690 (defun dired-unadvertise (dir) | |
5691 ;; Remove DIR from the buffer alist in variable dired-buffers. | |
5692 ;; This has the effect of removing any buffer whose main directory is DIR. | |
5693 ;; It does not affect buffers in which DIR is a subdir. | |
5694 ;; Removing is also done as a side-effect in dired-buffer-for-dir. | |
5695 (setq dired-buffers | |
5696 (delq (assoc dir dired-buffers) dired-buffers)) | |
5697 ;; If there are no more dired buffers, we are no longer needed in the | |
5698 ;; file-name-handler-alist. | |
5699 (or dired-buffers (dired-remove-from-file-name-handler-alist))) | |
5700 | |
5701 (defun dired-unadvertise-current-buffer () | |
5702 ;; Remove all references to the current buffer in dired-buffers. | |
5703 (setq dired-buffers | |
5704 (delq nil | |
5705 (mapcar | |
5706 (function | |
5707 (lambda (x) | |
5708 (and (not (eq (current-buffer) (cdr x))) x))) | |
5709 dired-buffers)))) | |
5710 | |
5711 (defun dired-fun-in-all-buffers (directory fun &rest args) | |
5712 ;; In all buffers dired'ing DIRECTORY, run FUN with ARGS. | |
5713 ;; Return list of buffers where FUN succeeded (i.e., returned non-nil). | |
5714 (let* ((buf-list (dired-buffers-for-dir directory)) | |
5715 (obuf (current-buffer)) | |
5716 (owin (selected-window)) | |
5717 (win owin) | |
5718 buf windows success-list) | |
5719 (if buf-list | |
5720 (unwind-protect | |
5721 (progn | |
5722 (while (not (eq (setq win (next-window win)) owin)) | |
5723 (and (memq (setq buf (window-buffer win)) buf-list) | |
5724 (progn | |
5725 (set-buffer buf) | |
5726 (= (point) (window-point win))) | |
5727 (setq windows (cons win windows)))) | |
5728 (while buf-list | |
5729 (setq buf (car buf-list) | |
5730 buf-list (cdr buf-list)) | |
5731 (set-buffer buf) | |
5732 (if (apply fun args) | |
5733 (setq success-list (cons (buffer-name buf) success-list)))) | |
5734 ;; dired-save-excursion prevents lossage of save-excursion | |
5735 ;; for point. However, if dired buffers are displayed in | |
5736 ;; other windows, the setting of window-point loses, and | |
5737 ;; drags the point with it. This should fix this. | |
5738 (while windows | |
5739 (condition-case nil | |
5740 (progn | |
5741 (set-buffer (window-buffer (setq win (car windows)))) | |
5742 (set-window-point win (point))) | |
5743 (error nil)) | |
5744 (setq windows (cdr windows)))) | |
5745 (set-buffer obuf))) | |
5746 success-list)) | |
5747 | |
5748 (defun dired-find-file-place (subdir file) | |
5749 ;; Finds a position to insert in SUBDIR FILE. If it can't find SUBDIR, | |
5750 ;; returns nil. | |
5751 (let ((sort (dired-sort-type dired-internal-switches)) | |
5752 (rev (memq ?r (nth 3 (assoc subdir dired-subdir-alist))))) | |
5753 (cond | |
5754 ((eq sort 'name) | |
5755 (if (dired-goto-subdir subdir) | |
5756 (let ((max (dired-subdir-max)) | |
5757 start end found) | |
5758 (if (dired-goto-next-file) | |
5759 (progn | |
5760 (skip-chars-forward "^\n\r") | |
5761 (setq start (point)) | |
5762 (goto-char (setq end max)) | |
5763 (forward-char -1) | |
5764 (skip-chars-backward "^\n\r") | |
5765 ;; This loop must find a file. At the very least, it will | |
5766 ;; find the one found previously. | |
5767 (while (not found) | |
5768 (if (save-excursion (dired-move-to-filename nil (point))) | |
5769 (setq found t) | |
5770 (setq end (point)) | |
5771 (forward-char -1) | |
5772 (skip-chars-backward "^\n\r"))) | |
5773 (if rev | |
5774 (while (< start end) | |
5775 (goto-char (/ (+ start end) 2)) | |
5776 (if (dired-file-name-lessp | |
5777 (or (dired-get-filename 'no-dir t) | |
5778 (error | |
5779 "Error in dired-find-file-place")) | |
5780 file) | |
5781 (setq end (progn | |
5782 (skip-chars-backward "^\n\r") | |
5783 (point))) | |
5784 (setq start (progn | |
5785 (skip-chars-forward "^\n\r") | |
5786 (forward-char 1) | |
5787 (skip-chars-forward "^\n\r") | |
5788 (point))))) | |
5789 (while (< start end) | |
5790 (goto-char (/ (+ start end) 2)) | |
5791 (if (dired-file-name-lessp | |
5792 file | |
5793 (or (dired-get-filename 'no-dir t) | |
5794 (error | |
5795 "Error in dired-find-file-place"))) | |
5796 (setq end (progn | |
5797 (skip-chars-backward "^\n\r") | |
5798 (point))) | |
5799 (setq start (progn | |
5800 (skip-chars-forward "^\n\r") | |
5801 (forward-char 1) | |
5802 (skip-chars-forward "^\n\r") | |
5803 (point)))))) | |
5804 (goto-char end)) | |
5805 (goto-char max)) | |
5806 t))) | |
5807 ((eq sort 'date) | |
5808 (if (dired-goto-subdir subdir) | |
5809 (if rev | |
5810 (goto-char (dired-subdir-max)) | |
5811 (dired-goto-next-file) | |
5812 t))) | |
5813 ;; Put in support for other sorting types. | |
5814 (t | |
5815 (if (string-equal (dired-current-directory) subdir) | |
5816 (progn | |
5817 ;; We are already where we should be, except when | |
5818 ;; point is before the subdir line or its total line. | |
5819 (or (save-excursion (beginning-of-line) (dired-move-to-filename)) | |
5820 (dired-goto-next-nontrivial-file)) ; in the header somewhere | |
5821 t) ; return t, for found. | |
5822 (if (dired-goto-subdir subdir) | |
5823 (progn | |
5824 (dired-goto-next-nontrivial-file) | |
5825 t))))))) | |
5826 | |
5827 (defun dired-add-entry (filename &optional marker-char inplace) | |
5828 ;; Add a new entry for FILENAME, optionally marking it | |
5829 ;; with MARKER-CHAR (a character, else dired-marker-char is used). | |
5830 ;; Hidden subdirs are exposed if a file is added there. | |
5831 ;; | |
5832 ;; This function now adds the new entry at the END of the previous line, | |
5833 ;; not the beginning of the current line. | |
5834 ;; Logically, we now think of the `newline' associated | |
5835 ;; with a fileline, as the one at the beginning of the line, not the end. | |
5836 ;; This makes it easier to keep track of omitted files. | |
5837 ;; | |
5838 ;; Uses dired-save-excursion, so that it doesn't move the | |
5839 ;; point around. Especially important when it runs asynch. | |
5840 ;; | |
5841 ;; If there is already an entry, delete the existing one before adding a | |
5842 ;; new one. In this case, doesn't remember its mark. Use | |
5843 ;; dired-update-file-line for that. | |
5844 ;; | |
5845 ;; If INPLACE eq 'relist, then the new entry is put in the | |
5846 ;; same place as the old, if there was an old entry. | |
5847 ;; If INPLACE is t, then the file entry is put on the line | |
5848 ;; currently containing the point. Otherwise, dired-find-file-place | |
5849 ;; attempts to determine where to put the file. | |
5850 | |
5851 (setq filename (directory-file-name filename)) | |
5852 (dired-save-excursion | |
5853 (let ((oentry (save-excursion (dired-goto-file filename))) | |
5854 (directory (file-name-directory filename)) | |
5855 (file-nodir (file-name-nondirectory filename)) | |
5856 buffer-read-only) | |
5857 (if oentry | |
5858 ;; Remove old entry | |
5859 (let ((opoint (point))) | |
5860 (goto-char oentry) | |
5861 (delete-region (save-excursion | |
5862 (skip-chars-backward "^\r\n") | |
5863 (dired-update-marker-counters (following-char) t) | |
5864 (1- (point))) | |
5865 (progn | |
5866 (skip-chars-forward "^\r\n") | |
5867 (point))) | |
5868 ;; Move to right place to replace deleted line. | |
5869 (cond ((eq inplace 'relist) (forward-char 1)) | |
5870 ((eq inplace t) (goto-char opoint))) | |
5871 (dired-update-mode-line-modified))) | |
5872 (if (or (eq inplace t) | |
5873 (and oentry (eq inplace 'relist)) | |
5874 ;; Tries to move the point to the right place. | |
5875 ;; Returns t on success. | |
5876 (dired-find-file-place directory file-nodir)) | |
5877 (let ((switches (dired-make-switches-string | |
5878 (cons ?d dired-internal-switches))) | |
5879 b-of-l) | |
5880 ;; Bind marker-char now, in case we are working asynch and | |
5881 ;; dired-marker-char changes in the meantime. | |
5882 (if (and marker-char (not (integerp marker-char))) | |
5883 (setq marker-char dired-marker-char)) | |
5884 ;; since we insert at the end of a line, | |
5885 ;; backup to the end of the previous line. | |
5886 (skip-chars-backward "^\n\r") | |
5887 (forward-char -1) | |
5888 (setq b-of-l (point)) | |
5889 (if (and (featurep 'efs-dired) efs-dired-host-type) | |
5890 ;; insert asynch | |
5891 ;; we call the efs version explicitly here, | |
5892 ;; rather than let the handler-alist work for us | |
5893 ;; because we want to pass extra args. | |
5894 ;; Is there a cleaner way to do this? | |
5895 (efs-insert-directory filename ; don't expand `.' ! | |
5896 switches nil nil | |
5897 t ; nowait | |
5898 marker-char) | |
5899 (let ((insert-directory-program dired-ls-program)) | |
5900 (insert-directory filename switches nil nil)) | |
5901 (dired-after-add-entry b-of-l marker-char)) | |
5902 (if dired-verify-modtimes | |
5903 (dired-set-file-modtime directory dired-subdir-alist)) | |
5904 t))))) ; return t on success, else nil. | |
5905 | |
5906 (defun dired-after-add-entry (start marker-char) | |
5907 ;; Does the cleanup of a dired entry after listing it. | |
5908 ;; START is the start of the new listing-line. | |
5909 ;; This is a separate function for the sake of efs. | |
5910 (save-excursion | |
5911 (goto-char start) | |
5912 ;; we make sure that the new line is bracketted by new-lines | |
5913 ;; so the user doesn't need to use voodoo in the | |
5914 ;; after-readin-hook. | |
5915 (insert ?\n) | |
5916 (dired-add-entry-do-indentation marker-char) | |
5917 (let* ((beg (dired-manual-move-to-filename t)) | |
5918 ;; error for strange output | |
5919 (end (dired-manual-move-to-end-of-filename)) | |
5920 (filename (buffer-substring beg end))) | |
5921 ;; We want to have the non-directory part only. | |
5922 (delete-region beg end) | |
5923 ;; Any markers pointing to the beginning of the filename, will | |
5924 ;; still point there after this insertion. Should keep | |
5925 ;; save-excursion from losing. | |
5926 (setq beg (point)) | |
5927 (insert (file-name-nondirectory filename)) | |
5928 (dired-insert-set-properties beg (point)) | |
5929 (dired-move-to-filename)) | |
5930 ;; The subdir-alist is not affected so we can run it right now. | |
5931 (let ((omit (dired-current-subdir-omitted-p)) | |
5932 (hide (dired-subdir-hidden-p (dired-current-directory)))) | |
5933 (if (or dired-after-readin-hook omit hide) | |
5934 (save-excursion | |
5935 (save-restriction | |
5936 ;; Use start so that we get the new-line at | |
5937 ;; the beginning of the line in case we want | |
5938 ;; to hide the file. Don't need to test (bobp) | |
5939 ;; here, since we never add a file at | |
5940 ;; the beginning of the buffer. | |
5941 (narrow-to-region start | |
5942 (save-excursion (forward-line 1) (point))) | |
5943 (run-hooks 'dired-after-readin-hook) | |
5944 (if omit | |
5945 (let ((dired-omit-silent (or dired-omit-silent 0))) | |
5946 (dired-omit-region (point-min) (point-max) | |
5947 (dired-omit-regexp)))) | |
5948 (if hide | |
5949 (subst-char-in-region (point-min) (1- (point-max)) | |
5950 ?\n ?\r)))))) | |
5951 ;; clobber the extra newline at the end of the line | |
5952 (end-of-line) | |
5953 (delete-char 1))) | |
5954 | |
5955 ;; This is a separate function for the sake of nested dired format. | |
5956 (defun dired-add-entry-do-indentation (marker-char) | |
5957 ;; two spaces or a marker plus a space: | |
5958 (insert (if marker-char | |
5959 (let ((char (if (integerp marker-char) | |
5960 marker-char | |
5961 dired-marker-char))) | |
5962 (dired-update-marker-counters char) | |
5963 (dired-update-mode-line-modified) | |
5964 char) | |
5965 ?\040) | |
5966 ?\040)) | |
5967 | |
5968 (defun dired-remove-file (file) | |
5969 (let ((alist dired-buffers) | |
5970 buff) | |
5971 (save-excursion | |
5972 (while alist | |
5973 (setq buff (cdr (car alist))) | |
5974 (if (buffer-name buff) | |
5975 (progn | |
5976 (set-buffer buff) | |
5977 (dired-remove-entry file)) | |
5978 (setq dired-buffers (delq (car alist) dired-buffers))) | |
5979 (setq alist (cdr alist)))) | |
5980 (or dired-buffers (dired-remove-from-file-name-handler-alist)))) | |
5981 | |
5982 (defun dired-remove-entry (file) | |
5983 (let ((ddir (expand-file-name default-directory)) | |
5984 (dirname (file-name-as-directory file))) | |
5985 (if (dired-in-this-tree ddir dirname) | |
5986 (if (or (memq 'kill-dired-buffer dired-no-confirm) | |
5987 (y-or-n-p (format "Kill dired buffer %s for %s, too? " | |
5988 (buffer-name) dired-directory))) | |
5989 (kill-buffer (current-buffer))) | |
5990 (if (dired-in-this-tree file ddir) | |
5991 (let ((alist dired-subdir-alist)) | |
5992 (while alist | |
5993 (if (dired-in-this-tree (car (car alist)) dirname) | |
5994 (save-excursion | |
5995 (goto-char (dired-get-subdir-min (car alist))) | |
5996 (dired-kill-subdir))) | |
5997 (setq alist (cdr alist))) | |
5998 (dired-save-excursion | |
5999 (and (dired-goto-file file) | |
6000 (let (buffer-read-only) | |
6001 (delete-region | |
6002 (progn (skip-chars-backward "^\n\r") | |
6003 (or (memq (following-char) '(\n \r ?\ )) | |
6004 (progn | |
6005 (dired-update-marker-counters | |
6006 (following-char) t) | |
6007 (dired-update-mode-line-modified))) | |
6008 (1- (point))) | |
6009 (progn (skip-chars-forward "^\n\r") (point))) | |
6010 (if dired-verify-modtimes | |
6011 (dired-set-file-modtime | |
6012 (file-name-directory (directory-file-name file)) | |
6013 dired-subdir-alist)))))))))) | |
6014 | |
6015 (defun dired-add-file (filename &optional marker-char) | |
6016 (dired-fun-in-all-buffers | |
6017 (file-name-directory filename) | |
6018 (function dired-add-entry) filename marker-char)) | |
6019 | |
6020 (defun dired-relist-file (file) | |
6021 (dired-uncache file nil) | |
6022 (dired-fun-in-all-buffers (file-name-directory file) | |
6023 (function dired-relist-entry) file)) | |
6024 | |
6025 (defun dired-relist-entry (file) | |
6026 ;; Relist the line for FILE, or just add it if it did not exist. | |
6027 ;; FILE must be an absolute pathname. | |
6028 (let* ((file (directory-file-name file)) | |
6029 (directory (file-name-directory file)) | |
6030 (dd (expand-file-name default-directory))) | |
6031 (if (assoc directory dired-subdir-alist) | |
6032 (if (or | |
6033 ;; Not a wildcard | |
6034 (equal dd dired-directory) | |
6035 ;; Not top-level | |
6036 (not (string-equal directory dd)) | |
6037 (and (string-equal directory | |
6038 (if (consp dired-directory) | |
6039 (file-name-as-directory | |
6040 (car dired-directory)) | |
6041 (file-name-directory dired-directory))) | |
6042 (dired-file-in-wildcard-p dired-directory file))) | |
6043 (let ((marker (save-excursion | |
6044 (and (dired-goto-file file) | |
6045 (dired-file-marker file))))) | |
6046 ;; recompute omission | |
6047 (if (eq marker dired-omit-marker-char) | |
6048 (setq marker nil)) | |
6049 (dired-add-entry file marker 'relist)) | |
6050 ;; At least tell dired that we considered updating the buffer. | |
6051 (if dired-verify-modtimes | |
6052 (dired-set-file-modtime directory dired-subdir-alist)))))) | |
6053 | |
6054 (defun dired-file-in-wildcard-p (wildcard file) | |
6055 ;; Return t if a file is part of the listing for wildcard. | |
6056 ;; File should be the non-directory part only. | |
6057 ;; This version is slow, but meticulously correct. Is it worth it? | |
6058 (if (consp wildcard) | |
6059 (let ((files (cdr wildcard)) | |
6060 (dir (car wildcard)) | |
6061 yep) | |
6062 (while (and files (not yep)) | |
6063 (setq yep (string-equal file (expand-file-name (car files) dir)) | |
6064 files (cdr files))) | |
6065 yep) | |
6066 (let ((err-buff | |
6067 (let ((default-major-mode 'fundamental-mode)) | |
6068 (get-buffer-create " *dired-check-process output*"))) | |
6069 (dir default-directory) | |
6070 (process-connection-type nil)) | |
6071 (save-excursion | |
6072 (set-buffer err-buff) | |
6073 (erase-buffer) | |
6074 (setq default-directory dir) | |
6075 (call-process shell-file-name nil t nil "-c" | |
6076 (concat dired-ls-program " -d " wildcard " | " | |
6077 "egrep '(^|/)" file "$'")) | |
6078 (/= (buffer-size) 0))))) | |
6079 | |
6080 ;; The difference between dired-add-file and dired-relist-file is that | |
6081 ;; the former creates the entry with a specific marker. The later preserves | |
6082 ;; existing markers on a per buffer basis. This is not the same as | |
6083 ;; giving dired-create-files a marker of t, which uses a marker in a specific | |
6084 ;; buffer to determine the marker for file line creation in all buffers. | |
6085 | |
6086 | |
6087 ;;;; ---------------------------------------------------------------- | |
6088 ;;;; Applying Lisp functions to marked files. | |
6089 ;;;; ---------------------------------------------------------------- | |
6090 | |
6091 ;;; Running tags commands on marked files. | |
6092 ;; | |
6093 ;; Written 8/30/93 by Roland McGrath <roland@gnu.ai.mit.edu>. | |
6094 ;; Requires tags.el as distributed with GNU Emacs 19.23, or later. | |
6095 | |
6096 (defun dired-do-tags-search (regexp) | |
6097 "Search through all marked files for a match for REGEXP. | |
6098 Stops when a match is found. | |
6099 To continue searching for next match, use command \\[tags-loop-continue]." | |
6100 (interactive "sSearch marked files (regexp): ") | |
6101 (tags-search regexp '(dired-get-marked-files))) | |
6102 | |
6103 (defun dired-do-tags-query-replace (from to &optional delimited) | |
6104 "Query-replace-regexp FROM with TO through all marked files. | |
6105 Third arg DELIMITED (prefix arg) means replace only word-delimited matches. | |
6106 If you exit (\\[keyboard-quit] or ESC), you can resume the query-replace | |
6107 with the command \\[tags-loop-continue]." | |
6108 (interactive | |
6109 "sQuery replace in marked files (regexp): \nsQuery replace %s by: \nP") | |
6110 (tags-query-replace from to delimited '(dired-get-marked-files))) | |
6111 | |
6112 ;;; byte compiling | |
6113 | |
6114 (defun dired-byte-compile () | |
6115 ;; Return nil for success, offending file name else. | |
6116 (let* ((filename (dired-get-filename)) | |
6117 buffer-read-only failure) | |
6118 (condition-case err | |
6119 (save-excursion (byte-compile-file filename)) | |
6120 (error | |
6121 (setq failure err))) | |
6122 ;; We should not need to update any file lines, as this will have | |
6123 ;; already been done by after-write-region-hook. | |
6124 (and failure | |
6125 (progn | |
6126 (dired-log (buffer-name (current-buffer)) | |
6127 "Byte compile error for %s:\n%s\n" filename failure) | |
6128 (dired-make-relative filename))))) | |
6129 | |
6130 (defun dired-do-byte-compile (&optional arg) | |
6131 "Byte compile marked (or next ARG) Emacs lisp files." | |
6132 (interactive "P") | |
6133 (dired-map-over-marks-check (function dired-byte-compile) arg | |
6134 'byte-compile "byte-compile" t)) | |
6135 | |
6136 ;;; loading | |
6137 | |
6138 (defun dired-load () | |
6139 ;; Return nil for success, offending file name else. | |
6140 (let ((file (dired-get-filename)) failure) | |
6141 (condition-case err | |
6142 (load file nil nil t) | |
6143 (error (setq failure err))) | |
6144 (if (not failure) | |
6145 nil | |
6146 (dired-log (buffer-name (current-buffer)) | |
6147 "Load error for %s:\n%s\n" file failure) | |
6148 (dired-make-relative file)))) | |
6149 | |
6150 (defun dired-do-load (&optional arg) | |
6151 "Load the marked (or next ARG) Emacs lisp files." | |
6152 (interactive "P") | |
6153 (dired-map-over-marks-check (function dired-load) arg 'load "load" t)) | |
6154 | |
6155 | |
6156 ;;;; ---------------------------------------------------------------- | |
6157 ;;;; File Name Handler Alist | |
6158 ;;;; ---------------------------------------------------------------- | |
6159 ;;; | |
6160 ;;; Make sure that I/O functions maintain dired buffers. | |
6161 | |
6162 (defun dired-remove-from-file-name-handler-alist () | |
6163 ;; Remove dired from the file-name-handler-alist | |
6164 (setq file-name-handler-alist | |
6165 (delq nil | |
6166 (mapcar | |
6167 (function | |
6168 (lambda (x) | |
6169 (and (not (eq (cdr x) 'dired-handler-fn)) | |
6170 x))) | |
6171 file-name-handler-alist)))) | |
6172 | |
6173 (defun dired-check-file-name-handler-alist () | |
6174 ;; Verify that dired is installed as the first item in the alist | |
6175 (or (eq (cdr (car file-name-handler-alist)) 'dired-handler-fn) | |
6176 (setq file-name-handler-alist | |
6177 (cons | |
6178 '("." . dired-handler-fn) | |
6179 (dired-remove-from-file-name-handler-alist))))) | |
6180 | |
6181 (defun dired-handler-fn (op &rest args) | |
6182 ;; Function to update dired buffers after I/O. | |
6183 (prog1 | |
6184 (let ((inhibit-file-name-handlers | |
6185 (cons 'dired-handler-fn | |
6186 (and (eq inhibit-file-name-operation op) | |
6187 inhibit-file-name-handlers))) | |
6188 (inhibit-file-name-operation op)) | |
6189 (apply op args)) | |
6190 (let ((dired-omit-silent t) | |
6191 (hf (get op 'dired))) | |
6192 (and hf (funcall hf args))))) | |
6193 | |
6194 (defun dired-handler-fn-1 (args) | |
6195 (let ((to (expand-file-name (nth 1 args)))) | |
6196 (or (member to dired-unhandle-add-files) | |
6197 (dired-relist-file to)))) | |
6198 | |
6199 (defun dired-handler-fn-2 (args) | |
6200 (let ((from (expand-file-name (car args))) | |
6201 (to (expand-file-name (nth 1 args)))) | |
6202 ;; Don't remove the original entry if making backups. | |
6203 ;; Otherwise we lose marks. I'm not completely happy with the | |
6204 ;; logic here. | |
6205 (or (and | |
6206 (eq (nth 2 args) t) ; backups always have OK-IF-OVERWRITE t | |
6207 (string-equal (car (find-backup-file-name from)) to)) | |
6208 (dired-remove-file from)) | |
6209 (or (member to dired-unhandle-add-files) | |
6210 (dired-relist-file to)))) | |
6211 | |
6212 (defun dired-handler-fn-3 (args) | |
6213 (let ((to (expand-file-name (nth 2 args)))) | |
6214 (or (member to dired-unhandle-add-files) | |
6215 (dired-relist-file to)))) | |
6216 | |
6217 (defun dired-handler-fn-4 (args) | |
6218 (dired-remove-file (expand-file-name (car args)))) | |
6219 | |
6220 (defun dired-handler-fn-5 (args) | |
6221 (let ((to (expand-file-name (car args)))) | |
6222 (or (member to dired-unhandle-add-files) | |
6223 (dired-relist-file to)))) | |
6224 | |
6225 (defun dired-handler-fn-6 (args) | |
6226 (let ((to (expand-file-name (nth 1 args))) | |
6227 (old (expand-file-name (car args)))) | |
6228 (or (member to dired-unhandle-add-files) | |
6229 (dired-relist-file to)) | |
6230 (dired-relist-file old))) | |
6231 | |
6232 (put 'copy-file 'dired 'dired-handler-fn-1) | |
6233 (put 'dired-make-relative-symlink 'dired 'dired-handler-fn-1) | |
6234 (put 'make-symbolic-link 'dired 'dired-handler-fn-1) | |
6235 (put 'add-name-to-file 'dired 'dired-handler-fn-6) | |
6236 (put 'rename-file 'dired 'dired-handler-fn-2) | |
6237 (put 'write-region 'dired 'dired-handler-fn-3) | |
6238 (put 'delete-file 'dired 'dired-handler-fn-4) | |
6239 (put 'delete-directory 'dired 'dired-handler-fn-4) | |
6240 (put 'dired-recursive-delete-directory 'dired 'dired-handler-fn-4) | |
6241 (put 'make-directory-internal 'dired 'dired-handler-fn-5) | |
6242 (put 'set-file-modes 'dired 'dired-handler-fn-5) | |
6243 | |
6244 ;;;; ------------------------------------------------------------ | |
6245 ;;;; Autoload land. | |
6246 ;;;; ------------------------------------------------------------ | |
6247 | |
6248 ;;; Reading mail (dired-xy) | |
6249 | |
6250 (autoload 'dired-read-mail "dired-xy" | |
6251 "Reads the current file as a mail folder." t) | |
6252 (autoload 'dired-vm "dired-xy" "Run VM on this file." t) | |
6253 (autoload 'dired-rmail "dired-xy" "Run RMAIL on this file." t) | |
6254 | |
6255 ;;; Virtual dired (dired-vir) | |
6256 | |
6257 (autoload 'dired-virtual "dired-vir" | |
6258 "Put this buffer into virtual dired mode." t) | |
6259 | |
6260 ;;; Grep (dired-grep) | |
6261 | |
6262 (autoload 'dired-do-grep "dired-grep" "Grep marked files for a pattern." t) | |
6263 | |
6264 ;;; Doing diffs (dired-diff) | |
6265 | |
6266 (autoload 'dired-diff "dired-diff" | |
6267 "Compare file at point with FILE using `diff'." t) | |
6268 (autoload 'dired-backup-diff "dired-diff" | |
6269 "Diff this file with its backup file or vice versa." t) | |
6270 (autoload 'dired-emerge "dired-diff" | |
6271 "Merge file at point with FILE using `emerge'." t) | |
6272 (autoload 'dired-emerge-with-ancestor "dired-diff" | |
6273 "Merge file at point with FILE, using a common ANCESTOR file." t) | |
6274 (autoload 'dired-ediff "dired-diff" "Ediff file at point with FILE." t) | |
6275 (autoload 'dired-epatch "dired-diff" "Patch file at point using `epatch'." t) | |
6276 | |
6277 ;;; Shell commands (dired-shell) | |
6278 | |
6279 (autoload 'dired-do-print "dired-shell" "Print the marked (next ARG) files." t) | |
6280 (autoload 'dired-run-shell-command "dired-shell" nil) | |
6281 (autoload 'dired-do-shell-command "dired-shell" | |
6282 "Run a shell command on the marked (or next ARG) files." t) | |
6283 (autoload 'dired-do-background-shell-command "dired-shell" | |
6284 "Run a background shell command on marked (or next ARG) files." t) | |
6285 | |
6286 ;;; Commands using regular expressions (dired-rgxp) | |
6287 | |
6288 (autoload 'dired-mark-files-regexp "dired-rgxp" | |
6289 "Mark all files whose names match REGEXP." t) | |
6290 (autoload 'dired-flag-files-regexp "dired-rgxp" | |
6291 "Flag for deletion all files whose names match REGEXP." t) | |
6292 (autoload 'dired-mark-extension "dired-rgxp" | |
6293 "Mark all files whose names have a given extension." t) | |
6294 (autoload 'dired-flag-extension "dired-rgxp" | |
6295 "Flag for deletion all files whose names have a given extension." t) | |
6296 (autoload 'dired-cleanup "dired-rgxp" | |
6297 "Flag for deletion dispensable files files created by PROGRAM." t) | |
6298 (autoload 'dired-do-rename-regexp "dired-rgxp" | |
6299 "Rename marked files whose names match a given regexp." t) | |
6300 (autoload 'dired-do-copy-regexp "dired-rgxp" | |
6301 "Copy marked files whose names match a given regexp." t) | |
6302 (autoload 'dired-do-hardlink-regexp "dired-rgxp" | |
6303 "Hardlink all marked files whose names match a regexp." t) | |
6304 (autoload 'dired-do-symlink "dired-rgxp" | |
6305 "Make a symbolic link to all files whose names match a regexp." t) | |
6306 (autoload | |
6307 'dired-do-relsymlink-regexp "dired-rgxp" | |
6308 "Make a relative symbolic link to all files whose names match a regexp." t) | |
6309 (autoload 'dired-upcase "dired-rgxp" | |
6310 "Rename all marked (or next ARG) files to upper case." t) | |
6311 (autoload 'dired-downcase "dired-rgxp" | |
6312 "Rename all marked (or next ARG) files to lower case." t) | |
6313 | |
6314 ;;; Marking files from other buffers (dired-mob) | |
6315 | |
6316 (autoload 'dired-mark-files-from-other-dired-buffer "dired-mob" | |
6317 "Mark files which are marked in another dired buffer." t) | |
6318 (autoload 'dired-mark-files-compilation-buffer "dired-mob" | |
6319 "Mark the files mentioned in the compilation buffer." t) | |
6320 | |
6321 ;;; uuencoding (dired-uu) | |
6322 | |
6323 (autoload 'dired-do-uucode "dired-uu" "Uuencode or uudecode marked files." t) | |
6324 | |
6325 ;;; Compressing (dired-cmpr) | |
6326 | |
6327 (autoload 'dired-do-compress "dired-cmpr" | |
6328 "Compress or uncompress marked files." t) | |
6329 (autoload 'dired-compress-subdir-files "dired-cmpr" | |
6330 "Compress uncompressed files in the current subdirectory." t) | |
6331 | |
6332 | |
6333 ;;; Marking files according to sexps | |
6334 | |
6335 (autoload 'dired-mark-sexp "dired-sex" | |
6336 "Mark files according to an sexpression." t) | |
6337 | |
6338 ;;; Help! | |
6339 | |
6340 (autoload 'dired-summary "dired-help" | |
6341 "Display summary of basic dired commands in the minibuffer." t) | |
6342 (autoload 'dired-describe-mode "dired-help" | |
6343 "Detailed description of dired mode. | |
6344 With a prefix, runs the info documentation browser for dired." t) | |
6345 (autoload 'dired-apropos "dired-help" | |
6346 "Do command apropos help for dired commands. | |
6347 With prefix does apropos help for dired variables." t) | |
6348 (autoload 'dired-report-bug "dired-help" "Report a bug for dired." t) | |
6349 | |
6350 ;;;; -------------------------------------------------------------- | |
6351 ;;;; Multi-flavour Emacs support | |
6352 ;;;; -------------------------------------------------------------- | |
6353 | |
6354 (let ((lucid-p (string-match "Lucid" emacs-version)) | |
6355 ver) | |
6356 (or (string-match "^\\([0-9]+\\)\\." emacs-version) | |
6357 (error "Weird emacs version %s" emacs-version)) | |
6358 (setq ver (string-to-int (substring emacs-version (match-beginning 1) | |
6359 (match-end 1)))) | |
6360 | |
6361 ;; Reading with history. | |
6362 (if (>= ver 19) | |
6363 | |
6364 (defun dired-read-with-history (prompt initial history) | |
6365 (read-from-minibuffer prompt initial nil nil history)) | |
6366 | |
6367 (defun dired-read-with-history (prompt initial history) | |
6368 (let ((minibuffer-history-symbol history)) ; for gmhist | |
6369 (read-string prompt initial)))) | |
6370 | |
6371 ;; Completing read with history. | |
6372 (if (>= ver 19) | |
6373 | |
6374 (fset 'dired-completing-read 'completing-read) | |
6375 | |
6376 (defun dired-completing-read (prompt table &optional predicate | |
6377 require-match initial-input history) | |
6378 (let ((minibuffer-history-symbol history)) ; for gmhist | |
6379 (completing-read prompt table predicate require-match | |
6380 initial-input)))) | |
6381 | |
6382 ;; Abbreviating file names. | |
6383 (if lucid-p | |
6384 (fset 'dired-abbreviate-file-name | |
6385 ;; Lemacs has this extra hack-homedir arg | |
6386 (function | |
6387 (lambda (fn) | |
6388 (abbreviate-file-name fn t)))) | |
6389 (fset 'dired-abbreviate-file-name 'abbreviate-file-name)) | |
6390 | |
6391 ;; Deleting directories | |
6392 ;; Check for pre 19.8 versions of lucid emacs. | |
6393 (if lucid-p | |
6394 (or (fboundp 'delete-directory) | |
6395 (fset 'delete-directory 'remove-directory))) | |
6396 | |
6397 ;; Minibuffers | |
6398 (if (= ver 18) | |
6399 | |
6400 (defun dired-get-active-minibuffer-window () | |
6401 (and (> (minibuffer-depth) 0) | |
6402 (minibuffer-window))) | |
6403 | |
6404 (defun dired-get-active-minibuffer-window () | |
6405 (let ((frames (frame-list)) | |
6406 win found) | |
6407 (while frames | |
6408 (if (and (setq win (minibuffer-window (car frames))) | |
6409 (minibuffer-window-active-p win)) | |
6410 (setq found win | |
6411 frames nil) | |
6412 (setq frames (cdr frames)))) | |
6413 found))) | |
6414 | |
6415 ;; Text properties and menus. | |
6416 | |
6417 (cond | |
6418 (lucid-p | |
6419 (require 'dired-xemacs)) | |
6420 ((>= ver 19) | |
6421 (require 'dired-fsf)) | |
6422 (t | |
6423 ;; text property stuff doesn't work in V18 | |
6424 (fset 'dired-insert-set-properties 'ignore) | |
6425 (fset 'dired-remove-text-properties 'ignore) | |
6426 (fset 'dired-set-text-properties 'ignore) | |
6427 (fset 'dired-move-to-filename 'dired-manual-move-to-filename) | |
6428 (fset 'dired-move-to-end-of-filename | |
6429 'dired-manual-move-to-end-of-filename)))) | |
6430 | |
6431 ;;; MULE | |
6432 | |
6433 (if (or (boundp 'MULE) (featurep 'mule)) (load "dired-mule")) | |
6434 | |
6435 | |
6436 ;; Run load hook for user customization. | |
6437 (run-hooks 'dired-load-hook) | |
6438 | |
6439 ;;; end of dired.el |