cgit.sxemacs.org Git - packages/blob - xemacs-packages/dired/dired-xemacs.el

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; File:          dired-xemacs.el
   4 ;; Dired Version: 7.17
   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 (require 'dired-faces)
  14
  15 (require 'backquote)
  16
  17
  18 ;;; Variables not meant for user editing
  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
  45           "-[-r][-w][-x][-r][-w][sS][-r][-w][xst]")
  46   "setgid plain file (even if not executable)")
  47
  48 (defvar dired-re-pre-permissions "^[^-d]? ?[0-9         ]*[-d]"
  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
  52 (defvar dired-re-permissions "[-r][-w][-Ssx][-r][-w][-Ssx][-r][-w][-xstT]"
  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-display-file 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-chmod t]
 166      ["Change Owner..." dired-do-chown t]
 167      ["Change Group..." dired-do-chgrp t]
 168      ["Load" dired-do-load t]
 169      ["Byte-compile" dired-do-byte-compile t]
 170      ["Hardlink to..." dired-do-hardlink t]
 171      ["Symlink to..." dired-do-symlink t]
 172      ["Shell Command..." dired-do-shell-command t]
 173      ["Background Shell Command..." dired-do-background-shell-command t]
 174      ["Delete Marked Files" dired-do-delete t]
 175      ["Visit file menu >" dired-visit-popup-menu-internal t]
 176      ["Operate on file menu >" dired-do-popup-menu-internal t]))
 177
 178   (setq
 179    dired-regexp-menu
 180    (list
 181     ["Mark..." dired-mark-files-regexp t]
 182     ["Mark Files with Extension..." dired-mark-extension t]
 183     ["Flag..." dired-flag-files-regexp t]
 184     ["Flag Files with Extension..." dired-flag-extension t]
 185     ["Downcase" dired-downcase t]
 186     ["Upcase" dired-upcase t]
 187     ["Copy..." dired-do-copy-regexp t]
 188     ["Rename..." dired-do-rename-regexp t]
 189     ["Hardlink..." dired-do-hardlink-regexp t]
 190     ["Symlink..." dired-do-symlink-regexp t]
 191     ["Relative Symlink..." dired-do-relsymlink-regexp t]
 192     "---"
 193     ["Add Omit Regex..." dired-add-omit-regexp t]
 194     (vector "Remove Omit Regex..."
 195             '(let ((current-prefix-arg 1))
 196                (call-interactively 'dired-add-omit-regexp))
 197             ':keys (dired-key-description 'dired-add-omit-regexp 1))
 198     (vector "Add Omit Extension..."
 199             '(let ((current-prefix-arg '(4)))
 200                (call-interactively 'dired-add-omit-regexp))
 201             ':keys (dired-key-description 'dired-add-omit-regexp 'universal-argument))
 202     (vector "Remove Omit Extension..."
 203             '(let ((current-prefix-arg '(16)))
 204                (call-interactively 'dired-add-omit-regexp))
 205             ':keys (dired-key-description 'dired-add-omit-regexp
 206                                           'universal-argument 'universal-argument))
 207     (vector "Show Omit Regex"
 208             '(let ((current-prefix-arg 0))
 209                (call-interactively 'dired-add-omit-regexp))
 210             ':keys (dired-key-description 'dired-add-omit-regexp 0))))
 211
 212   (setq
 213    dired-look-menu
 214    '(["Grep for..." dired-do-grep t]
 215      ["Tags Search for..." dired-do-tags-search t]
 216      ["Tags Query Replace..." dired-do-tags-query-replace t]
 217      "---"
 218      ["Diff File..." dired-diff t]
 219      ["Diff with Backup" dired-backup-diff t]
 220      ["Merge Files..." dired-emerge t]
 221      ["Merge Files Having Common Ancestor..." dired-emerge-with-ancestor t]
 222      ["Ediff Files..." dired-ediff t]
 223      ["Patch File" dired-epatch t]))
 224
 225   (setq
 226    dired-sort-menu
 227    (list
 228     ["Toggle Current Subdir by Name/Date" dired-sort-toggle-or-edit t]
 229     (vector "Show Current Switches"
 230             '(dired-sort-toggle-or-edit 0)
 231             ':keys (dired-key-description 'dired-sort-toggle-or-edit 0))
 232     (vector "Edit Switches for Current Subdir..."
 233             '(dired-sort-toggle-or-edit 1)
 234             ':keys (dired-key-description 'dired-sort-toggle-or-edit 1))
 235     (vector "Edit Default Switches for Inserted Subdirs..."
 236             '(dired-sort-toggle-or-edit 2)
 237             ':keys (dired-key-description 'dired-sort-toggle-or-edit 2))
 238     (vector "Sort Entire Buffer by Date"
 239             '(dired-sort-toggle-or-edit 'date)
 240             ':keys (dired-key-description 'dired-sort-toggle-or-edit
 241                                           'universal-argument))
 242     (vector "Sort Entire Buffer by Name"
 243             '(dired-sort-toggle-or-edit 'name)
 244             ':keys (dired-key-description 'dired-sort-toggle-or-edit
 245                                           'universal-argument))
 246     (vector "Edit Switches for Entire Buffer..."
 247             '(dired-sort-toggle-or-edit '(16))
 248             ':keys (dired-key-description 'dired-sort-toggle-or-edit
 249                                           'universal-argument))
 250     "---"
 251     ["Hide All Subdirs" dired-hide-all t]
 252     ["Hide Subdir" dired-hide-subdir t]
 253     ["Toggle Omit" dired-omit-toggle t]
 254     ["Kill Marked Lines" dired-do-kill-file-lines t]
 255     (vector "Redisplay Killed Lines"
 256             '(dired-do-kill-file-lines 0)
 257             ':keys (dired-key-description 'dired-do-kill-file-lines "0"))))
 258   (setq
 259    dired-help-menu
 260    (list
 261     ["Dired Summary Help" dired-summary t]
 262     ["Describe Dired" dired-describe-mode t]
 263     (vector "Dired Info Manual"
 264             '(dired-describe-mode t)
 265             ':keys (dired-key-description 'dired-describe-mode
 266                                           'universal-argument))
 267     ["Dired Command Apropos" dired-apropos t]
 268     (vector "Dired Variable Apropos"
 269             '(let ((current-prefix-arg t))
 270                (call-interactively 'dired-apropos))
 271             ':keys (dired-key-description 'dired-apropos 'universal-argument))
 272     ["Report Dired Bug" dired-report-bug t])))
 273
 274 (defun dired-install-menubar ()
 275   "Installs the Dired menu at the menubar."
 276   (if (null dired-help-menu)
 277       (dired-setup-menus))
 278   (if (and (featurep 'menubar) current-menubar)
 279       (progn
 280         (let ((buffer-menubar (copy-sequence current-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         (unless
 290             (car (find-menu-item current-menubar '("Help" "Dired")))
 291           (add-menu-button '("Help") "--:shadowEtchedIn")
 292           (add-submenu '("Help") (cons "Dired" dired-help-menu))))))
 293
 294 (add-hook 'dired-mode-hook 'dired-install-menubar)
 295
 296 ;;; Mouse functions
 297
 298 (defun dired-mouse-file-action (event fun)
 299   "In dired, apply function FUN to the file or directory name you click on."
 300   (save-excursion
 301     (set-buffer (window-buffer (event-window event)))
 302     (if dired-subdir-alist
 303         (save-excursion
 304           (goto-char (event-point event))
 305           (funcall fun))
 306       (error
 307        (concat "dired-subdir-alist seems to be mangled.  "
 308                (substitute-command-keys
 309                 "\\<dired-mode-map>Try dired-revert (\\[dired-revert])."))))))
 310
 311 (defun dired-mouse-find-file (event)
 312   "In dired, visit the file or directory name you click on."
 313   (interactive "e")
 314   (dired-mouse-file-action event 'dired-find-file))
 315
 316 (defun dired-mouse-display-file (event)
 317   "In dired, display the file or directory name you click on."
 318   (interactive "e")
 319   (dired-mouse-file-action event 'dired-display-file))
 320
 321 (defun dired-mouse-find-file-other-window (event)
 322   "In dired, visit the file or directory name you click on in another window."
 323   (interactive "e")
 324   (dired-mouse-file-action event 'dired-find-file-other-window))
 325
 326 (defun dired-mouse-find-file-other-frame (event)
 327   "In dired, visit the file or directory name you click on in another frame."
 328   (interactive "e")
 329   (dired-mouse-file-action event 'dired-find-file-other-frame))
 330
 331 (defun dired-mouse-mark (event)
 332   "In dired, mark the file name that you click on.
 333 If the file name is already marked, this unmarks it."
 334   (interactive "e")
 335   (save-excursion
 336     (set-buffer (window-buffer (event-window event)))
 337     (if dired-subdir-alist
 338         (save-excursion
 339           (goto-char (event-point event))
 340           (beginning-of-line)
 341           (if (looking-at dired-re-mark)
 342               (dired-unmark 1)
 343             (dired-mark 1)))
 344       (error
 345        (concat "dired-subdir-alist seems to be mangled.  "
 346                (substitute-command-keys
 347                 "\\<dired-mode-map>Try dired-revert (\\[dired-revert])."))))))
 348
 349 (defun dired-mouse-flag (event)
 350   "In dired, flag for deletion the file name that you click on.
 351 If the file name is already flag, this unflags it."
 352   (interactive "e")
 353   (save-excursion
 354     (set-buffer (window-buffer (event-window event)))
 355     (if dired-subdir-alist
 356         (save-excursion
 357           (goto-char (event-point event))
 358           (beginning-of-line)
 359           (if (char-equal (char-after (point)) dired-del-marker)
 360               (dired-unflag 1)
 361             (dired-flag-file-deletion 1)))
 362       (error
 363        (concat "dired-subdir-alist seems to be mangled.  "
 364                (substitute-command-keys
 365                 "\\<dired-mode-map>Try dired-revert (\\[dired-revert])."))))))
 366
 367 (defun dired-mouse-get-target (event)
 368   "In dired, put a copy of the selected directory in the active minibuffer."
 369   (interactive "e")
 370   (let ((obuff (current-buffer))
 371         mb)
 372     (set-buffer (window-buffer (event-window event)))
 373     (if (and dired-subdir-alist (setq mb (dired-get-active-minibuffer-window)))
 374         (let (dir)
 375           (goto-char (event-point event))
 376           (setq dir (dired-current-directory))
 377           (select-window mb)
 378           (set-buffer (window-buffer mb))
 379           (erase-buffer)
 380           (insert dir))
 381       (set-buffer obuff)
 382       (if mb
 383           (error "No directory specified")
 384         (error "No active minibuffer")))))
 385
 386 (defun dired-visit-popup-menu (event)
 387   "Popup a menu to visit the moused file."
 388   (interactive "e")
 389   (save-excursion
 390     (set-buffer (window-buffer (event-window event)))
 391     (save-excursion
 392       (goto-char (event-point event))
 393       (dired-visit-popup-menu-internal event))))
 394
 395 (defun dired-visit-popup-menu-internal (event)
 396   (interactive "e")
 397   (let ((fn (dired-get-filename 'no-dir)))
 398     (popup-menu
 399      (cons (concat "Visit " fn " with") dired-visit-popup-menu))
 400     ;; this looks like a kludge to me ...
 401     (while (popup-up-p)
 402       (dispatch-event (next-event)))))
 403
 404 (defun dired-do-popup-menu (event)
 405   "Pop up a menu to do an operation on the moused file."
 406   (interactive "e")
 407   (let ((obuff (current-buffer)))
 408     (unwind-protect
 409         (progn
 410           (set-buffer (window-buffer (event-window event)))
 411           (dired-save-excursion
 412             (goto-char (event-point event))
 413             (dired-do-popup-menu-internal event)))
 414       (set-buffer obuff))))
 415
 416 (defun dired-do-popup-menu-internal (event)
 417   (interactive "e")
 418   (let ((fn (dired-get-filename 'no-dir))
 419         (current-prefix-arg 1))
 420     (popup-menu
 421      (cons (concat "Do operation on " fn) dired-do-popup-menu))
 422     (while (popup-up-p)
 423       (dispatch-event (next-event)))))
 424
 425 (defvar dired-filename-local-map
 426   (let ((map (make-sparse-keymap)))
 427     (set-keymap-name map 'dired-filename-local-map)
 428     (define-key map [button2]           'dired-mouse-find-file)
 429     (define-key map [(shift button2)]   'dired-mouse-display-file)
 430     (define-key map [(meta button2)]    'dired-mouse-find-file-other-frame)
 431     (define-key map [button3]           'dired-visit-popup-menu)
 432     (define-key map [(control button2)] 'dired-do-popup-menu)
 433     (define-key map [(shift button1)]   'dired-mouse-mark)
 434     (define-key map [(control shift button1)] 'dired-mouse-flag)
 435     map)
 436   "Keymap used to activate actions on files in dired.")
 437
 438 ;; Make this defined everywhere in the dired buffer.
 439 (define-key dired-mode-map '(meta button3) 'dired-mouse-get-target)
 440
 441
 442 (define-key dired-mode-map [(home)] (function (lambda ()
 443                                       (interactive)
 444                                       (beginning-of-line)
 445                                       (when dired-do-interactive-permissions
 446                                         (dired-move-to-permissions ?u 1)))))
 447
 448 (define-key dired-mode-map [(end)] (function (lambda ()
 449                                      (interactive)
 450                                      (beginning-of-line)
 451                                      (dired-move-to-filename))))
 452
 453 ;;; Extent managment
 454
 455 (defun dired-maybe-filename-start (start end)
 456   "Return start of filename if indicated by 'dired-file-name extent.
 457 Presumably, this extent was inserted by `insert-directory'."
 458   (let ((extents (dired-filename-extents start end)))
 459     (and extents
 460          (extent-start-position (car extents)))))
 461
 462 (defun dired-maybe-filename-end (start end)
 463   "Return end of filename if indicated by 'dired-file-name extent.
 464 Presumably, this extent was inserted by `insert-directory'."
 465   (let ((extents (dired-filename-extents start end)))
 466     (and extents
 467          (extent-end-position (car extents)))))
 468
 469 (defun dired-filename-extents (start end)
 470   "Returns extents with DIRED-FILE-NAME property.
 471 START and END say where."
 472   (let ((extents '()))
 473     (map-extents #'(lambda (extent _)
 474                      (if (extent-property extent 'dired-file-name)
 475                          (setq extents (cons extent extents)))
 476                      nil)
 477                  nil
 478                  start end)
 479     extents))
 480
 481 (defun dired-set-extent-text-properties (extent face)
 482   (set-extent-face extent face)
 483   (set-extent-property extent 'keymap dired-filename-local-map)
 484   (set-extent-property extent 'highlight t)
 485   (set-extent-property
 486    extent 'help-echo
 487    (concat
 488     "button2 finds, button3 visits, "
 489     "C-button2 file ops, [C-]shift-button1 marks/flags.")))
 490
 491 (defun dired-set-text-properties (start end &optional face)
 492   (let ((extent
 493          (let ((extents (dired-filename-extents start end)))
 494            (if extents
 495                (car extents)
 496              (let ((extent (make-extent start end)))
 497                (set-extent-property extent 'dired-file-name t)
 498                (set-extent-property extent 'start-open t)
 499                (set-extent-property extent 'end-open t)
 500                extent)))))
 501     (dired-set-extent-text-properties extent (or face 'default))
 502     extent))
 503
 504 (defun dired-insert-set-properties (beg end)
 505   ;; Sets the extents for the file names and their properties
 506   (save-excursion
 507     (goto-char beg)
 508     (beginning-of-line)
 509     (let ((eol (save-excursion (end-of-line) (point)))
 510           (bol (point))
 511           start)
 512       (while (< (point) end)
 513         (setq eol (save-excursion (end-of-line) (point)))
 514
 515         (if dired-do-interactive-permissions
 516             (dired-make-permissions-interactive (point)))
 517
 518         (if (dired-manual-move-to-filename nil bol eol)
 519             (progn
 520               (setq start (point))
 521               (dired-manual-move-to-end-of-filename nil bol eol)
 522               (dired-set-text-properties
 523                start
 524                (point)
 525                (save-excursion
 526                  (beginning-of-line)
 527                  (cond
 528                   ((null dired-do-highlighting) nil)
 529                   ((looking-at dired-re-raw-dir) 'dired-face-directory)
 530                   ((looking-at dired-re-raw-sym) 'dired-face-symlink)
 531                   ((or (looking-at dired-re-raw-setuid)
 532                        (looking-at dired-re-raw-setgid)) 'dired-face-setuid)
 533                   ((looking-at dired-re-raw-exe) 'dired-face-executable)
 534                   ((looking-at dired-re-raw-socket) 'dired-face-socket)
 535                   ((save-excursion
 536                      (goto-char start)
 537                      (save-restriction
 538                        (narrow-to-region (point) eol)
 539                        (re-search-forward dired-re-raw-boring eol t)))
 540                    'dired-face-boring))))))
 541
 542         (setq bol (1+ eol))
 543         (goto-char bol)))))
 544
 545 (defun dired-remove-text-properties (start end)
 546   ;; Removes text properties.  Called in popup buffers.
 547   (map-extents
 548    (function
 549     (lambda (extent maparg)
 550       (delete-extent extent)
 551       nil))
 552    nil start end nil nil 'dired-file-name))
 553
 554 (defun dired-highlight-filename-mark (extent)
 555   (let ((mark
 556          (save-excursion
 557            (skip-chars-backward "^\n\r")
 558            (char-after (point))))
 559         (face (extent-face extent)))
 560     (if (char-equal mark ?\ )
 561         (if (consp face)
 562             (set-extent-face extent (cadr face)))
 563       (let ((new-face
 564              (cond
 565               ((char-equal dired-default-marker mark)
 566                'dired-face-marked)
 567               ((char-equal dired-del-marker mark)
 568                'dired-face-flagged)
 569               (t 'default))))
 570         (set-extent-face
 571          extent
 572          (if (consp face)
 573              (list new-face (cadr face))
 574            (list new-face face)))))))
 575
 576 (defun dired-move-to-filename (&optional raise-error bol eol)
 577   (or bol (setq bol (save-excursion
 578                       (skip-chars-backward "^\n\r")
 579                       (point))))
 580   (or eol (setq eol (save-excursion
 581                       (skip-chars-forward "^\n\r")
 582                       (point))))
 583   (goto-char bol)
 584   (let ((extent
 585          (map-extents
 586           (function
 587            (lambda (extent maparg)
 588              (if (extent-property extent 'dired-file-name)
 589                  extent
 590                nil)))
 591           nil bol eol)))
 592     (if extent
 593         (progn
 594           (if dired-do-highlighting
 595               (dired-highlight-filename-mark extent))
 596           (goto-char (extent-start-position extent)))
 597       (if raise-error
 598           (error "No file on this line")
 599         nil))))
 600
 601
 602 (defun dired-move-to-end-of-filename (&optional no-error bol eol)
 603   ;; Assumes point is at beginning of filename,
 604   ;; thus the rwx bit re-search-backward below will succeed in *this*
 605   ;; line if at all.  So, it should be called only after
 606   ;; (dired-move-to-filename t).
 607   ;; On failure, signals an error (with non-nil NO-ERROR just returns nil).
 608   (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point))))
 609   (and
 610    (null no-error)
 611    selective-display
 612    (or bol (setq bol (save-excursion (skip-chars-backward "^\r\n") (point))))
 613    (eq (char-after (1- bol)) ?\r)
 614    (cond
 615     ((dired-subdir-hidden-p (dired-current-directory))
 616      (error
 617       (substitute-command-keys
 618        "File line is hidden. Type \\[dired-hide-subdir] to unhide.")))
 619     ((error
 620       (substitute-command-keys
 621        "File line is omitted. Type \\[dired-omit-toggle] to un-omit.")))))
 622   (let ((filename-extent  (map-extents
 623                             (function
 624                              (lambda (e p) (and (extent-property e p) e)))
 625                             (current-buffer) bol eol 'dired-file-name)))
 626     (if filename-extent
 627         (goto-char (extent-end-position filename-extent))
 628       (and (null no-error) (error "No file on this line")))))
 629
 630 (defun dired-move-to-permissions (domain direction)
 631   (skip-chars-backward "^\r\n")
 632   (let (extent)
 633     (while (not (setq extent (map-extents (function
 634                                            (lambda (e p)
 635                                             (and
 636                                              (char-equal domain (extent-property e p))
 637                                              e)))
 638                                           (current-buffer)
 639                                           (point)
 640                                           (save-excursion
 641                                             (skip-chars-forward "^\r\n")
 642                                             (point))
 643                                           'dired-permissions)))
 644       (forward-line direction))
 645     (goto-char (extent-start-position extent))))
 646
 647 ;;; Interactive chmod
 648 ;;; (based on ideas from Russell Ritchie's dired-chmod.el)
 649
 650 (defun dired-do-interactive-chmod (new-attribute)
 651   (let* ((file (dired-get-filename))
 652          (operation (concat "chmod " new-attribute " " file))
 653          (failure (apply (function dired-check-process)
 654                          operation
 655                          "chmod" new-attribute (list file))))
 656     (dired-do-redisplay)
 657     (if failure
 658         (dired-log-summary (buffer-name (current-buffer))
 659                            (format "%s: error" operation) nil))))
 660
 661 (defun dired-chmod-popup-menu (event menu)
 662   (save-excursion
 663     (set-buffer (window-buffer (event-window event)))
 664     (save-excursion
 665       (goto-char (event-point event))
 666       (popup-menu menu)
 667       ;; this looks like a kludge to me ...
 668       (while (popup-up-p)
 669         (dispatch-event (next-event))))))
 670
 671 ;; This is probably overdoing it.
 672 ;; Someone give me lexical scoping here ...
 673
 674 (defun dired-setup-chmod-keymap (domain id keys &optional toggle-keys)
 675   (let* ((names
 676           (mapcar
 677            (function
 678             (lambda (key)
 679               (let ((name (intern (concat "dired-"
 680                                           (list domain ?-  key)))))
 681                 (eval
 682                  `(defun ,name ()
 683                     (interactive)
 684                     (dired-do-interactive-chmod ,(concat (list domain ?+ key)))
 685                     (forward-char 1)))
 686                 name)))
 687            keys))
 688          (prefix (concat "dired-" (list domain) "-" (list id)))
 689          (remove-name (intern (concat prefix "-remove")))
 690          (toggle-name (intern (concat prefix "-toggle")))
 691          (mouse-toggle-name (intern (concat prefix "-mouse-toggle")))
 692          (mouse-menu-name (intern (concat prefix "-menu"))))
 693
 694     (eval
 695      `(defun ,remove-name ()
 696         (interactive)
 697         (cond ,@(mapcar (function
 698                          (lambda (key)
 699                            `((looking-at ,(regexp-quote (char-to-string key)))
 700                              (dired-do-interactive-chmod
 701                               ,(concat (list domain ?- key))))))
 702                         keys))
 703         (forward-char 1)))
 704
 705     (eval
 706      `(defun ,toggle-name ()
 707         (interactive)
 708         (cond ((looking-at "-") (dired-do-interactive-chmod
 709                                  ,(concat (list domain ?+ (car keys)))))
 710               ,@(let ((l (or toggle-keys keys))
 711                       (c '()))
 712                   (while l
 713                     (setq c
 714                           (cons
 715                            `((looking-at (regexp-quote (char-to-string ,(car l))))
 716                              (dired-do-interactive-chmod
 717                               ,(if (null (cdr l))
 718                                    (concat (list domain ?- (car l)))
 719                                  (concat (list domain ?+ (cadr l))))))
 720                            c))
 721                     (setq l (cdr l)))
 722                   (reverse c))
 723               (t (dired-do-interactive-chmod
 724                   ,(concat (list domain ?+ (car keys))))))
 725         (forward-char 1)))
 726
 727     (eval
 728      `(defun ,mouse-toggle-name (event)
 729         (interactive "e")
 730         (save-excursion
 731           (set-buffer (window-buffer (event-window event)))
 732           (save-excursion
 733             (goto-char (event-point event))
 734             (,toggle-name)))))
 735
 736     (let ((menu '())
 737           (loop-keys keys)
 738           (loop-names names))
 739       (while loop-keys
 740         (setq menu
 741               (cons (vector (concat (list ?+ (car loop-keys)))
 742                             (car loop-names)
 743                             t)
 744                     menu))
 745         (setq loop-keys (cdr loop-keys)
 746               loop-names (cdr loop-names)))
 747       (setq menu (append menu (list (vector "Toggle" toggle-name t)
 748                                     (vector "Clear" remove-name t))))
 749       (setq menu (cons (char-to-string domain) menu))
 750
 751       (eval
 752        `(defun ,mouse-menu-name (event)
 753           (interactive "e")
 754           (dired-chmod-popup-menu event ',menu))))
 755
 756     (let ((keymap (make-sparse-keymap)))
 757       (let ((loop-keys (cons ?. (cons ?- keys)))
 758             (loop-names (cons toggle-name (cons remove-name names))))
 759         (while loop-keys
 760           (define-key keymap (car loop-keys) (car loop-names))
 761           (setq loop-keys (cdr loop-keys)
 762                 loop-names (cdr loop-names))))
 763
 764       (define-key keymap 'button2 mouse-toggle-name)
 765       (define-key keymap 'button3 mouse-menu-name)
 766       (define-key keymap [(control ?p)] (function (lambda ()
 767                                           (interactive)
 768                                           (dired-permissions-arrow-move -1))))
 769       (define-key keymap [(up)] (function (lambda ()
 770                                   (interactive)
 771                                   (dired-permissions-arrow-move -1))))
 772       (define-key keymap [(control ?n)] (function (lambda ()
 773                                           (interactive)
 774                                           (dired-permissions-arrow-move 1))))
 775       (define-key keymap [(down)] (function (lambda ()
 776                                     (interactive)
 777                                     (dired-permissions-arrow-move 1))))
 778       (set-keymap-name keymap (char-to-string domain))
 779       keymap)))
 780
 781 (defun dired-permissions-arrow-move (direction)
 782   (let ((domain (extent-property
 783                  (extent-at (point) nil 'dired-permissions)
 784                  'dired-permissions))
 785         (here (point)))
 786     (forward-line direction)
 787     ;; /etc/rcN.d is ".", "..", and the rest all symlinks.
 788     (if (catch 'found-one
 789           (while t
 790             (cond
 791               ;; Cannot modify symlink permissions.
 792               ((looking-at dired-re-sym) (forward-line direction))
 793               ((looking-at "^. [ \t0-9]*[^l][r-][w-]") (throw 'found-one t))
 794               (t (throw 'found-one nil)))))
 795         (dired-move-to-permissions domain direction)
 796       (goto-char here)
 797       (if (save-excursion
 798             (forward-line direction)
 799             (looking-at dired-re-sym))
 800           (progn
 801             (forward-line direction)
 802             (dired-move-to-filename))
 803         (dired-move-to-permissions domain direction)
 804         (when signal-error-on-buffer-boundary
 805           ;; it'll do for now...
 806           (ding nil 'buffer-bound))))))
 807
 808 (defvar dired-u-r-keymap nil "internal keymap for dired")
 809 (defvar dired-u-w-keymap nil "internal keymap for dired")
 810 (defvar dired-u-x-keymap nil "internal keymap for dired")
 811 (defvar dired-g-r-keymap nil "internal keymap for dired")
 812 (defvar dired-g-w-keymap nil "internal keymap for dired")
 813 (defvar dired-g-x-keymap nil "internal keymap for dired")
 814 (defvar dired-o-r-keymap nil "internal keymap for dired")
 815 (defvar dired-o-w-keymap nil "internal keymap for dired")
 816 (defvar dired-o-x-keymap nil "internal keymap for dired")
 817
 818
 819 (defun dired-setup-chmod-keymaps ()
 820   (setq
 821    dired-u-r-keymap (dired-setup-chmod-keymap ?u ?r '(?r))
 822    dired-u-w-keymap (dired-setup-chmod-keymap ?u ?w '(?w))
 823    dired-u-x-keymap (dired-setup-chmod-keymap ?u ?x '(?x ?s) '(?x))
 824    dired-g-r-keymap (dired-setup-chmod-keymap ?g ?r '(?r))
 825    dired-g-w-keymap (dired-setup-chmod-keymap ?g ?w '(?w))
 826    dired-g-x-keymap (dired-setup-chmod-keymap ?g ?x '(?x ?s) '(?x))
 827    dired-o-r-keymap (dired-setup-chmod-keymap ?o ?r '(?r))
 828    dired-o-w-keymap (dired-setup-chmod-keymap ?o ?w '(?w))
 829    dired-o-x-keymap (dired-setup-chmod-keymap ?o ?x '(?x ?s ?t) '(?x))))
 830
 831 (defun dired-make-permissions-interactive (beg)
 832   (save-excursion
 833     (goto-char beg)
 834     (buffer-substring (point) (save-excursion (end-of-line) (point)))
 835     (if (and (re-search-forward dired-re-pre-permissions
 836                                 (save-excursion (end-of-line) (point))
 837                                 t)
 838              (looking-at dired-re-permissions))
 839         (let ((p (point)))
 840           (dired-activate-permissions (make-extent p (+ 1 p)) dired-u-r-keymap)
 841           (dired-activate-permissions (make-extent (+ 1 p) (+ 2 p)) dired-u-w-keymap)
 842           (dired-activate-permissions (make-extent (+ 2 p) (+ 3 p)) dired-u-x-keymap)
 843           (dired-activate-permissions (make-extent (+ 3 p) (+ 4 p)) dired-g-r-keymap)
 844           (dired-activate-permissions (make-extent (+ 4 p) (+ 5 p)) dired-g-w-keymap)
 845           (dired-activate-permissions (make-extent (+ 5 p) (+ 6 p)) dired-g-x-keymap)
 846           (dired-activate-permissions (make-extent (+ 6 p) (+ 7 p)) dired-o-r-keymap)
 847           (dired-activate-permissions (make-extent (+ 7 p) (+ 8 p)) dired-o-w-keymap)
 848           (dired-activate-permissions (make-extent (+ 8 p) (+ 9 p)) dired-o-x-keymap)))))
 849
 850 (defun dired-activate-permissions (extent keymap)
 851   (set-extent-face extent 'dired-face-permissions)
 852   (set-extent-property extent 'keymap keymap)
 853   (set-extent-property extent 'highlight t)
 854   (set-extent-property extent 'dired-permissions (string-to-char (keymap-name keymap)))
 855   (set-extent-property extent 'help-echo
 856    "button2 toggles, button3 changes otherwise."))
 857
 858 (dired-setup-chmod-keymaps)
 859
 860
 861 ;;; Popup header supports
 862 (defun dired-insert-set-headerline-properties ()
 863   ;; Sets the extents for the current directory header line
 864   (let ((position (dired-get-headerline)))
 865     (dired-insert-set-headerline-properties-internal (car position)
 866                                                      (cdr position))))
 867
 868 (defun dired-get-headerline ()
 869   ;; Get the bufffer position of the current directory header line
 870   (save-excursion
 871     (beginning-of-line)
 872     (save-match-data
 873       (re-search-forward " *\\(.*\\):$" nil t)
 874       ;; Return begin and end pair
 875       (cons (match-beginning 1) (match-end 1)))))
 876
 877 (defun dired-insert-set-headerline-properties-internal (b e)
 878   (let ((extent (make-extent b e)))
 879     (set-extent-face extent 'dired-face-header)
 880     (set-extent-property extent 'keymap dired-headerline-local-map)
 881     (set-extent-property extent 'highlight t)
 882     (set-extent-property
 883      extent 'help-echo
 884      "button2 do dired this window.")))
 885
 886 (defvar dired-headerline-local-map
 887   (let ((map (make-sparse-keymap)))
 888     (set-keymap-name map 'dired-headerline-local-map)
 889     (define-key map [button2] 'dired-headerline-dired)
 890     (define-key map [(shift button2)] 'dired-headerline-dired-other-window)
 891     (define-key map [(meta button2)] 'dired-headerline-dired-other-frame)
 892     ;;
 893     (define-key map "f" 'dired-headerline-dired-by-key)
 894     (define-key map "o" 'dired-headerline-dired-other-window-by-key)
 895     (define-key map "w" 'dired-headerline-dired-frame-window-by-key)
 896     map)
 897   "Keymap used to activate actions on the header line in dired directory.")
 898
 899 (defun dired-split-headerline (dir)
 900   ;; (dired-split-headerline "/")
 901   ;; => (list "/")
 902   ;;
 903   ;; (dired-split-headerline "/a/b/c")
 904   ;; => (list  "/" "/a" "/a/b" "/a/b/c")
 905   ;;
 906   ;; (dired-split-headerline "/masat-y@foo:/a")
 907   ;; => (list  "/"  "/masat-y@foo:/" "/masat-y@foo:/a")
 908   ;;
 909   ;; (dired-split-headerline "/masat-y@foo:/")
 910   ;; => (list  "/"  "/masat-y@foo:/")
 911
 912   (let ((dirlist (cons dir nil))
 913         (lastdir dir))                  ; To check double entry item
 914     (setq dir (directory-file-name
 915                (file-name-directory  dir)))
 916     (while (not (string= dir lastdir))
 917       (setq dirlist (cons dir dirlist)
 918             lastdir dir
 919             dir (directory-file-name
 920                      (file-name-directory dir))))
 921     ;; Add "/" if it is not in `dirlist'.
 922     (if (not (string= (car dirlist) "/"))
 923         (setq dirlist (cons "/" dirlist)))
 924     dirlist))
 925
 926 ;; by mouse
 927 (defun dired-headerline-dired (event)
 928   "On the header line in dired, visit the parent directory."
 929   (interactive "e")
 930   (dired-headerline-dired-internal event 'dired "Dired"))
 931
 932 (defun dired-headerline-dired-other-window (event)
 933   "On the header line in dired, visit the parent directory in another window."
 934   (interactive "e")
 935   (dired-headerline-dired-internal event
 936                                    'dired-other-window
 937                                    "Dired in Other Window"))
 938
 939 (defun dired-headerline-dired-other-frame (event)
 940   "On the header line in dired, visit the parent directory in another frame."
 941   (interactive "e")
 942   (dired-headerline-dired-internal event
 943                                    'dired-other-frame
 944                                    "Dired in Other Frame"))
 945
 946 (defun dired-headerline-dired-internal (event func title)
 947   ;;
 948   ;; Header line:  /a/b/c
 949   ;; =>
 950   ;; Popup menu: TITLE
 951   ;;             ------
 952   ;;             /a/b/c
 953   ;;             /a/b
 954   ;;             /a
 955   ;;             /
 956   ;;
 957   (interactive "e")
 958   (let (dirlist)
 959     ;;
 960     ;; Get directory list
 961     ;;
 962     (let (points basedir)
 963       (save-excursion
 964         (set-buffer (window-buffer (event-window event)))
 965         (save-excursion
 966           (goto-char (event-point event))
 967           (setq points (dired-get-headerline)
 968                 dirlist (dired-split-headerline
 969                          (buffer-substring (car points) (cdr points)))))))
 970     ;;
 971     ;; Create menu and popup it
 972     ;;
 973     (let (v items dir)
 974       (while dirlist
 975         (setq dir (car dirlist)
 976               dirlist (cdr dirlist)
 977               v (make-vector 3 0))
 978         (aset v 0 dir) (aset v 1 (list func dir)) (aset v 2 t)
 979         (setq items (cons v items)))
 980       (popup-menu (cons title items)))))
 981
 982 ;; By key
 983 (defun dired-headerline-dired-by-key (p)
 984   "On the header line in dired, visit the parent directory under ther cursor."
 985   (interactive "d")
 986   (dired-headerline-dired-by-key-internal p 'dired))
 987
 988 (defun dired-headerline-dired-other-window-by-key (p)
 989   "On the header line in dired, visit the parent directory under ther cursor on another window."
 990   (interactive "d")
 991   (dired-headerline-dired-by-key-internal p 'dired-other-window))
 992
 993 (defun dired-headerline-dired-other-frame-by-key (p)
 994   "On the header line in dired, visit the parent directory under ther cursor on another frame."
 995   (interactive "d")
 996   (dired-headerline-dired-by-key-internal p 'dired-other-frame))
 997
 998 (defun dired-headerline-dired-by-key-internal (p func)
 999   (let ((points (dired-get-headerline))
1000         dirlist
1001         basedir
1002         dir
1003         (check-remote nil))
1004     ;; A function that checks the headerline shows remote directry.
1005     (fset 'check-remote (lambda (str)
1006                           (save-match-data (string-match "/.*@.*:/" str))))
1007
1008     ;; Calculate position in headerline
1009     (setq p       (- p (car points)))
1010
1011     ;; Get directory list
1012     (setq basedir (buffer-substring (car points) (cdr points)))
1013     (setq dirlist (dired-split-headerline basedir))
1014
1015     ;; Which directory 'p' in on...
1016     (setq dir
1017           (catch 'found
1018             ;;
1019             ;; P points out Root directory?
1020             (if (= p 0)
1021                 ;; p is on "/"
1022                 (throw 'found "/")
1023               ;; p is not on "/".
1024               (setq dirlist (cdr dirlist)))
1025             ;;
1026             ;; P points out remote host name field.
1027             ;;
1028             (if (and dirlist
1029                      (apply 'check-remote (list (car dirlist))))
1030                 ;; P points out remote host field in headerline?
1031                 (if (< p (length (car dirlist)))
1032                     (throw 'found (car dirlist))
1033                   ;; P points out remote directory not remote host field.
1034                   (setq dirlist (cdr dirlist))))
1035             ;;
1036             ;; Find p  from directory list
1037             ;;
1038             (let (tmpdir)
1039               (while  dirlist
1040                 (setq tmpdir (car dirlist))
1041                 (if (<= p (length tmpdir))
1042                     (throw 'found tmpdir)
1043                   (setq dirlist (cdr dirlist))))
1044               nil)
1045             ))
1046     ;;
1047     ;; Run dired
1048     ;;
1049     (if (string= dir basedir)
1050         (revert-buffer dir)
1051       (funcall func dir))))
1052
1053 ;;; end of dired-xemacs.el