Mercurial > hg > xemacs-beta

comparison lisp/efs/dired-xemacs.el @ 24:4103f0995bd7 r19-15b95

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b95
author cvs
date Mon, 13 Aug 2007 08:51:03 +0200
parents 8fc7fe29b841
children 7e54bd776075
comparison
equal deleted inserted replaced
23:0edd3412f124 24:4103f0995bd7
8 ;; 8 ;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10 10
11 (provide 'dired-xemacs) 11 (provide 'dired-xemacs)
12 (require 'dired) 12 (require 'dired)
13 (require 'dired-faces)
13 14
14 (require 'backquote) 15 (require 'backquote)
15 16
16 ;;; Variables 17
18 ;;; Variables not meant for user editing
17 19
18 ;; kludge 20 ;; kludge
19 (defun dired-demarkify-regexp (re) 21 (defun dired-demarkify-regexp (re)
20 (if (string-equal (substring re 0 (length dired-re-maybe-mark)) 22 (if (string-equal (substring re 0 (length dired-re-maybe-mark))
21 dired-re-maybe-mark) 23 dired-re-maybe-mark)
22 (concat "^" (substring re 24 (concat "^" (substring re
23 (length dired-re-maybe-mark) 25 (length dired-re-maybe-mark)
24 (length re))) 26 (length re)))
25 re)) 27 re))
26 28
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)) 29 (defvar dired-re-raw-dir (dired-demarkify-regexp dired-re-dir))
34 (defvar dired-re-raw-sym (dired-demarkify-regexp dired-re-sym)) 30 (defvar dired-re-raw-sym (dired-demarkify-regexp dired-re-sym))
35 (defvar dired-re-raw-exe (dired-demarkify-regexp dired-re-exe)) 31 (defvar dired-re-raw-exe (dired-demarkify-regexp dired-re-exe))
36 32
37 (defvar dired-re-raw-boring (dired-omit-regexp) 33 (defvar dired-re-raw-boring (dired-omit-regexp)
44 "-[-r][-w][Ss][-r][-w][sx][-r][-w][xst]") 40 "-[-r][-w][Ss][-r][-w][sx][-r][-w][xst]")
45 "setuid plain file (even if not executable)") 41 "setuid plain file (even if not executable)")
46 42
47 (defvar dired-re-raw-setgid 43 (defvar dired-re-raw-setgid
48 (concat "^" dired-re-inode-size 44 (concat "^" dired-re-inode-size
49 "-[-r][-w][-x][-r][-w][Ss][-r][-w][xst]") 45 "-[-r][-w][-x][-r][-w][sS][-r][-w][xst]")
50 "setgid plain file (even if not executable)") 46 "setgid plain file (even if not executable)")
51 47
52 (defvar dired-re-pre-permissions "^.? ?[0-9 ]*[-d]" 48 (defvar dired-re-pre-permissions "^.? ?[0-9 ]*[-d]"
53 "Regexp matching the preamble to file permissions part of a dired line. 49 "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).") 50 This shouldn't match socket or symbolic link lines (which aren't editable).")
55 51
56 (defvar dired-re-permissions "[-r][-w][-Ssx][-r][-w][-sx][-r][-w][-xst]" 52 (defvar dired-re-permissions "[-r][-w][-Ssx][-r][-w][-Ssx][-r][-w][-xst]"
57 "Regexp matching the file permissions part of a dired line.") 53 "Regexp matching the file permissions part of a dired line.")
58 54
59 ;;; Setup 55 ;;; Setup
60 56
61 (setq dired-modeline-tracking-cmds '(mouse-track)) 57 (setq dired-modeline-tracking-cmds '(mouse-track))
62 58
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 59
134 ;;; Menus 60 ;;; Menus
135 61
136 (defvar dired-subdir-menu nil "The Subdir menu for dired") 62 (defvar dired-subdir-menu nil "The Subdir menu for dired")
137 (defvar dired-mark-menu nil "The Mark menu for dired") 63 (defvar dired-mark-menu nil "The Mark menu for dired")
567 (let ((new-face 493 (let ((new-face
568 (cond 494 (cond
569 ((char-equal dired-default-marker mark) 495 ((char-equal dired-default-marker mark)
570 'dired-face-marked) 496 'dired-face-marked)
571 ((char-equal dired-del-marker mark) 497 ((char-equal dired-del-marker mark)
572 'dired-face-deleted) 498 'dired-face-flagged)
573 (t 'default)))) 499 (t 'default))))
574 (set-extent-face 500 (set-extent-face
575 extent 501 extent
576 (if (consp face) 502 (if (consp face)
577 (list new-face (cadr face)) 503 (list new-face (cadr face))
656 (dispatch-event (next-event)))))) 582 (dispatch-event (next-event))))))
657 583
658 ;; This is probably overdoing it. 584 ;; This is probably overdoing it.
659 ;; Someone give me lexical scoping here ... 585 ;; Someone give me lexical scoping here ...
660 586
661 (defun dired-setup-chmod-keymap (domain id keys) 587 (defun dired-setup-chmod-keymap (domain id keys &optional toggle-keys)
662 (let* ((names 588 (let* ((names
663 (mapcar 589 (mapcar
664 (function 590 (function
665 (lambda (key) 591 (lambda (key)
666 (let ((name (intern (concat "dired-" 592 (let ((name (intern (concat "dired-"
690 (eval 616 (eval
691 `(defun ,toggle-name () 617 `(defun ,toggle-name ()
692 (interactive) 618 (interactive)
693 (cond ((looking-at "-") (dired-do-interactive-chmod 619 (cond ((looking-at "-") (dired-do-interactive-chmod
694 ,(concat (list domain ?+ (car keys))))) 620 ,(concat (list domain ?+ (car keys)))))
695 ,@(let ((l keys) 621 ,@(let ((l (or toggle-keys keys))
696 (c '())) 622 (c '()))
697 (while l 623 (while l
698 (setq c 624 (setq c
699 (cons 625 (cons
700 `((looking-at (regexp-quote (char-to-string ,(car l)))) 626 `((looking-at (regexp-quote (char-to-string ,(car l))))
702 ,(if (null (cdr l)) 628 ,(if (null (cdr l))
703 (concat (list domain ?- (car l))) 629 (concat (list domain ?- (car l)))
704 (concat (list domain ?+ (cadr l)))))) 630 (concat (list domain ?+ (cadr l))))))
705 c)) 631 c))
706 (setq l (cdr l))) 632 (setq l (cdr l)))
707 (reverse c))))) 633 (reverse c))
634 (t (dired-do-interactive-chmod
635 ,(concat (list domain ?+ (car keys))))))))
708 636
709 (eval 637 (eval
710 `(defun ,mouse-toggle-name (event) 638 `(defun ,mouse-toggle-name (event)
711 (interactive "e") 639 (interactive "e")
712 (save-excursion 640 (save-excursion
760 688
761 (defun dired-setup-chmod-keymaps () 689 (defun dired-setup-chmod-keymaps ()
762 (setq 690 (setq
763 dired-u-r-keymap (dired-setup-chmod-keymap ?u ?r '(?r)) 691 dired-u-r-keymap (dired-setup-chmod-keymap ?u ?r '(?r))
764 dired-u-w-keymap (dired-setup-chmod-keymap ?u ?w '(?w)) 692 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)) 693 dired-u-x-keymap (dired-setup-chmod-keymap ?u ?x '(?x ?s ?S) '(?x))
766 dired-g-r-keymap (dired-setup-chmod-keymap ?g ?r '(?r)) 694 dired-g-r-keymap (dired-setup-chmod-keymap ?g ?r '(?r))
767 dired-g-w-keymap (dired-setup-chmod-keymap ?g ?w '(?w)) 695 dired-g-w-keymap (dired-setup-chmod-keymap ?g ?w '(?w))
768 dired-g-x-keymap (dired-setup-chmod-keymap ?g ?x '(?s ?x)) 696 dired-g-x-keymap (dired-setup-chmod-keymap ?g ?x '(?x ?s ?S) '(?x))
769 dired-o-r-keymap (dired-setup-chmod-keymap ?o ?r '(?r)) 697 dired-o-r-keymap (dired-setup-chmod-keymap ?o ?r '(?r))
770 dired-o-w-keymap (dired-setup-chmod-keymap ?o ?w '(?w)) 698 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)))) 699 dired-o-x-keymap (dired-setup-chmod-keymap ?o ?x '(?x ?s ?t) '(?x))))
772 700
773 (defun dired-make-permissions-interactive (beg) 701 (defun dired-make-permissions-interactive (beg)
774 (save-excursion 702 (save-excursion
775 (goto-char beg) 703 (goto-char beg)
776 (buffer-substring (point) (save-excursion (end-of-line) (point))) 704 (buffer-substring (point) (save-excursion (end-of-line) (point)))