Mercurial > hg > xemacs-beta

comparison lisp/modeline.el @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents b8cc9ab3f761
children 11054d720c21
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details. 19 ;; General Public License for more details.
20 20
21 ;; You should have received a copy of the GNU General Public License 21 ;; You should have received a copy of the GNU General Public License
22 ;; along with XEmacs; see the file COPYING. If not, write to the 22 ;; along with XEmacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, 59 Temple Place - Suite 330, 23 ;; Free Software Foundation, 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA. 24 ;; Boston, MA 02111-1307, USA.
25 25
26 ;;; Synched up with: Not in FSF. 26 ;;; Synched up with: Not in FSF.
27 27
57 Click on the left half of the modeline cycles forward through the 57 Click on the left half of the modeline cycles forward through the
58 buffer list and clicking on the right half cycles backward." 58 buffer list and clicking on the right half cycles backward."
59 :type 'boolean 59 :type 'boolean
60 :group 'modeline) 60 :group 'modeline)
61 61
62 (defcustom modeline-scrolling-method nil
63 "*If non-nil, dragging the modeline with the mouse may also scroll its
64 text horizontally (vertical motion controls window resizing and horizontal
65 motion controls modeline scrolling).
66
67 With a value of t, the modeline text is scrolled in the same direction as
68 the mouse motion. With a value of 'scrollbar, the modeline is considered as
69 a scrollbar for its own text, which then moves in the opposite direction."
70 :type '(choice (const :tag "none" nil)
71 (const :tag "text" t)
72 (const :tag "scrollbar" scrollbar))
73 :set (lambda (sym val)
74 (set-default sym val)
75 (when (featurep 'x)
76 (cond ((eq val t)
77 (set-glyph-image modeline-pointer-glyph "hand2" 'global 'x))
78 ((eq val 'scrollbar)
79 (set-glyph-image modeline-pointer-glyph "fleur" 'global 'x))
80 (t
81 (set-glyph-image modeline-pointer-glyph "sb_v_double_arrow"
82 'global 'x))))
83 (when (featurep 'mswindows)
84 (cond ((eq val t)
85 (set-glyph-image modeline-pointer-glyph
86 [mswindows-resource :resource-type cursor
87 :resource-id "SizeAll"]
88 'global 'mswindows))
89 ((eq val 'scrollbar)
90 (set-glyph-image modeline-pointer-glyph
91 [mswindows-resource :resource-type cursor
92 :resource-id "Normal"]
93 'global 'mswindows))
94 (t
95 (set-glyph-image modeline-pointer-glyph
96 [mswindows-resource :resource-type cursor
97 :resource-id "SizeNS"]
98 'global 'mswindows)))))
99 :group 'modeline)
100
101 (defun mouse-drag-modeline (event) 62 (defun mouse-drag-modeline (event)
102 "Resize a window by dragging its modeline. 63 "Resize a window by dragging its modeline.
103 This command should be bound to a button-press event in modeline-map. 64 This command should be bound to a button-press event in modeline-map.
104 Holding down a mouse button and moving the mouse up and down will 65 Holding down a mouse button and moving the mouse up and down will
105 make the clicked-on window taller or shorter. 66 make the clicked-on window taller or shorter."
106
107 See also the variable `modeline-scrolling-method'."
108 (interactive "e") 67 (interactive "e")
109 (or (button-press-event-p event) 68 (or (button-press-event-p event)
110 (error "%s must be invoked by a mouse-press" this-command)) 69 (error "%s must be invoked by a mouse-press" this-command))
111 (or (event-over-modeline-p event) 70 (or (event-over-modeline-p event)
112 (error "not over a modeline")) 71 (error "not over a modeline"))
118 (let ((done nil) 77 (let ((done nil)
119 (depress-line (event-y event)) 78 (depress-line (event-y event))
120 (start-event-frame (event-frame event)) 79 (start-event-frame (event-frame event))
121 (start-event-window (event-window event)) 80 (start-event-window (event-window event))
122 (start-nwindows (count-windows t)) 81 (start-nwindows (count-windows t))
123 (hscroll-delta (face-width 'modeline)) 82 ;; (hscroll-delta (face-width 'modeline))
124 (start-hscroll (modeline-hscroll (event-window event))) 83 ;; (start-hscroll (modeline-hscroll (event-window event)))
125 (start-x-pixel (event-x-pixel event)) 84 ; (start-x-pixel (event-x-pixel event))
126 (last-timestamp 0) 85 (last-timestamp 0)
127 default-line-height 86 default-line-height
128 modeline-height 87 modeline-height
129 should-enlarge-minibuffer 88 should-enlarge-minibuffer
130 event min-height minibuffer y top bot edges wconfig growth) 89 event min-height minibuffer y top bot edges wconfig growth)
180 (setq done t) 139 (setq done t)
181 ;; Consider we have a mouse click neither X pos (modeline 140 ;; Consider we have a mouse click neither X pos (modeline
182 ;; scroll) nore Y pos (modeline drag) have changed. 141 ;; scroll) nore Y pos (modeline drag) have changed.
183 (and modeline-click-swaps-buffers 142 (and modeline-click-swaps-buffers
184 (= depress-line (event-y event)) 143 (= depress-line (event-y event))
185 (or (not modeline-scrolling-method) 144 ;; (= start-hscroll (modeline-hscroll start-event-window))
186 (= start-hscroll
187 (modeline-hscroll start-event-window)))
188 (modeline-swap-buffers event))) 145 (modeline-swap-buffers event)))
189 ((button-event-p event) 146 ((button-event-p event)
190 (setq done t)) 147 (setq done t))
191 ((not (motion-event-p event)) 148 ((not (motion-event-p event))
192 (dispatch-event event)) 149 (dispatch-event event))
194 (setq done t)) 151 (setq done t))
195 ((< (abs (- (event-timestamp event) last-timestamp)) 152 ((< (abs (- (event-timestamp event) last-timestamp))
196 drag-divider-event-lag) 153 drag-divider-event-lag)
197 nil) 154 nil)
198 (t 155 (t
199 (when modeline-scrolling-method 156 ;; (set-modeline-hscroll start-event-window
200 (let ((delta (/ (- (event-x-pixel event) start-x-pixel) 157 ;; (+ (/ (- (event-x-pixel event)
201 hscroll-delta))) 158 ;; start-x-pixel)
202 (set-modeline-hscroll start-event-window 159 ;; hscroll-delta)
203 (if (eq modeline-scrolling-method t) 160 ;; start-hscroll))
204 (- start-hscroll delta)
205 (+ start-hscroll delta)))
206 ))
207 (setq last-timestamp (event-timestamp event) 161 (setq last-timestamp (event-timestamp event)
208 y (event-y-pixel event) 162 y (event-y-pixel event)
209 edges (window-pixel-edges start-event-window) 163 edges (window-pixel-edges start-event-window)
210 top (nth 1 edges) 164 top (nth 1 edges)
211 bot (nth 3 edges)) 165 bot (nth 3 edges))
307 (define-key modeline-map 'button3 'modeline-menu) 261 (define-key modeline-map 'button3 'modeline-menu)
308 262
309 (make-face 'modeline-mousable "Face for mousable portions of the modeline.") 263 (make-face 'modeline-mousable "Face for mousable portions of the modeline.")
310 (set-face-parent 'modeline-mousable 'modeline nil '(default)) 264 (set-face-parent 'modeline-mousable 'modeline nil '(default))
311 (when (featurep 'window-system) 265 (when (featurep 'window-system)
312 (set-face-foreground 'modeline-mousable "firebrick" nil '(default color win)) 266 (set-face-foreground 'modeline-mousable
313 (set-face-font 'modeline-mousable [bold] nil '(default mono win)) 267 '(((default color x) . "firebrick")
314 (set-face-font 'modeline-mousable [bold] nil '(default grayscale win))) 268 ((default color mswindows) . "firebrick"))
269 'global))
270 (when (featurep 'x)
271 (set-face-font 'modeline-mousable [bold] nil '(default mono x))
272 (set-face-font 'modeline-mousable [bold] nil '(default grayscale x)))
315 273
316 (defmacro make-modeline-command-wrapper (command) 274 (defmacro make-modeline-command-wrapper (command)
317 `#'(lambda (event) 275 `#'(lambda (event)
318 (interactive "e") 276 (interactive "e")
319 (save-selected-window 277 (save-selected-window
343 (make-face 'modeline-mousable-minor-mode 301 (make-face 'modeline-mousable-minor-mode
344 "Face for mousable minor-mode strings in the modeline.") 302 "Face for mousable minor-mode strings in the modeline.")
345 (set-face-parent 'modeline-mousable-minor-mode 'modeline-mousable nil 303 (set-face-parent 'modeline-mousable-minor-mode 'modeline-mousable nil
346 '(default)) 304 '(default))
347 (when (featurep 'window-system) 305 (when (featurep 'window-system)
348 (set-face-foreground 'modeline-mousable-minor-mode '("green4" "forestgreen") 306 (set-face-foreground 'modeline-mousable-minor-mode
349 nil '(default color win))) 307 '(((default color x) . "green4")
308 ((default color x) . "forestgreen")
309 ((default color mswindows) . "green4")
310 ((default color mswindows) . "forestgreen"))
311 'global))
350 312
351 (defvar modeline-mousable-minor-mode-extent (make-extent nil nil) 313 (defvar modeline-mousable-minor-mode-extent (make-extent nil nil)
352 ;; alliteration at its finest. 314 ;; alliteration at its finest.
353 "Extent managing the mousable minor mode modeline strings.") 315 "Extent managing the mousable minor mode modeline strings.")
354 (set-extent-face modeline-mousable-minor-mode-extent 316 (set-extent-face modeline-mousable-minor-mode-extent
427 extent) 389 extent)
428 (cons modeline-mousable-minor-mode-extent name)) 390 (cons modeline-mousable-minor-mode-extent name))
429 name))) 391 name)))
430 (if (setq el (assq toggle minor-mode-alist)) 392 (if (setq el (assq toggle minor-mode-alist))
431 (setcdr el (list hacked-name)) 393 (setcdr el (list hacked-name))
432 (funcall add-elt 394 (funcall add-elt
433 (list toggle hacked-name) 395 (list toggle hacked-name)
434 'minor-mode-alist)))) 396 'minor-mode-alist))))
435 (when keymap 397 (when keymap
436 (if (setq el (assq toggle minor-mode-map-alist)) 398 (if (setq el (assq toggle minor-mode-map-alist))
437 (setcdr el keymap) 399 (setcdr el keymap)
544 506
545 (make-face 'modeline-buffer-id 507 (make-face 'modeline-buffer-id
546 "Face for the buffer ID string in the modeline.") 508 "Face for the buffer ID string in the modeline.")
547 (set-face-parent 'modeline-buffer-id 'modeline nil '(default)) 509 (set-face-parent 'modeline-buffer-id 'modeline nil '(default))
548 (when (featurep 'window-system) 510 (when (featurep 'window-system)
549 (set-face-foreground 'modeline-buffer-id "blue4" nil '(default color win)) 511 (set-face-foreground 'modeline-buffer-id
550 (set-face-font 'modeline-buffer-id [bold-italic] nil '(default mono win)) 512 '(((default color x) . "blue4")
551 (set-face-font 'modeline-buffer-id [bold-italic] nil '(default grayscale win))) 513 ((default color mswindows) . "blue4"))
514 'global))
515 (when (featurep 'x)
516 (set-face-font 'modeline-buffer-id [bold-italic] nil '(default mono x))
517 (set-face-font 'modeline-buffer-id [bold-italic] nil '(default grayscale x)))
552 (when (featurep 'tty) 518 (when (featurep 'tty)
553 (set-face-font 'modeline-buffer-id [bold-italic] nil '(default tty))) 519 (set-face-font 'modeline-buffer-id [bold-italic] nil '(default tty)))
554 520
555 (defvar modeline-buffer-id-extent (make-extent nil nil) 521 (defvar modeline-buffer-id-extent (make-extent nil nil)
556 "Extent covering the whole of the buffer-id string.") 522 "Extent covering the whole of the buffer-id string.")
557 (set-extent-face modeline-buffer-id-extent 'modeline-buffer-id) 523 (set-extent-face modeline-buffer-id-extent 'modeline-buffer-id)
558 524
559 (defvar modeline-buffer-id-left-extent (make-extent nil nil) 525 (defvar modeline-buffer-id-left-extent (make-extent nil nil)
560 "Extent covering the left half of the buffer-id string.") 526 "Extent covering the left half of the buffer-id string.")
561 (set-extent-keymap modeline-buffer-id-left-extent 527 (set-extent-keymap modeline-buffer-id-left-extent
562 modeline-buffer-id-left-map) 528 modeline-buffer-id-left-map)
563 (set-extent-property modeline-buffer-id-left-extent 'help-echo 529 (set-extent-property modeline-buffer-id-left-extent 'help-echo
573 (defconst modeline-buffer-identification 539 (defconst modeline-buffer-identification
574 (list (cons modeline-buffer-id-left-extent (purecopy "XEmacs%N:")) 540 (list (cons modeline-buffer-id-left-extent (purecopy "XEmacs%N:"))
575 ; this used to be "XEmacs:" 541 ; this used to be "XEmacs:"
576 (cons modeline-buffer-id-right-extent (purecopy " %17b"))) 542 (cons modeline-buffer-id-right-extent (purecopy " %17b")))
577 "Modeline control for identifying the buffer being displayed. 543 "Modeline control for identifying the buffer being displayed.
578 Its default value is 544 Its default value is \"XEmacs: %17b\" (NOT!). Major modes that edit things
579 545 other than ordinary files may change this (e.g. Info, Dired,...)")
580 (list (cons modeline-buffer-id-left-extent (purecopy \"XEmacs%N:\"))
581 (cons modeline-buffer-id-right-extent (purecopy \" %17b\")))
582
583 Major modes that edit things other than ordinary files may change this
584 (e.g. Info, Dired,...).")
585 (make-variable-buffer-local 'modeline-buffer-identification) 546 (make-variable-buffer-local 'modeline-buffer-identification)
586 547
587 ;; These are for the sake of minor mode menu. #### All of this is 548 ;; These are for the sake of minor mode menu. #### All of this is
588 ;; kind of dirty. `add-minor-mode' started out as a simple substitute 549 ;; kind of dirty. `add-minor-mode' started out as a simple substitute
589 ;; for (or (assq ...) ...) FSF stuff, but now is used for all kind of 550 ;; for (or (assq ...) ...) FSF stuff, but now is used for all kind of
632 (cons modeline-modified-extent 'modeline-modified) 593 (cons modeline-modified-extent 'modeline-modified)
633 (cons modeline-buffer-id-extent 'modeline-buffer-identification) 594 (cons modeline-buffer-id-extent 'modeline-buffer-identification)
634 (purecopy " ") 595 (purecopy " ")
635 'global-mode-string 596 'global-mode-string
636 (purecopy " %[(") 597 (purecopy " %[(")
637 (cons modeline-minor-mode-extent 598 (cons modeline-minor-mode-extent (list "" 'mode-name 'minor-mode-alist))
638 (list (purecopy "") 'mode-name 'minor-mode-alist)) 599 (cons modeline-narrowed-extent "%n")
639 (cons modeline-narrowed-extent (purecopy "%n"))
640 'modeline-process 600 'modeline-process
641 (purecopy ")%]----") 601 (purecopy ")%]----")
642 (list 'line-number-mode (purecopy "L%l--")) 602 (purecopy '(line-number-mode "L%l--"))
643 (list 'column-number-mode (purecopy "C%c--")) 603 (purecopy '(column-number-mode "C%c--"))
644 (cons -3 (purecopy "%p")) 604 (purecopy '(-3 . "%p"))
645 (purecopy "-%-"))) 605 (purecopy "-%-")))
646 606
647 ;;; Added for XEmacs 20.3. Provide wrapper for vc since it may not always be 607 ;;; Added for XEmacs 20.3. Provide wrapper for vc since it may not always be
648 ;;; present, and its symbols are not visible this early in the dump if it 608 ;;; present, and its symbols are not visible this early in the dump if it
649 ;;; is. 609 ;;; is.