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