|
22
|
1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
2 ;;
|
|
|
3 ;; File: dired-xemacs.el
|
|
|
4 ;; Dired Version: $Revision: 1.1 $
|
|
|
5 ;; RCS:
|
|
|
6 ;; Description: dired functions for XEmacs
|
|
|
7 ;; Author: Mike Sperber <sperber@informatik.uni-tuebingen.de>
|
|
|
8 ;;
|
|
|
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
10
|
|
|
11 (provide 'dired-xemacs)
|
|
|
12 (require 'dired)
|
|
|
13
|
|
|
14 (require 'backquote)
|
|
|
15
|
|
|
16 ;;; Variables
|
|
|
17
|
|
|
18 ;; kludge
|
|
|
19 (defun dired-demarkify-regexp (re)
|
|
|
20 (if (string-equal (substring re 0 (length dired-re-maybe-mark))
|
|
|
21 dired-re-maybe-mark)
|
|
|
22 (concat "^" (substring re
|
|
|
23 (length dired-re-maybe-mark)
|
|
|
24 (length re)))
|
|
|
25 re))
|
|
|
26
|
|
|
27 (defvar dired-do-highlighting t
|
|
|
28 "Set if we should use highlighting according to filetype.")
|
|
|
29
|
|
|
30 (defvar dired-do-interactive-permissions t
|
|
|
31 "Set if we should allow interactive chmod.")
|
|
|
32
|
|
|
33 (defvar dired-re-raw-dir (dired-demarkify-regexp dired-re-dir))
|
|
|
34 (defvar dired-re-raw-sym (dired-demarkify-regexp dired-re-sym))
|
|
|
35 (defvar dired-re-raw-exe (dired-demarkify-regexp dired-re-exe))
|
|
|
36
|
|
|
37 (defvar dired-re-raw-boring (dired-omit-regexp)
|
|
|
38 "Regexp to match backup, autosave and otherwise boring files.")
|
|
|
39
|
|
|
40 (defvar dired-re-raw-socket (concat "^" dired-re-inode-size "s"))
|
|
|
41
|
|
|
42 (defvar dired-re-raw-setuid
|
|
|
43 (concat "^" dired-re-inode-size
|
|
|
44 "-[-r][-w][Ss][-r][-w][sx][-r][-w][xst]")
|
|
|
45 "setuid plain file (even if not executable)")
|
|
|
46
|
|
|
47 (defvar dired-re-raw-setgid
|
|
|
48 (concat "^" dired-re-inode-size
|
|
|
49 "-[-r][-w][-x][-r][-w][Ss][-r][-w][xst]")
|
|
|
50 "setgid plain file (even if not executable)")
|
|
|
51
|
|
|
52 (defvar dired-re-pre-permissions "^.? ?[0-9 ]*[-d]"
|
|
|
53 "Regexp matching the preamble to file permissions part of a dired line.
|
|
|
54 This shouldn't match socket or symbolic link lines (which aren't editable).")
|
|
|
55
|
|
|
56 (defvar dired-re-permissions "[-r][-w][-Ssx][-r][-w][-sx][-r][-w][-xst]"
|
|
|
57 "Regexp matching the file permissions part of a dired line.")
|
|
|
58
|
|
|
59 ;;; Setup
|
|
|
60
|
|
|
61 (setq dired-modeline-tracking-cmds '(mouse-track))
|
|
|
62
|
|
|
63 ;;; Make needed faces if the user hasn't already done so.
|
|
|
64 ;;; Respect X resources (`make-face' uses them when they exist).
|
|
|
65
|
|
|
66 (let ((change-it
|
|
|
67 (function (lambda (face)
|
|
|
68 (or (if (fboundp 'facep)
|
|
|
69 (facep face)
|
|
|
70 (memq face (face-list)))
|
|
|
71 (make-face face))
|
|
|
72 (not (face-differs-from-default-p face))))))
|
|
|
73
|
|
|
74 (if (funcall change-it 'dired-face-marked)
|
|
|
75 (progn
|
|
|
76 (set-face-background 'dired-face-marked "PaleVioletRed"
|
|
|
77 'global '(color) 'append)
|
|
|
78 (set-face-underline-p 'dired-face-marked t
|
|
|
79 'global '(mono) 'append)
|
|
|
80 (set-face-underline-p 'dired-face-marked t
|
|
|
81 'global '(grayscale) 'append)))
|
|
|
82 (if (funcall change-it 'dired-face-deleted)
|
|
|
83 (progn
|
|
|
84 (set-face-background 'dired-face-deleted "LightSlateGray"
|
|
|
85 'global '(color) 'append)
|
|
|
86 (set-face-underline-p 'dired-face-deleted t
|
|
|
87 'global '(mono) 'append)
|
|
|
88 (set-face-underline-p 'dired-face-deleted t
|
|
|
89 'global '(grayscale) 'append)))
|
|
|
90 (if (funcall change-it 'dired-face-directory)
|
|
|
91 (make-face-bold 'dired-face-directory))
|
|
|
92 (if (funcall change-it 'dired-face-executable)
|
|
|
93 (progn
|
|
|
94 (set-face-foreground 'dired-face-executable "SeaGreen"
|
|
|
95 'global '(color) 'append)
|
|
|
96 (make-face-bold 'dired-face-executable)))
|
|
|
97 (if (funcall change-it 'dired-face-setuid)
|
|
|
98 (progn
|
|
|
99 (set-face-foreground 'dired-face-setuid "Red"
|
|
|
100 'global '(color) 'append)
|
|
|
101 (make-face-bold 'dired-face-setuid)))
|
|
|
102 (if (funcall change-it 'dired-face-socket)
|
|
|
103 (progn
|
|
|
104 (set-face-foreground 'dired-face-socket "Gold"
|
|
|
105 'global '(color) 'append)
|
|
|
106 (make-face-italic 'dired-face-socket)))
|
|
|
107 (if (funcall change-it 'dired-face-symlink)
|
|
|
108 (progn
|
|
|
109 (set-face-foreground 'dired-face-symlink "MediumBlue"
|
|
|
110 'global '(color) 'append)
|
|
|
111 (make-face-bold 'dired-face-symlink)))
|
|
|
112
|
|
|
113 (if (funcall change-it 'dired-face-boring)
|
|
|
114 (progn
|
|
|
115 (set-face-foreground 'dired-face-boring "Grey"
|
|
|
116 'global '(color) 'append)
|
|
|
117 (set-face-background-pixmap
|
|
|
118 'dired-face-boring
|
|
|
119 [xbm :data (32 2 "\125\125\125\125\252\252\252\252")]
|
|
|
120 'global '(mono) 'append)
|
|
|
121 (set-face-background-pixmap
|
|
|
122 'dired-face-boring
|
|
|
123 [xbm :data (32 2 "\125\125\125\125\252\252\252\252")]
|
|
|
124 'global '(grayscale) 'append)))
|
|
|
125 (if (funcall change-it 'dired-face-permissions)
|
|
|
126 (progn
|
|
|
127 (set-face-foreground 'dired-face-permissions "MediumOrchid"
|
|
|
128 'global '(color) 'append)
|
|
|
129 (set-face-underline-p 'dired-face-deleted t
|
|
|
130 'global '(mono) 'append)
|
|
|
131 (set-face-underline-p 'dired-face-deleted t
|
|
|
132 'global '(grayscale) 'append))))
|
|
|
133
|
|
|
134 ;;; Menus
|
|
|
135
|
|
|
136 (defvar dired-subdir-menu nil "The Subdir menu for dired")
|
|
|
137 (defvar dired-mark-menu nil "The Mark menu for dired")
|
|
|
138 (defvar dired-do-menu nil "The Do menu for dired")
|
|
|
139 (defvar dired-regexp-menu nil "The Regexp menu for dired")
|
|
|
140 (defvar dired-look-menu nil "The Look menu for dired")
|
|
|
141 (defvar dired-sort-menu nil "The Sort menu for dired")
|
|
|
142 (defvar dired-help-menu nil "The Help menu for dired")
|
|
|
143
|
|
|
144 (defvar dired-menubar-menus
|
|
|
145 '(("Subdir" . dired-subdir-menu)
|
|
|
146 ("Mark" . dired-mark-menu)
|
|
|
147 ("Do" . dired-do-menu)
|
|
|
148 ("Regexp" . dired-regexp-menu)
|
|
|
149 ("Look" . dired-look-menu)
|
|
|
150 ("Sort" . dired-sort-menu))
|
|
|
151 "All the dired menus.")
|
|
|
152
|
|
|
153 (defvar dired-visit-popup-menu nil "The Visit popup for dired")
|
|
|
154 (defvar dired-do-popup-menu nil "The Do popup for dired")
|
|
|
155
|
|
|
156 (defun dired-setup-menus ()
|
|
|
157 (setq
|
|
|
158 dired-visit-popup-menu
|
|
|
159 '(["Find File" dired-find-file t]
|
|
|
160 ["Find in Other Window" dired-find-file-other-window t]
|
|
|
161 ["Find in Other Frame" dired-find-file-other-frame t]
|
|
|
162 ["View File" dired-view-file t]
|
|
|
163 ["Display in Other Window" dired-find-file-other-window t]))
|
|
|
164
|
|
|
165 (setq
|
|
|
166 dired-do-popup-menu
|
|
|
167 '(["Copy to..." dired-do-copy t]
|
|
|
168 ["Rename to..." dired-do-rename t]
|
|
|
169 ["Compress/Uncompress" dired-do-compress t]
|
|
|
170 ["Uuencode/Uudecode" dired-do-uucode t]
|
|
|
171 ["Change Mode..." dired-do-chmod t]
|
|
|
172 ["Change Owner..." dired-do-chown t]
|
|
|
173 ["Change Group..." dired-do-chgrp t]
|
|
|
174 ["Load" dired-do-load t]
|
|
|
175 ["Byte-compile" dired-do-byte-compile t]
|
|
|
176 ["Hardlink to..." dired-do-hardlink t]
|
|
|
177 ["Symlink to..." dired-do-symlink t]
|
|
|
178 ["Shell Command..." dired-do-shell-command t]
|
|
|
179 ["Background Shell Command..." dired-do-background-shell-command t]
|
|
|
180 ["Delete" dired-do-delete t]))
|
|
|
181
|
|
|
182 (setq
|
|
|
183 dired-subdir-menu
|
|
|
184 (list
|
|
|
185 ["Next Subdir" dired-next-subdir t]
|
|
|
186 ["Prev Subdir" dired-prev-subdir t]
|
|
|
187 ["Next Dirline" dired-next-dirline t]
|
|
|
188 ["Prev Dirline" dired-prev-dirline t]
|
|
|
189 ["Up Dir" dired-up-directory t]
|
|
|
190 ["Down Dir" dired-down-directory t]
|
|
|
191 ["Insert This Subdir" dired-maybe-insert-subdir t]
|
|
|
192 ["Create Directory..." dired-create-directory t]
|
|
|
193 ["Kill This Subdir" dired-kill-subdir t]
|
|
|
194 "-- Commands on All Files in Subdir --"
|
|
|
195 ["Redisplay Subdir" dired-redisplay-subdir t]
|
|
|
196 ["Mark Files" dired-mark-subdir-files t]
|
|
|
197 ["Flag Files for Deletion" dired-flag-subdir-files t]
|
|
|
198 ["Compress Uncompressed Files" dired-compress-subdir-files t]
|
|
|
199 (vector "Uncompress Compressed Files"
|
|
|
200 '(let ((current-prefix-arg t))
|
|
|
201 (dired-compress-subdir-files))
|
|
|
202 ':keys (dired-key-description 'dired-compress-subdir-files
|
|
|
203 'universal-argument))))
|
|
|
204
|
|
|
205 (setq
|
|
|
206 dired-mark-menu
|
|
|
207 (list
|
|
|
208 ["Next Marked" dired-next-marked-file t]
|
|
|
209 ["Previous Marked" dired-prev-marked-file t]
|
|
|
210 ["Change Marks..." dired-change-marks t]
|
|
|
211 ["Unmark All" dired-unmark-all-files t]
|
|
|
212 (vector "Toggle marks..."
|
|
|
213 '(let ((current-prefix-arg t))
|
|
|
214 (call-interactively 'dired-change-marks))
|
|
|
215 ':keys (dired-key-description 'dired-change-marks
|
|
|
216 'universal-argument))
|
|
|
217 ["Mark Symlinks" dired-mark-symlinks t]
|
|
|
218 ["Mark Directories" dired-mark-directories t]
|
|
|
219 ["Mark Old Backups" dired-clean-directory t]
|
|
|
220 ["Mark Executables" dired-mark-executables t]
|
|
|
221 ["Flag Backup Files" dired-flag-backup-files t]
|
|
|
222 ["Flag Auto-save Files" dired-flag-auto-save-files t]
|
|
|
223 ["Set new marker char" dired-set-marker-char t]
|
|
|
224 ["Restore marker char" dired-restore-marker-char t]
|
|
|
225 ["Marker stack left" dired-marker-stack-left t]
|
|
|
226 ["Marker stack right" dired-marker-stack-right t]
|
|
|
227 "---"
|
|
|
228 ["Mark Files from Other Dired" dired-mark-files-from-other-dired-buffer t]
|
|
|
229 ["Mark Files from Compile Buffer..." dired-mark-files-compilation-buffer t]))
|
|
|
230
|
|
|
231 (setq
|
|
|
232 dired-do-menu
|
|
|
233 '(["Copy to..." dired-do-copy t]
|
|
|
234 ["Rename to..." dired-do-rename t]
|
|
|
235 ["Expunge File Flagged for Deletion" dired-expunge-deletions t]
|
|
|
236 ["Compress/Uncompress" dired-do-compress t]
|
|
|
237 ["Uuencode/Uudecode" dired-do-uucode t]
|
|
|
238 ["Print..." dired-do-print t]
|
|
|
239 ["Change Mode..." dired-do-interactive-chmod t]
|
|
|
240 ["Change Owner..." dired-do-chown t]
|
|
|
241 ["Change Group..." dired-do-chgrp t]
|
|
|
242 ["Byte-compile" dired-do-byte-compile t]
|
|
|
243 ["Hardlink to..." dired-do-hardlink t]
|
|
|
244 ["Symlink to..." dired-do-symlink t]
|
|
|
245 ["Shell Command..." dired-do-shell-command t]
|
|
|
246 ["Background Shell Command..." dired-do-background-shell-command t]
|
|
|
247 ["Delete Marked Files" dired-do-delete t]
|
|
|
248 ["Visit file menu >" dired-visit-popup-menu-internal t]
|
|
|
249 ["Operate on file menu >" dired-do-popup-menu-internal t]))
|
|
|
250
|
|
|
251 (setq
|
|
|
252 dired-regexp-menu
|
|
|
253 (list
|
|
|
254 ["Mark..." dired-mark-files-regexp t]
|
|
|
255 ["Mark Files with Extension..." dired-mark-extension t]
|
|
|
256 ["Flag..." dired-flag-files-regexp t]
|
|
|
257 ["Flag Files with Extension..." dired-flag-extension t]
|
|
|
258 ["Downcase" dired-downcase t]
|
|
|
259 ["Upcase" dired-upcase t]
|
|
|
260 ["Copy..." dired-do-copy-regexp t]
|
|
|
261 ["Rename..." dired-do-rename-regexp t]
|
|
|
262 ["Hardlink..." dired-do-hardlink-regexp t]
|
|
|
263 ["Symlink..." dired-do-symlink-regexp t]
|
|
|
264 ["Relative Symlink..." dired-do-relsymlink-regexp t]
|
|
|
265 "---"
|
|
|
266 ["Add Omit Regex..." dired-add-omit-regexp t]
|
|
|
267 (vector "Remove Omit Regex..."
|
|
|
268 '(let ((current-prefix-arg 1))
|
|
|
269 (call-interactively 'dired-add-omit-regexp))
|
|
|
270 ':keys (dired-key-description 'dired-add-omit-regexp 1))
|
|
|
271 (vector "Add Omit Extension..."
|
|
|
272 '(let ((current-prefix-arg '(4)))
|
|
|
273 (call-interactively 'dired-add-omit-regexp))
|
|
|
274 ':keys (dired-key-description 'dired-add-omit-regexp 'universal-argument))
|
|
|
275 (vector "Remove Omit Extension..."
|
|
|
276 '(let ((current-prefix-arg '(16)))
|
|
|
277 (call-interactively 'dired-add-omit-regexp))
|
|
|
278 ':keys (dired-key-description 'dired-add-omit-regexp
|
|
|
279 'universal-argument 'universal-argument))
|
|
|
280 (vector "Show Omit Regex"
|
|
|
281 '(let ((current-prefix-arg 0))
|
|
|
282 (call-interactively 'dired-add-omit-regexp))
|
|
|
283 ':keys (dired-key-description 'dired-add-omit-regexp 0))))
|
|
|
284
|
|
|
285 (setq
|
|
|
286 dired-look-menu
|
|
|
287 '(["Grep for..." dired-do-grep t]
|
|
|
288 ["Tags Search for..." dired-do-tags-search t]
|
|
|
289 ["Tags Query Replace..." dired-do-tags-query-replace t]
|
|
|
290 "---"
|
|
|
291 ["Diff File..." dired-diff t]
|
|
|
292 ["Diff with Backup" dired-backup-diff t]
|
|
|
293 ["Merge Files..." dired-emerge t]
|
|
|
294 ["Merge Files Having Common Ancestor..." dired-emerge-with-ancestor t]
|
|
|
295 ["Ediff Files..." dired-ediff t]
|
|
|
296 ["Patch File" dired-epatch t]))
|
|
|
297
|
|
|
298 (setq
|
|
|
299 dired-sort-menu
|
|
|
300 (list
|
|
|
301 ["Toggle Current Subdir by Name/Date" dired-sort-toggle-or-edit t]
|
|
|
302 (vector "Show Current Switches"
|
|
|
303 '(dired-sort-toggle-or-edit 0)
|
|
|
304 ':keys (dired-key-description 'dired-sort-toggle-or-edit 0))
|
|
|
305 (vector "Edit Switches for Current Subdir..."
|
|
|
306 '(dired-sort-toggle-or-edit 1)
|
|
|
307 ':keys (dired-key-description 'dired-sort-toggle-or-edit 1))
|
|
|
308 (vector "Edit Default Switches for Inserted Subdirs..."
|
|
|
309 '(dired-sort-toggle-or-edit 2)
|
|
|
310 ':keys (dired-key-description 'dired-sort-toggle-or-edit 2))
|
|
|
311 (vector "Sort Entire Buffer by Date"
|
|
|
312 '(dired-sort-toggle-or-edit 'date)
|
|
|
313 ':keys (dired-key-description 'dired-sort-toggle-or-edit
|
|
|
314 'universal-argument))
|
|
|
315 (vector "Sort Entire Buffer by Name"
|
|
|
316 '(dired-sort-toggle-or-edit 'name)
|
|
|
317 ':keys (dired-key-description 'dired-sort-toggle-or-edit
|
|
|
318 'universal-argument))
|
|
|
319 (vector "Edit Switches for Entire Buffer..."
|
|
|
320 '(dired-sort-toggle-or-edit '(16))
|
|
|
321 ':keys (dired-key-description 'dired-sort-toggle-or-edit
|
|
|
322 'universal-argument))
|
|
|
323 "---"
|
|
|
324 ["Hide All Subdirs" dired-hide-all t]
|
|
|
325 ["Hide Subdir" dired-hide-subdir t]
|
|
|
326 ["Toggle Omit" dired-omit-toggle t]
|
|
|
327 ["Kill Marked Lines" dired-do-kill-file-lines t]
|
|
|
328 (vector "Redisplay Killed Lines"
|
|
|
329 '(dired-do-kill-file-lines 0)
|
|
|
330 ':keys (dired-key-description 'dired-do-kill-file-lines "0"))))
|
|
|
331 (setq
|
|
|
332 dired-help-menu
|
|
|
333 (list
|
|
|
334 ["Dired Summary Help" dired-summary t]
|
|
|
335 ["Describe Dired" dired-describe-mode t]
|
|
|
336 (vector "Dired Info Manual"
|
|
|
337 '(dired-describe-mode t)
|
|
|
338 ':keys (dired-key-description 'dired-describe-mode
|
|
|
339 'universal-argument))
|
|
|
340 ["Dired Command Apropos" dired-apropos t]
|
|
|
341 (vector "Dired Variable Apropos"
|
|
|
342 '(let ((current-prefix-arg t))
|
|
|
343 (call-interactively 'dired-apropos))
|
|
|
344 ':keys (dired-key-description 'dired-apropos 'universal-argument))
|
|
|
345 ["Report Dired Bug" dired-report-bug t])))
|
|
|
346
|
|
|
347 (defun dired-install-menubar ()
|
|
|
348 "Installs the Dired menu at the menubar."
|
|
|
349 (if (null dired-help-menu)
|
|
|
350 (dired-setup-menus))
|
|
|
351 (if current-menubar
|
|
|
352 (progn
|
|
|
353 (let ((buffer-menubar (copy-sequence current-menubar)))
|
|
|
354 (delete (assoc "Edit" buffer-menubar) buffer-menubar)
|
|
|
355 (set-buffer-menubar buffer-menubar)
|
|
|
356 (mapcar
|
|
|
357 (function
|
|
|
358 (lambda (pair)
|
|
|
359 (let ((name (car pair))
|
|
|
360 (menu (symbol-value (cdr pair))))
|
|
|
361 (add-submenu nil (cons name menu)))))
|
|
|
362 dired-menubar-menus))
|
|
|
363 (add-menu-button '("Help") (list "---"))
|
|
|
364 (add-submenu '("Help") (cons "Dired" dired-help-menu)))))
|
|
|
365
|
|
|
366 (add-hook 'dired-mode-hook 'dired-install-menubar)
|
|
|
367
|
|
|
368 ;;; Mouse functions
|
|
|
369
|
|
|
370 (defun dired-mouse-find-file (event)
|
|
|
371 "In dired, visit the file or directory name you click on."
|
|
|
372 (interactive "e")
|
|
|
373 (save-excursion
|
|
|
374 (set-buffer (window-buffer (event-window event)))
|
|
|
375 (if dired-subdir-alist
|
|
|
376 (save-excursion
|
|
|
377 (goto-char (event-point event))
|
|
|
378 (dired-find-file))
|
|
|
379 (error
|
|
|
380 (concat "dired-subdir-alist seems to be mangled. "
|
|
|
381 (substitute-command-keys
|
|
|
382 "\\<dired-mode-map>Try dired-revert (\\[dired-revert])."))))))
|
|
|
383
|
|
|
384 (defun dired-mouse-mark (event)
|
|
|
385 "In dired, mark the file name that you click on.
|
|
|
386 If the file name is already marked, this unmarks it."
|
|
|
387 (interactive "e")
|
|
|
388 (save-excursion
|
|
|
389 (set-buffer (window-buffer (event-window event)))
|
|
|
390 (if dired-subdir-alist
|
|
|
391 (save-excursion
|
|
|
392 (goto-char (event-point event))
|
|
|
393 (beginning-of-line)
|
|
|
394 (if (looking-at dired-re-mark)
|
|
|
395 (dired-unmark 1)
|
|
|
396 (dired-mark 1)))
|
|
|
397 (error
|
|
|
398 (concat "dired-subdir-alist seems to be mangled. "
|
|
|
399 (substitute-command-keys
|
|
|
400 "\\<dired-mode-map>Try dired-revert (\\[dired-revert])."))))))
|
|
|
401
|
|
|
402 (defun dired-mouse-flag (event)
|
|
|
403 "In dired, flag for deletion the file name that you click on.
|
|
|
404 If the file name is already flag, this unflags it."
|
|
|
405 (interactive "e")
|
|
|
406 (save-excursion
|
|
|
407 (set-buffer (window-buffer (event-window event)))
|
|
|
408 (if dired-subdir-alist
|
|
|
409 (save-excursion
|
|
|
410 (goto-char (event-point event))
|
|
|
411 (beginning-of-line)
|
|
|
412 (if (char-equal (following-char) dired-del-marker)
|
|
|
413 (dired-unflag 1)
|
|
|
414 (dired-flag-file-deletion 1)))
|
|
|
415 (error
|
|
|
416 (concat "dired-subdir-alist seems to be mangled. "
|
|
|
417 (substitute-command-keys
|
|
|
418 "\\<dired-mode-map>Try dired-revert (\\[dired-revert])."))))))
|
|
|
419
|
|
|
420 (defun dired-mouse-get-target (event)
|
|
|
421 "In dired, put a copy of the selected directory in the active minibuffer."
|
|
|
422 (interactive "e")
|
|
|
423 (let ((obuff (current-buffer))
|
|
|
424 mb)
|
|
|
425 (set-buffer (window-buffer (event-window event)))
|
|
|
426 (if (and dired-subdir-alist (setq mb (dired-get-active-minibuffer-window)))
|
|
|
427 (let (dir)
|
|
|
428 (goto-char (event-point event))
|
|
|
429 (setq dir (dired-current-directory))
|
|
|
430 (select-window mb)
|
|
|
431 (set-buffer (window-buffer mb))
|
|
|
432 (erase-buffer)
|
|
|
433 (insert dir))
|
|
|
434 (set-buffer obuff)
|
|
|
435 (if mb
|
|
|
436 (error "No directory specified")
|
|
|
437 (error "No active minibuffer")))))
|
|
|
438
|
|
|
439 (defun dired-visit-popup-menu (event)
|
|
|
440 "Popup a menu to visit the moused file."
|
|
|
441 (interactive "e")
|
|
|
442 (save-excursion
|
|
|
443 (set-buffer (window-buffer (event-window event)))
|
|
|
444 (save-excursion
|
|
|
445 (goto-char (event-point event))
|
|
|
446 (dired-visit-popup-menu-internal event))))
|
|
|
447
|
|
|
448 (defun dired-visit-popup-menu-internal (event)
|
|
|
449 (interactive "e")
|
|
|
450 (let ((fn (dired-get-filename 'no-dir)))
|
|
|
451 (popup-menu
|
|
|
452 (cons (concat "Visit " fn " with") dired-visit-popup-menu))
|
|
|
453 ;; this looks like a kludge to me ...
|
|
|
454 (while (popup-up-p)
|
|
|
455 (dispatch-event (next-event)))))
|
|
|
456
|
|
|
457 (defun dired-do-popup-menu (event)
|
|
|
458 "Pop up a menu to do an operation on the moused file."
|
|
|
459 (interactive "e")
|
|
|
460 (let ((obuff (current-buffer)))
|
|
|
461 (unwind-protect
|
|
|
462 (progn
|
|
|
463 (set-buffer (window-buffer (event-window event)))
|
|
|
464 (dired-save-excursion
|
|
|
465 (goto-char (event-point event))
|
|
|
466 (dired-do-popup-menu-internal event)))
|
|
|
467 (set-buffer obuff))))
|
|
|
468
|
|
|
469 (defun dired-do-popup-menu-internal (event)
|
|
|
470 (interactive "e")
|
|
|
471 (let ((fn (dired-get-filename 'no-dir))
|
|
|
472 (current-prefix-arg 1))
|
|
|
473 (popup-menu
|
|
|
474 (cons (concat "Do operation on " fn) dired-do-popup-menu))
|
|
|
475 (while (popup-up-p)
|
|
|
476 (dispatch-event (next-event)))))
|
|
|
477
|
|
|
478 (defvar dired-filename-local-map
|
|
|
479 (let ((map (make-sparse-keymap)))
|
|
|
480 (set-keymap-name map 'dired-filename-local-map)
|
|
|
481 (define-key map 'button2 'dired-mouse-find-file)
|
|
|
482 (define-key map 'button3 'dired-visit-popup-menu)
|
|
|
483 (define-key map '(control button2) 'dired-do-popup-menu)
|
|
|
484 (define-key map '(shift button1) 'dired-mouse-mark)
|
|
|
485 (define-key map '(control shift button1) 'dired-mouse-flag)
|
|
|
486 map)
|
|
|
487 "Keymap used to activate actions on files in dired.")
|
|
|
488
|
|
|
489 ;; Make this defined everywhere in the dired buffer.
|
|
|
490 (define-key dired-mode-map '(meta button3) 'dired-mouse-get-target)
|
|
|
491
|
|
|
492 ;;; Extent managment
|
|
|
493
|
|
|
494 (defun dired-set-text-properties (start end &optional face)
|
|
|
495 (let ((filename-extent (make-extent start end)))
|
|
|
496 (set-extent-face filename-extent (or face 'default))
|
|
|
497 (set-extent-property filename-extent 'dired-file-name t)
|
|
|
498 (set-extent-property filename-extent 'start-open t)
|
|
|
499 (set-extent-property filename-extent 'end-open t)
|
|
|
500 (set-extent-property filename-extent 'keymap dired-filename-local-map)
|
|
|
501 (set-extent-property filename-extent 'highlight t)
|
|
|
502 (set-extent-property
|
|
|
503 filename-extent 'help-echo
|
|
|
504 (concat
|
|
|
505 "button2 finds, button3 visits, "
|
|
|
506 "C-button2 file ops, [C-]shift-button1 marks/flags."))
|
|
|
507 filename-extent))
|
|
|
508
|
|
|
509 (defun dired-insert-set-properties (beg end)
|
|
|
510 ;; Sets the extents for the file names and their properties
|
|
|
511 (save-excursion
|
|
|
512 (goto-char beg)
|
|
|
513 (beginning-of-line)
|
|
|
514 (let ((eol (save-excursion (end-of-line) (point)))
|
|
|
515 (bol (point))
|
|
|
516 start)
|
|
|
517 (while (< (point) end)
|
|
|
518 (setq eol (save-excursion (end-of-line) (point)))
|
|
|
519
|
|
|
520 (if dired-do-interactive-permissions
|
|
|
521 (dired-make-permissions-interactive (point)))
|
|
|
522
|
|
|
523 (if (dired-manual-move-to-filename nil bol eol)
|
|
|
524 (progn
|
|
|
525 (setq start (point))
|
|
|
526 (dired-manual-move-to-end-of-filename nil bol eol)
|
|
|
527 (dired-set-text-properties
|
|
|
528 start
|
|
|
529 (point)
|
|
|
530 (save-excursion
|
|
|
531 (beginning-of-line)
|
|
|
532 (cond
|
|
|
533 ((null dired-do-highlighting) nil)
|
|
|
534 ((looking-at dired-re-raw-dir) 'dired-face-directory)
|
|
|
535 ((looking-at dired-re-raw-sym) 'dired-face-symlink)
|
|
|
536 ((or (looking-at dired-re-raw-setuid)
|
|
|
537 (looking-at dired-re-raw-setgid)) 'dired-face-setuid)
|
|
|
538 ((looking-at dired-re-raw-exe) 'dired-face-executable)
|
|
|
539 ((looking-at dired-re-raw-socket) 'dired-face-socket)
|
|
|
540 ((save-excursion
|
|
|
541 (goto-char start)
|
|
|
542 (re-search-forward dired-re-raw-boring eol t))
|
|
|
543 'dired-face-boring))))))
|
|
|
544
|
|
|
545 (setq bol (1+ eol))
|
|
|
546 (goto-char bol)))))
|
|
|
547
|
|
|
548 (defun dired-remove-text-properties (start end)
|
|
|
549 ;; Removes text properties. Called in popup buffers.
|
|
|
550 (map-extents
|
|
|
551 (function
|
|
|
552 (lambda (extent maparg)
|
|
|
553 (if (extent-property extent 'dired-file-name)
|
|
|
554 (delete-extent extent))
|
|
|
555 nil))
|
|
|
556 nil start end))
|
|
|
557
|
|
|
558 (defun dired-highlight-filename-mark (extent)
|
|
|
559 (let ((mark
|
|
|
560 (save-excursion
|
|
|
561 (skip-chars-backward "^\n\r")
|
|
|
562 (following-char)))
|
|
|
563 (face (extent-face extent)))
|
|
|
564 (if (char-equal mark ?\ )
|
|
|
565 (if (consp face)
|
|
|
566 (set-extent-face extent (cadr face)))
|
|
|
567 (let ((new-face
|
|
|
568 (cond
|
|
|
569 ((char-equal dired-default-marker mark)
|
|
|
570 'dired-face-marked)
|
|
|
571 ((char-equal dired-del-marker mark)
|
|
|
572 'dired-face-deleted)
|
|
|
573 (t 'default))))
|
|
|
574 (set-extent-face
|
|
|
575 extent
|
|
|
576 (if (consp face)
|
|
|
577 (list new-face (cadr face))
|
|
|
578 (list new-face face)))))))
|
|
|
579
|
|
|
580 (defun dired-move-to-filename (&optional raise-error bol eol)
|
|
|
581 (or bol (setq bol (save-excursion
|
|
|
582 (skip-chars-backward "^\n\r")
|
|
|
583 (point))))
|
|
|
584 (or eol (setq eol (save-excursion
|
|
|
585 (skip-chars-forward "^\n\r")
|
|
|
586 (point))))
|
|
|
587 (goto-char bol)
|
|
|
588 (let ((extent
|
|
|
589 (map-extents
|
|
|
590 (function
|
|
|
591 (lambda (extent maparg)
|
|
|
592 (if (extent-property extent 'dired-file-name)
|
|
|
593 extent
|
|
|
594 nil)))
|
|
|
595 nil bol eol)))
|
|
|
596 (if extent
|
|
|
597 (progn
|
|
|
598 (if dired-do-highlighting
|
|
|
599 (dired-highlight-filename-mark extent))
|
|
|
600 (goto-char (extent-start-position extent)))
|
|
|
601 (if raise-error
|
|
|
602 (error "No file on this line")
|
|
|
603 nil))))
|
|
|
604
|
|
|
605
|
|
|
606 (defun dired-move-to-end-of-filename (&optional no-error bol eol)
|
|
|
607 ;; Assumes point is at beginning of filename,
|
|
|
608 ;; thus the rwx bit re-search-backward below will succeed in *this*
|
|
|
609 ;; line if at all. So, it should be called only after
|
|
|
610 ;; (dired-move-to-filename t).
|
|
|
611 ;; On failure, signals an error (with non-nil NO-ERROR just returns nil).
|
|
|
612 (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point))))
|
|
|
613 (and
|
|
|
614 (null no-error)
|
|
|
615 selective-display
|
|
|
616 (or bol (setq bol (save-excursion (skip-chars-backward "^\r\n") (point))))
|
|
|
617 (eq (char-after (1- bol)) ?\r)
|
|
|
618 (cond
|
|
|
619 ((dired-subdir-hidden-p (dired-current-directory))
|
|
|
620 (error
|
|
|
621 (substitute-command-keys
|
|
|
622 "File line is hidden. Type \\[dired-hide-subdir] to unhide.")))
|
|
|
623 ((error
|
|
|
624 (substitute-command-keys
|
|
|
625 "File line is omitted. Type \\[dired-omit-toggle] to un-omit.")))))
|
|
|
626 (let ((filename-extent (map-extents
|
|
|
627 (function
|
|
|
628 (lambda (e p) (and (extent-property e p) e)))
|
|
|
629 (current-buffer) bol eol 'dired-file-name)))
|
|
|
630 (if filename-extent
|
|
|
631 (goto-char (extent-end-position filename-extent))
|
|
|
632 (and (null no-error) (error "No file on this line")))))
|
|
|
633
|
|
|
634 ;;; Interactive chmod
|
|
|
635 ;;; (based on ideas from Russell Ritchie's dired-chmod.el)
|
|
|
636
|
|
|
637 (defun dired-do-interactive-chmod (new-attribute)
|
|
|
638 (let* ((file (dired-get-filename))
|
|
|
639 (operation (concat "chmod " new-attribute " " file))
|
|
|
640 (failure (apply (function dired-check-process)
|
|
|
641 operation
|
|
|
642 "chmod" new-attribute (list file))))
|
|
|
643 (dired-do-redisplay)
|
|
|
644 (if failure
|
|
|
645 (dired-log-summary (buffer-name (current-buffer))
|
|
|
646 (format "%s: error" operation) nil))))
|
|
|
647
|
|
|
648 (defun dired-chmod-popup-menu (event menu)
|
|
|
649 (save-excursion
|
|
|
650 (set-buffer (window-buffer (event-window event)))
|
|
|
651 (save-excursion
|
|
|
652 (goto-char (event-point event))
|
|
|
653 (popup-menu menu)
|
|
|
654 ;; this looks like a kludge to me ...
|
|
|
655 (while (popup-up-p)
|
|
|
656 (dispatch-event (next-event))))))
|
|
|
657
|
|
|
658 ;; This is probably overdoing it.
|
|
|
659 ;; Someone give me lexical scoping here ...
|
|
|
660
|
|
|
661 (defun dired-setup-chmod-keymap (domain id keys)
|
|
|
662 (let* ((names
|
|
|
663 (mapcar
|
|
|
664 (function
|
|
|
665 (lambda (key)
|
|
|
666 (let ((name (intern (concat "dired-"
|
|
|
667 (list domain ?- key)))))
|
|
|
668 (eval
|
|
|
669 `(defun ,name ()
|
|
|
670 (interactive)
|
|
|
671 (dired-do-interactive-chmod ,(concat (list domain ?+ key)))))
|
|
|
672 name)))
|
|
|
673 keys))
|
|
|
674 (prefix (concat "dired-" (list domain) "-" (list id)))
|
|
|
675 (remove-name (intern (concat prefix "-remove")))
|
|
|
676 (toggle-name (intern (concat prefix "-toggle")))
|
|
|
677 (mouse-toggle-name (intern (concat prefix "-mouse-toggle")))
|
|
|
678 (mouse-menu-name (intern (concat prefix "-menu"))))
|
|
|
679
|
|
|
680 (eval
|
|
|
681 `(defun ,remove-name ()
|
|
|
682 (interactive)
|
|
|
683 (cond ,@(mapcar (function
|
|
|
684 (lambda (key)
|
|
|
685 `((looking-at ,(regexp-quote (char-to-string key)))
|
|
|
686 (dired-do-interactive-chmod
|
|
|
687 ,(concat (list domain ?- key))))))
|
|
|
688 keys))))
|
|
|
689
|
|
|
690 (eval
|
|
|
691 `(defun ,toggle-name ()
|
|
|
692 (interactive)
|
|
|
693 (cond ((looking-at "-") (dired-do-interactive-chmod
|
|
|
694 ,(concat (list domain ?+ (car keys)))))
|
|
|
695 ,@(let ((l keys)
|
|
|
696 (c '()))
|
|
|
697 (while l
|
|
|
698 (setq c
|
|
|
699 (cons
|
|
|
700 `((looking-at (regexp-quote (char-to-string ,(car l))))
|
|
|
701 (dired-do-interactive-chmod
|
|
|
702 ,(if (null (cdr l))
|
|
|
703 (concat (list domain ?- (car l)))
|
|
|
704 (concat (list domain ?+ (cadr l))))))
|
|
|
705 c))
|
|
|
706 (setq l (cdr l)))
|
|
|
707 (reverse c)))))
|
|
|
708
|
|
|
709 (eval
|
|
|
710 `(defun ,mouse-toggle-name (event)
|
|
|
711 (interactive "e")
|
|
|
712 (save-excursion
|
|
|
713 (set-buffer (window-buffer (event-window event)))
|
|
|
714 (save-excursion
|
|
|
715 (goto-char (event-point event))
|
|
|
716 (,toggle-name)))))
|
|
|
717
|
|
|
718 (let ((menu '())
|
|
|
719 (loop-keys keys)
|
|
|
720 (loop-names names))
|
|
|
721 (while loop-keys
|
|
|
722 (setq menu
|
|
|
723 (cons (vector (concat (list ?+ (car loop-keys)))
|
|
|
724 (car loop-names)
|
|
|
725 t)
|
|
|
726 menu))
|
|
|
727 (setq loop-keys (cdr loop-keys)
|
|
|
728 loop-names (cdr loop-names)))
|
|
|
729 (setq menu (append menu (list (vector "Toggle" toggle-name t)
|
|
|
730 (vector "Clear" remove-name t))))
|
|
|
731 (setq menu (cons (char-to-string domain) menu))
|
|
|
732
|
|
|
733 (eval
|
|
|
734 `(defun ,mouse-menu-name (event)
|
|
|
735 (interactive "e")
|
|
|
736 (dired-chmod-popup-menu event ',menu))))
|
|
|
737
|
|
|
738 (let ((keymap (make-sparse-keymap)))
|
|
|
739 (let ((loop-keys (cons ?. (cons ?- keys)))
|
|
|
740 (loop-names (cons toggle-name (cons remove-name names))))
|
|
|
741 (while loop-keys
|
|
|
742 (define-key keymap (car loop-keys) (car loop-names))
|
|
|
743 (setq loop-keys (cdr loop-keys)
|
|
|
744 loop-names (cdr loop-names))))
|
|
|
745
|
|
|
746 (define-key keymap 'button2 mouse-toggle-name)
|
|
|
747 (define-key keymap 'button3 mouse-menu-name)
|
|
|
748 keymap)))
|
|
|
749
|
|
|
750 (defvar dired-u-r-keymap nil "internal keymap for dired")
|
|
|
751 (defvar dired-u-w-keymap nil "internal keymap for dired")
|
|
|
752 (defvar dired-u-x-keymap nil "internal keymap for dired")
|
|
|
753 (defvar dired-g-r-keymap nil "internal keymap for dired")
|
|
|
754 (defvar dired-g-w-keymap nil "internal keymap for dired")
|
|
|
755 (defvar dired-g-x-keymap nil "internal keymap for dired")
|
|
|
756 (defvar dired-o-r-keymap nil "internal keymap for dired")
|
|
|
757 (defvar dired-o-w-keymap nil "internal keymap for dired")
|
|
|
758 (defvar dired-o-x-keymap nil "internal keymap for dired")
|
|
|
759
|
|
|
760
|
|
|
761 (defun dired-setup-chmod-keymaps ()
|
|
|
762 (setq
|
|
|
763 dired-u-r-keymap (dired-setup-chmod-keymap ?u ?r '(?r))
|
|
|
764 dired-u-w-keymap (dired-setup-chmod-keymap ?u ?w '(?w))
|
|
|
765 dired-u-x-keymap (dired-setup-chmod-keymap ?u ?x '(?s ?S ?x))
|
|
|
766 dired-g-r-keymap (dired-setup-chmod-keymap ?g ?r '(?r))
|
|
|
767 dired-g-w-keymap (dired-setup-chmod-keymap ?g ?w '(?w))
|
|
|
768 dired-g-x-keymap (dired-setup-chmod-keymap ?g ?x '(?s ?x))
|
|
|
769 dired-o-r-keymap (dired-setup-chmod-keymap ?o ?r '(?r))
|
|
|
770 dired-o-w-keymap (dired-setup-chmod-keymap ?o ?w '(?w))
|
|
|
771 dired-o-x-keymap (dired-setup-chmod-keymap ?o ?x '(?s ?t ?x))))
|
|
|
772
|
|
|
773 (defun dired-make-permissions-interactive (beg)
|
|
|
774 (save-excursion
|
|
|
775 (goto-char beg)
|
|
|
776 (buffer-substring (point) (save-excursion (end-of-line) (point)))
|
|
|
777 (if (and (re-search-forward dired-re-pre-permissions
|
|
|
778 (save-excursion (end-of-line) (point))
|
|
|
779 t)
|
|
|
780 (looking-at dired-re-permissions))
|
|
|
781 (let ((p (point)))
|
|
|
782 (dired-activate-permissions (make-extent p (+ 1 p)) dired-u-r-keymap)
|
|
|
783 (dired-activate-permissions (make-extent (+ 1 p) (+ 2 p)) dired-u-w-keymap)
|
|
|
784 (dired-activate-permissions (make-extent (+ 2 p) (+ 3 p)) dired-u-x-keymap)
|
|
|
785 (dired-activate-permissions (make-extent (+ 3 p) (+ 4 p)) dired-g-r-keymap)
|
|
|
786 (dired-activate-permissions (make-extent (+ 4 p) (+ 5 p)) dired-g-w-keymap)
|
|
|
787 (dired-activate-permissions (make-extent (+ 5 p) (+ 6 p)) dired-g-x-keymap)
|
|
|
788 (dired-activate-permissions (make-extent (+ 6 p) (+ 7 p)) dired-o-r-keymap)
|
|
|
789 (dired-activate-permissions (make-extent (+ 7 p) (+ 8 p)) dired-o-w-keymap)
|
|
|
790 (dired-activate-permissions (make-extent (+ 8 p) (+ 9 p)) dired-o-x-keymap)))))
|
|
|
791
|
|
|
792 (defun dired-activate-permissions (extent keymap)
|
|
|
793 (set-extent-face extent 'dired-face-permissions)
|
|
|
794 (set-extent-property extent 'keymap keymap)
|
|
|
795 (set-extent-property extent 'highlight t)
|
|
|
796 (set-extent-property
|
|
|
797 extent 'help-echo
|
|
|
798 "button2 toggles, button3 changes otherwise."))
|
|
|
799
|
|
|
800 (dired-setup-chmod-keymaps)
|
|
|
801
|
|
|
802 ;;; end of dired-xemacs.el
|
