Mercurial > hg > xemacs-beta
comparison lisp/efs/dired-xemacs.el @ 22:8fc7fe29b841 r19-15b94
Import from CVS: tag r19-15b94
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:50:29 +0200 |
| parents | |
| children | 4103f0995bd7 4be1180a9e89 |
comparison
equal
deleted
inserted
replaced
| 21:b88636d63495 | 22:8fc7fe29b841 |
|---|---|
| 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 |