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