Mercurial > hg > xemacs-beta
annotate lisp/modeline.el @ 5640:e6b5c49f9e13
Add autoload cookie to custom-set-face-bold
| author | Vin Shelton <acs@xemacs.org> |
|---|---|
| date | Sun, 08 Jan 2012 22:29:06 -0500 |
| parents | cf2733b1ff4b |
| children |
| rev | line source |
|---|---|
| 428 | 1 ;;; modeline.el --- modeline hackery. |
| 2 | |
| 3 ;; Copyright (C) 1988, 1992-1994, 1997 Free Software Foundation, Inc. | |
| 771 | 4 ;; Copyright (C) 1995, 1996, 2002 Ben Wing. |
| 428 | 5 |
| 6 ;; Maintainer: XEmacs Development Team | |
| 7 ;; Keywords: extensions, dumped | |
| 8 | |
| 9 ;; This file is part of XEmacs. | |
| 10 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
11 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
12 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
13 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
14 ;; option) any later version. |
| 428 | 15 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
16 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
18 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
19 ;; for more details. |
| 428 | 20 |
| 21 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
22 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 23 |
| 24 ;;; Synched up with: Not in FSF. | |
| 25 | |
| 26 ;;; Commentary: | |
| 27 | |
| 28 ;; This file is dumped with XEmacs. | |
| 29 | |
| 30 ;;; Code: | |
| 31 | |
| 32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 33 ;;; General mouse modeline stuff ;;; | |
| 34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 35 | |
| 36 (defgroup modeline nil | |
| 37 "Modeline customizations." | |
| 38 :group 'environment) | |
| 39 | |
| 442 | 40 (defcustom modeline-3d-p ;; added for the options menu |
| 41 (let ((thickness | |
| 42 (specifier-instance modeline-shadow-thickness))) | |
| 43 (and (integerp thickness) | |
| 44 (> thickness 0))) | |
|
4578
49e17f7182f5
Fix docstring copy-pasto.
"Ville Skyttä <scop@xemacs.org>"
parents:
4043
diff
changeset
|
45 "Whether the modeline is displayed with raised, 3-d appearance. |
| 771 | 46 This option only has an effect when set using `customize-set-variable', |
| 47 or through the Options menu." | |
| 442 | 48 :group 'display |
| 49 :type 'boolean | |
| 50 :set #'(lambda (var val) | |
| 51 (if val | |
| 52 (set-specifier modeline-shadow-thickness 2) | |
| 53 (set-specifier modeline-shadow-thickness 0)) | |
| 54 (redraw-modeline t) | |
| 55 (setq modeline-3d-p val)) | |
| 56 ) | |
| 57 | |
| 428 | 58 (defcustom drag-divider-event-lag 150 |
| 59 "*The pause (in msecs) between divider drag events before redisplaying. | |
| 60 If this value is too small, dragging will be choppy because redisplay cannot | |
| 61 keep up. If it is too large, dragging will be choppy because of the explicit | |
| 62 redisplay delay specified." | |
| 63 :type 'integer | |
| 64 ;; #### Fix group. | |
| 65 :group 'modeline) | |
| 66 | |
| 67 (define-obsolete-variable-alias | |
| 68 'drag-modeline-event-lag | |
| 69 'drag-divider-event-lag) | |
| 70 | |
| 71 (defcustom modeline-click-swaps-buffers nil | |
| 72 "*If non-nil, clicking on the modeline changes the current buffer. | |
| 73 Click on the left half of the modeline cycles forward through the | |
| 74 buffer list and clicking on the right half cycles backward." | |
| 75 :type 'boolean | |
| 76 :group 'modeline) | |
| 77 | |
| 438 | 78 (defcustom modeline-scrolling-method nil |
| 79 "*If non-nil, dragging the modeline with the mouse may also scroll its | |
| 80 text horizontally (vertical motion controls window resizing and horizontal | |
| 81 motion controls modeline scrolling). | |
| 82 | |
| 83 With a value of t, the modeline text is scrolled in the same direction as | |
| 84 the mouse motion. With a value of 'scrollbar, the modeline is considered as | |
| 771 | 85 a scrollbar for its own text, which then moves in the opposite direction. |
| 86 | |
| 87 This option should be set using `customize-set-variable'." | |
| 438 | 88 :type '(choice (const :tag "none" nil) |
| 89 (const :tag "text" t) | |
| 90 (const :tag "scrollbar" scrollbar)) | |
| 91 :set (lambda (sym val) | |
| 92 (set-default sym val) | |
| 93 (when (featurep 'x) | |
| 94 (cond ((eq val t) | |
| 95 (set-glyph-image modeline-pointer-glyph "hand2" 'global 'x)) | |
| 96 ((eq val 'scrollbar) | |
| 97 (set-glyph-image modeline-pointer-glyph "fleur" 'global 'x)) | |
| 98 (t | |
| 99 (set-glyph-image modeline-pointer-glyph "sb_v_double_arrow" | |
| 442 | 100 'global 'x)))) |
| 101 (when (featurep 'mswindows) | |
| 102 (cond ((eq val t) | |
| 103 (set-glyph-image modeline-pointer-glyph | |
| 104 [mswindows-resource :resource-type cursor | |
| 105 :resource-id "SizeAll"] | |
| 106 'global 'mswindows)) | |
| 107 ((eq val 'scrollbar) | |
| 108 (set-glyph-image modeline-pointer-glyph | |
| 109 [mswindows-resource :resource-type cursor | |
| 110 :resource-id "Normal"] | |
| 111 'global 'mswindows)) | |
| 112 (t | |
| 113 (set-glyph-image modeline-pointer-glyph | |
| 114 [mswindows-resource :resource-type cursor | |
| 115 :resource-id "SizeNS"] | |
| 116 'global 'mswindows))))) | |
| 438 | 117 :group 'modeline) |
| 118 | |
| 428 | 119 (defun mouse-drag-modeline (event) |
| 120 "Resize a window by dragging its modeline. | |
| 121 This command should be bound to a button-press event in modeline-map. | |
| 122 Holding down a mouse button and moving the mouse up and down will | |
| 438 | 123 make the clicked-on window taller or shorter. |
| 124 | |
| 125 See also the variable `modeline-scrolling-method'." | |
| 428 | 126 (interactive "e") |
| 127 (or (button-press-event-p event) | |
| 128 (error "%s must be invoked by a mouse-press" this-command)) | |
| 129 (or (event-over-modeline-p event) | |
| 130 (error "not over a modeline")) | |
| 131 ;; Give the modeline a "pressed" look. --hniksic | |
| 132 (let-specifier ((modeline-shadow-thickness | |
| 133 (- (specifier-instance modeline-shadow-thickness | |
| 134 (event-window event))) | |
| 135 (event-window event))) | |
| 136 (let ((done nil) | |
| 137 (depress-line (event-y event)) | |
| 138 (start-event-frame (event-frame event)) | |
| 139 (start-event-window (event-window event)) | |
| 140 (start-nwindows (count-windows t)) | |
| 438 | 141 (hscroll-delta (face-width 'modeline)) |
| 142 (start-hscroll (modeline-hscroll (event-window event))) | |
| 143 (start-x-pixel (event-x-pixel event)) | |
| 428 | 144 (last-timestamp 0) |
| 145 default-line-height | |
| 146 modeline-height | |
| 147 should-enlarge-minibuffer | |
| 148 event min-height minibuffer y top bot edges wconfig growth) | |
| 149 (setq minibuffer (minibuffer-window start-event-frame) | |
| 150 default-line-height (face-height 'default start-event-window) | |
| 151 min-height (+ (* window-min-height default-line-height) | |
| 152 ;; Don't let the window shrink by a | |
| 153 ;; non-multiple of the default line | |
| 154 ;; height. (enlarge-window -1) will do | |
| 155 ;; this if the difference between the | |
| 156 ;; current window height and the minimum | |
| 157 ;; window height is less than the height | |
| 158 ;; of the default font. These extra | |
| 159 ;; lost pixels of height don't come back | |
| 160 ;; if you grow the window again. This | |
| 161 ;; can make it impossible to drag back | |
| 162 ;; to the exact original size, which is | |
| 163 ;; disconcerting. | |
| 164 (% (window-pixel-height start-event-window) | |
| 165 default-line-height)) | |
| 166 modeline-height | |
| 167 (if (specifier-instance has-modeline-p start-event-window) | |
| 168 (+ (face-height 'modeline start-event-window) | |
| 169 (* 2 (specifier-instance modeline-shadow-thickness | |
| 170 start-event-window))) | |
| 171 (* 2 (specifier-instance modeline-shadow-thickness | |
| 172 start-event-window)))) | |
| 173 (if (not (eq (window-frame minibuffer) start-event-frame)) | |
| 174 (setq minibuffer nil)) | |
| 175 (if (and (null minibuffer) (one-window-p t)) | |
| 176 (error "Attempt to resize sole window")) | |
| 177 ;; if this is the bottommost ordinary window, then to | |
| 178 ;; move its modeline the minibuffer must be enlarged. | |
| 179 (setq should-enlarge-minibuffer | |
| 180 (and minibuffer (window-lowest-p start-event-window))) | |
| 181 ;; loop reading events | |
| 182 (while (not done) | |
| 183 (setq event (next-event event)) | |
| 184 ;; requeue event and quit if this is a misc-user, eval or | |
| 185 ;; keypress event. | |
| 186 ;; quit if this is a button press or release event, or if the event | |
| 187 ;; occurred in some other frame. | |
| 188 ;; drag if this is a mouse motion event and the time | |
| 189 ;; between this event and the last event is greater than | |
| 190 ;; drag-divider-event-lag. | |
| 191 ;; do nothing if this is any other kind of event. | |
| 192 (cond ((or (misc-user-event-p event) | |
| 193 (key-press-event-p event)) | |
| 194 (setq unread-command-events (nconc unread-command-events | |
| 195 (list event)) | |
| 196 done t)) | |
| 197 ((button-release-event-p event) | |
| 198 (setq done t) | |
| 199 ;; Consider we have a mouse click neither X pos (modeline | |
| 200 ;; scroll) nore Y pos (modeline drag) have changed. | |
| 201 (and modeline-click-swaps-buffers | |
| 202 (= depress-line (event-y event)) | |
| 438 | 203 (or (not modeline-scrolling-method) |
| 204 (= start-hscroll | |
| 205 (modeline-hscroll start-event-window))) | |
| 428 | 206 (modeline-swap-buffers event))) |
| 207 ((button-event-p event) | |
| 208 (setq done t)) | |
| 209 ((not (motion-event-p event)) | |
| 210 (dispatch-event event)) | |
| 211 ((not (eq start-event-frame (event-frame event))) | |
| 212 (setq done t)) | |
| 213 ((< (abs (- (event-timestamp event) last-timestamp)) | |
| 214 drag-divider-event-lag) | |
| 215 nil) | |
| 216 (t | |
| 438 | 217 (when modeline-scrolling-method |
| 218 (let ((delta (/ (- (event-x-pixel event) start-x-pixel) | |
| 219 hscroll-delta))) | |
| 220 (set-modeline-hscroll start-event-window | |
| 221 (if (eq modeline-scrolling-method t) | |
| 222 (- start-hscroll delta) | |
| 223 (+ start-hscroll delta))) | |
| 224 )) | |
| 428 | 225 (setq last-timestamp (event-timestamp event) |
| 226 y (event-y-pixel event) | |
| 227 edges (window-pixel-edges start-event-window) | |
| 228 top (nth 1 edges) | |
| 229 bot (nth 3 edges)) | |
| 230 ;; scale back a move that would make the | |
| 231 ;; window too short. | |
| 232 (cond ((< (- y top (- modeline-height)) min-height) | |
| 233 (setq y (+ top min-height (- modeline-height))))) | |
| 234 ;; compute size change needed | |
| 235 (setq growth (- y bot (/ (- modeline-height) 2)) | |
| 236 wconfig (current-window-configuration)) | |
| 237 ;; grow/shrink minibuffer? | |
| 238 (if should-enlarge-minibuffer | |
| 239 (progn | |
| 240 ;; yes. scale back shrinkage if it | |
| 241 ;; would make the minibuffer less than 1 | |
| 242 ;; line tall. | |
| 243 ;; | |
| 244 ;; also flip the sign of the computed growth, | |
| 245 ;; since if we want to grow the window with the | |
| 246 ;; modeline we need to shrink the minibuffer | |
| 247 ;; and vice versa. | |
| 248 (if (and (> growth 0) | |
| 249 (< (- (window-pixel-height minibuffer) | |
| 250 growth) | |
| 251 default-line-height)) | |
| 252 (setq growth | |
| 253 (- (window-pixel-height minibuffer) | |
| 254 default-line-height))) | |
| 255 (setq growth (- growth)))) | |
| 256 ;; window grow and shrink by lines not pixels, so | |
| 257 ;; divide the pixel height by the height of the | |
| 258 ;; default face. | |
| 259 (setq growth (/ growth default-line-height)) | |
| 260 ;; grow/shrink the window | |
| 261 (enlarge-window growth nil (if should-enlarge-minibuffer | |
| 262 minibuffer | |
| 263 start-event-window)) | |
| 264 ;; if this window's growth caused another | |
| 265 ;; window to be deleted because it was too | |
| 266 ;; short, rescind the change. | |
| 267 ;; | |
| 268 ;; if size change caused space to be stolen | |
| 269 ;; from a window above this one, rescind the | |
| 270 ;; change, but only if we didn't grow/shrink | |
| 271 ;; the minibuffer. minibuffer size changes | |
| 272 ;; can cause all windows to shrink... no way | |
| 273 ;; around it. | |
| 274 (if (or (/= start-nwindows (count-windows t)) | |
| 275 (and (not should-enlarge-minibuffer) | |
| 276 (/= top (nth 1 (window-pixel-edges | |
| 277 start-event-window))))) | |
| 278 (set-window-configuration wconfig)))))))) | |
| 279 | |
| 280 ;; from Bob Weiner (bob_weiner@pts.mot.com) | |
| 281 ;; Whether this function should be called is now decided in | |
| 282 ;; mouse-drag-modeline - dverna feb. 98 | |
| 283 (defun modeline-swap-buffers (event) | |
| 284 "Handle mouse clicks on modeline by switching buffers. | |
| 285 If click on left half of a frame's modeline, bury current buffer. | |
| 286 If click on right half of a frame's modeline, raise bottommost buffer. | |
| 287 Arg EVENT is the button release event that occurred on the modeline." | |
| 288 (or (event-over-modeline-p event) | |
| 289 (error "not over a modeline")) | |
| 290 (or (button-release-event-p event) | |
| 291 (error "not a button release event")) | |
| 292 (if (< (event-x event) (/ (window-width (event-window event)) 2)) | |
| 293 ;; On left half of modeline, bury current buffer, | |
| 294 ;; displaying second buffer on list. | |
| 295 (mouse-bury-buffer event) | |
| 296 ;; On right half of modeline, raise and display bottommost | |
| 297 ;; buffer in buffer list. | |
| 298 (mouse-unbury-buffer event))) | |
| 299 | |
| 300 (defconst modeline-menu | |
| 301 '("Window Commands" | |
| 302 ["Delete Window Above" delete-window t] | |
| 303 ["Delete Other Windows" delete-other-windows t] | |
| 304 ["Split Window Above" split-window-vertically t] | |
| 305 ["Split Window Horizontally" split-window-horizontally t] | |
| 306 ["Balance Windows" balance-windows t] | |
| 307 )) | |
| 308 | |
| 309 (defun modeline-menu (event) | |
| 310 (interactive "e") | |
| 311 (popup-menu-and-execute-in-window | |
| 312 (cons (format "Window Commands for %S:" | |
| 313 (buffer-name (event-buffer event))) | |
| 314 (cdr modeline-menu)) | |
| 315 event)) | |
| 316 | |
| 317 (defvar modeline-map (make-sparse-keymap 'modeline-map) | |
| 318 "Keymap consulted for mouse-clicks on the modeline of a window. | |
| 319 This variable may be buffer-local; its value will be looked up in | |
| 320 the buffer of the window whose modeline was clicked upon.") | |
| 321 | |
| 322 (define-key modeline-map 'button1 'mouse-drag-modeline) | |
| 323 ;; button2 selects the window without setting point | |
| 324 (define-key modeline-map 'button2 (lambda () (interactive "@"))) | |
| 325 (define-key modeline-map 'button3 'modeline-menu) | |
| 326 | |
| 327 (make-face 'modeline-mousable "Face for mousable portions of the modeline.") | |
| 328 (set-face-parent 'modeline-mousable 'modeline nil '(default)) | |
| 329 (when (featurep 'window-system) | |
| 440 | 330 (set-face-foreground 'modeline-mousable "firebrick" nil '(default color win)) |
| 331 (set-face-font 'modeline-mousable [bold] nil '(default mono win)) | |
| 332 (set-face-font 'modeline-mousable [bold] nil '(default grayscale win))) | |
| 428 | 333 |
| 334 (defmacro make-modeline-command-wrapper (command) | |
|
5513
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
335 "Return a function object wrapping COMMAND, for use with the modeline. |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
336 |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
337 The function (itself a command, with \"e\" as its interactive spec) calls |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
338 COMMAND with the appropriate window selected, and is suitable as a binding |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
339 in the keymaps associated with the modeline." |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
340 (cond |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
341 ((and-fboundp 'cl-const-expr-p (cl-const-expr-p command)) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
342 `#'(lambda (event) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
343 (interactive "e") |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
344 (save-selected-window |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
345 (select-window (event-window event)) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
346 (call-interactively ,command)))) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
347 ((eval-when-compile (cl-compiling-file)) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
348 (let ((compiled |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
349 (eval-when-compile |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
350 (byte-compile-sexp |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
351 #'(lambda (event) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
352 (interactive "e") |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
353 (save-selected-window |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
354 (select-window (event-window event)) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
355 (call-interactively 'placeholder))))))) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
356 `(make-byte-code ',(compiled-function-arglist compiled) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
357 ,(compiled-function-instructions compiled) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
358 (vector ,@(subst command ''placeholder |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
359 (mapcar 'quote-maybe |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
360 (compiled-function-constants compiled)) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
361 :test 'equal)) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
362 ,(compiled-function-stack-depth compiled) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
363 ,(compiled-function-doc-string compiled) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
364 ,(quote-maybe (second (compiled-function-interactive compiled)))))) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
365 (t |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
366 `(lexical-let ((command ,command)) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
367 #'(lambda (event) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
368 (interactive "e") |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
369 (save-selected-window |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
370 (select-window (event-window event)) |
|
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
371 (call-interactively command))))))) |
| 428 | 372 |
| 373 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 374 ;;; Minor modes ;;; | |
| 375 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 376 | |
| 377 (defvar minor-mode-alist nil | |
| 378 "Alist saying how to show minor modes in the modeline. | |
| 379 Each element looks like (VARIABLE STRING); | |
| 380 STRING is included in the modeline iff VARIABLE's value is non-nil. | |
| 381 | |
| 382 Actually, STRING need not be a string; any possible modeline element | |
| 383 is okay. See `modeline-format'.") | |
| 384 | |
| 385 ;; Used by C code (lookup-key and friends) but defined here. | |
| 386 (defvar minor-mode-map-alist nil | |
| 387 "Alist of keymaps to use for minor modes. | |
| 388 Each element looks like (VARIABLE . KEYMAP); KEYMAP is used to read | |
| 389 key sequences and look up bindings iff VARIABLE's value is non-nil. | |
| 390 If two active keymaps bind the same key, the keymap appearing earlier | |
| 391 in the list takes precedence.") | |
| 392 | |
| 393 (make-face 'modeline-mousable-minor-mode | |
| 394 "Face for mousable minor-mode strings in the modeline.") | |
| 395 (set-face-parent 'modeline-mousable-minor-mode 'modeline-mousable nil | |
| 396 '(default)) | |
| 397 (when (featurep 'window-system) | |
| 440 | 398 (set-face-foreground 'modeline-mousable-minor-mode '("green4" "forestgreen") |
| 399 nil '(default color win))) | |
| 428 | 400 |
| 401 (defvar modeline-mousable-minor-mode-extent (make-extent nil nil) | |
| 402 ;; alliteration at its finest. | |
| 403 "Extent managing the mousable minor mode modeline strings.") | |
| 404 (set-extent-face modeline-mousable-minor-mode-extent | |
| 405 'modeline-mousable-minor-mode) | |
| 406 | |
| 407 ;; This replaces the idiom | |
| 408 ;; | |
| 409 ;; (or (assq 'isearch-mode minor-mode-alist) | |
| 410 ;; (setq minor-mode-alist | |
| 411 ;; (purecopy | |
| 412 ;; (append minor-mode-alist | |
| 413 ;; '((isearch-mode isearch-mode)))))) | |
| 414 | |
| 415 (defun add-minor-mode (toggle name &optional keymap after toggle-fun) | |
| 416 "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'. | |
| 417 | |
| 418 TOGGLE is a symbol whose value as a variable specifies whether the | |
| 419 minor mode is active. | |
| 420 | |
| 421 NAME is the name that should appear in the modeline. It should either | |
| 422 be a string beginning with a space, or a symbol with a similar string | |
| 423 as its value. | |
| 424 | |
| 425 KEYMAP is a keymap to make active when the minor mode is active. | |
| 426 | |
| 427 AFTER is the toggling symbol used for another minor mode. If AFTER is | |
| 428 non-nil, then it is used to position the new mode in the minor-mode | |
| 429 alists. | |
| 430 | |
| 431 TOGGLE-FUN specifies an interactive function that is called to toggle | |
| 432 the mode on and off; this affects what happens when button2 is pressed | |
| 433 on the mode, and when button3 is pressed somewhere in the list of | |
| 434 modes. If TOGGLE-FUN is nil and TOGGLE names an interactive function, | |
| 435 TOGGLE is used as the toggle function. | |
| 436 | |
| 437 Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map)" | |
| 438 (let* ((add-elt #'(lambda (elt sym) | |
| 439 (let (place) | |
| 440 (cond ((null after) ; add to front | |
| 441 (push elt (symbol-value sym))) | |
| 442 ((and (not (eq after t)) | |
| 443 (setq place (memq (assq after | |
| 444 (symbol-value sym)) | |
| 445 (symbol-value sym)))) | |
| 446 (push elt (cdr place))) | |
| 447 (t | |
| 448 (set sym (append (symbol-value sym) | |
| 449 (list elt)))))) | |
| 450 (symbol-value sym))) | |
| 451 el toggle-keymap) | |
| 452 (if toggle-fun | |
| 453 (check-argument-type 'commandp toggle-fun) | |
| 454 (when (commandp toggle) | |
| 455 (setq toggle-fun toggle))) | |
| 456 (when (and toggle-fun name) | |
| 457 (setq toggle-keymap (make-sparse-keymap | |
| 458 (intern (concat "modeline-minor-" | |
| 459 (symbol-name toggle) | |
| 460 "-map")))) | |
| 461 (define-key toggle-keymap 'button2 | |
|
5513
cf2733b1ff4b
Be more reasonable in the implementation of #'make-modeline-command-wrapper.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
462 (make-modeline-command-wrapper toggle-fun)) |
| 428 | 463 (put toggle 'modeline-toggle-function toggle-fun)) |
| 464 (when name | |
| 465 (let ((hacked-name | |
| 466 (if toggle-keymap | |
| 467 (cons (let ((extent (make-extent nil nil))) | |
| 468 (set-extent-keymap extent toggle-keymap) | |
| 469 (set-extent-property | |
| 470 extent 'help-echo | |
| 471 (concat "button2 turns off " | |
| 472 (if (symbolp toggle-fun) | |
| 473 (symbol-name toggle-fun) | |
| 474 (symbol-name toggle)))) | |
| 475 extent) | |
| 476 (cons modeline-mousable-minor-mode-extent name)) | |
| 477 name))) | |
| 478 (if (setq el (assq toggle minor-mode-alist)) | |
| 479 (setcdr el (list hacked-name)) | |
| 438 | 480 (funcall add-elt |
| 428 | 481 (list toggle hacked-name) |
| 482 'minor-mode-alist)))) | |
| 483 (when keymap | |
| 484 (if (setq el (assq toggle minor-mode-map-alist)) | |
| 485 (setcdr el keymap) | |
| 486 (funcall add-elt | |
| 487 (cons toggle keymap) | |
| 488 'minor-mode-map-alist))))) | |
| 489 | |
| 695 | 490 (defcustom abbrev-mode-line-string " Abbrev" |
| 491 "*String to display in the modeline when `abbrev-mode' is active. | |
| 492 Set this to nil if you don't want a modeline indicator." | |
| 493 :type '(choice string | |
| 729 | 494 (const :tag "none" nil)) |
| 495 :group 'abbrev-mode) | |
| 695 | 496 |
| 497 (defcustom overwrite-mode-line-string " Ovwrt" | |
| 498 "*String to display in the modeline when `overwrite-mode' is active. | |
| 499 Set this to nil if you don't want a modeline indicator." | |
| 500 :type '(choice string | |
| 729 | 501 (const :tag "none" nil)) |
| 502 :group 'editing-basics) | |
| 695 | 503 |
| 504 (defcustom auto-fill-mode-line-string " Fill" | |
| 505 "*String to display in the modeline when `auto-fill-mode' is active. | |
| 506 Set this to nil if you don't want a modeline indicator." | |
| 507 :type '(choice string | |
| 729 | 508 (const :tag "none" nil)) |
| 509 :group 'fill) | |
| 695 | 510 |
| 511 (defcustom defining-kbd-macro-mode-line-string " Def" | |
| 512 "*String to display in the modeline when `defining-kbd-macro' is active. | |
| 513 Set this to nil if you don't want a modeline indicator." | |
| 514 :type '(choice string | |
| 729 | 515 (const :tag "none" nil)) |
| 516 :group 'keyboard) | |
| 695 | 517 |
| 428 | 518 ;; #### TODO: Add `:menu-tag' keyword to add-minor-mode. Or create a |
| 519 ;; separate function to manage the minor mode menu. | |
| 520 | |
| 521 ;(put 'abbrev-mode :menu-tag "Abbreviation Expansion") | |
| 695 | 522 (add-minor-mode 'abbrev-mode 'abbrev-mode-line-string) |
| 428 | 523 ;; only when visiting a file... |
| 695 | 524 (add-minor-mode 'overwrite-mode 'overwrite-mode-line-string) |
| 428 | 525 ;(put 'auto-fill-function :menu-tag "Auto Fill") |
| 695 | 526 (add-minor-mode 'auto-fill-function 'auto-fill-mode-line-string |
| 527 nil nil 'auto-fill-mode) | |
| 428 | 528 |
| 529 ;(put 'defining-kbd-macro :menu-tag "Keyboard Macro") | |
| 695 | 530 (add-minor-mode 'defining-kbd-macro 'defining-kbd-macro-mode-line-string |
| 531 nil nil | |
| 428 | 532 (lambda () |
| 533 (interactive) | |
| 534 (if defining-kbd-macro | |
| 535 (progn | |
| 536 ;; #### This means to disregard the last event. | |
| 537 ;; It is needed because the last recorded | |
| 538 ;; event is usually the mouse event that | |
| 539 ;; invoked the menu item (and this function), | |
| 540 ;; and having it in the macro causes problems. | |
| 541 (zap-last-kbd-macro-event) | |
| 542 (end-kbd-macro nil)) | |
| 543 (start-kbd-macro nil)))) | |
| 544 | |
| 545 (defun modeline-minor-mode-menu (event) | |
| 546 "The menu that pops up when you press `button3' inside the | |
| 547 parentheses on the modeline." | |
| 548 (interactive "e") | |
| 549 (save-excursion | |
| 550 (set-buffer (event-buffer event)) | |
| 551 (popup-menu-and-execute-in-window | |
| 552 (cons | |
| 553 "Minor Mode Toggles" | |
| 554 (sort | |
|
5267
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
555 (mapcan |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
556 #'(lambda (x) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
557 (let* ((toggle-sym (car x)) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
558 (toggle-fun (or (get toggle-sym |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
559 'modeline-toggle-function) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
560 (and (commandp toggle-sym) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
561 toggle-sym))) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
562 (menu-tag (symbol-name (if (symbolp toggle-fun) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
563 toggle-fun |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
564 toggle-sym)) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
565 ;; Here a function should maybe be invoked to |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
566 ;; beautify the symbol's menu appearance. |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
567 )) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
568 (and toggle-fun |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
569 (list (vector menu-tag |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
570 toggle-fun |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
571 ;; The following two are wrong because of |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
572 ;; possible name clashes. |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
573 ;:active (get toggle-sym :active t) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
574 ;:included (get toggle-sym :included t) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
575 :style 'toggle |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
576 :selected (and (boundp toggle-sym) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
577 toggle-sym)))))) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
578 minor-mode-alist) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4578
diff
changeset
|
579 (lambda (e1 e2) (string< (aref e1 0) (aref e2 0))))) |
| 428 | 580 event))) |
| 581 | |
| 582 (defvar modeline-minor-mode-map (make-sparse-keymap 'modeline-minor-mode-map) | |
| 583 "Keymap consulted for mouse-clicks on the minor-mode modeline list.") | |
| 584 (define-key modeline-minor-mode-map 'button3 'modeline-minor-mode-menu) | |
| 585 | |
| 586 (defvar modeline-minor-mode-extent (make-extent nil nil) | |
| 587 "Extent covering the minor mode modeline strings.") | |
| 588 (set-extent-face modeline-minor-mode-extent 'modeline-mousable) | |
| 589 (set-extent-keymap modeline-minor-mode-extent modeline-minor-mode-map) | |
| 590 | |
| 591 | |
| 592 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 771 | 593 ;;; Modeline definition ;;; |
| 428 | 594 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 595 | |
| 771 | 596 (defmacro define-modeline-control (name contents doc-string &optional face |
| 597 help-echo) | |
| 598 "Define a modeline control named NAME, a symbol. | |
| 599 A modeline control is a section of the modeline whose contents can easily | |
| 600 be changed independently of the rest of the modeline, which can have its | |
| 601 own color, and which can have its own mouse commands, which apply when the | |
| 602 mouse is over the control. | |
| 603 | |
| 604 Logically, a modeline control should be an object; but we have terrible | |
| 605 object support in XEmacs, and so history has given us a series of related | |
| 606 variables, which [hopefully] all follow the same conventions. | |
| 607 | |
| 608 Three variables are created: | |
| 609 | |
| 610 1. The variable holding the control specification is called | |
| 611 `modeline-NAME', and is automatically buffer-local. | |
| 612 | |
| 613 2. The variable holding the extent that covers the control area in the | |
| 614 modeline is called `modeline-NAME-extent'. Onto this extent, colors and | |
| 615 keymaps (and possibly glyphs?) can be added, and will be noticed by the | |
| 616 modeline redisplay code. The attachment of the extent and its control | |
| 617 is done somewhere in the modeline specification: either in the main spec | |
| 618 in `modeline-format', or in some other control, like this: | |
| 619 | |
| 620 (cons modeline-NAME-extent 'modeline-NAME) | |
| 621 | |
| 622 3. The keymap holding the mousable commands for the control is called | |
| 623 `modeline-NAME-map'. This is automatically attached to the extent by | |
| 624 this macro. | |
| 625 | |
| 626 Initial contents of the control are CONTENTS (see `modeline-format' for | |
| 627 information about the structure of this contents). DOC-STRING specifies | |
| 628 help text that will be placed in the control variable's documentation, | |
| 629 indicating what's supposed to be in the control. | |
| 630 | |
| 631 Optional argument FACE specifies the face of the control's | |
| 632 extent. (`modeline-mousable' is a good choice if your control is, in fact, | |
| 633 mousable (i.e. it has some mouse commands defined for it). Optional | |
| 634 argument HELP-ECHO specifies some help-echo to be displayed when the mouse | |
| 635 moves over the control, indicating what mouse strokes are available. " | |
| 636 (let ((control-var (intern (format "modeline-%s" name))) | |
| 637 (extent-var (intern (format "modeline-%s-extent" name))) | |
| 638 (map-var (intern (format "modeline-%s-map" name))) | |
| 639 ) | |
| 640 `(progn | |
| 641 (defconst ,control-var ,contents | |
| 642 ,(format "%s | |
| 643 | |
| 644 The format of the contents of this variable is documented in | |
| 645 `modeline-format'. The way the control is displayed can be changed by | |
| 646 setting the face of `%s'. Mouse commands | |
| 647 for the control can be set using `%s'." doc-string extent-var map-var)) | |
| 648 (make-variable-buffer-local ',control-var) | |
| 649 (defvar ,extent-var (make-extent nil nil) | |
| 650 ,(format "Extent covering the `%s' control." control-var)) | |
| 651 (defvar ,map-var (make-sparse-keymap 'modeline-narrowed-map) | |
| 652 ,(format "Keymap consulted for mouse-clicks on the `%s' control." | |
| 653 control-var)) | |
| 654 (set-extent-face ,extent-var ,face) | |
| 655 (set-extent-keymap ,extent-var ,map-var) | |
| 656 (set-extent-property ,extent-var 'help-echo ,help-echo)))) | |
| 657 (put 'define-modeline-control 'lisp-indent-function 2) | |
| 658 | |
| 659 ;; ------------------------ modeline buffer id ------------------- | |
| 660 | |
| 428 | 661 (defun modeline-buffers-menu (event) |
| 662 (interactive "e") | |
| 663 (popup-menu-and-execute-in-window | |
| 664 '("Buffers Popup Menu" | |
| 665 :filter buffers-menu-filter | |
| 666 ["List All Buffers" list-buffers t] | |
| 667 "--" | |
| 668 ) | |
| 669 event)) | |
| 670 | |
| 771 | 671 (define-modeline-control buffer-id-left |
| 672 'modeline-modified-buffer-highlighted-name ;; "XEmacs:" | |
| 673 "Modeline control for left half of buffer ID." | |
| 674 'modeline-mousable | |
| 675 "button2 cycles to the previous buffer") | |
| 428 | 676 |
| 771 | 677 (define-modeline-control buffer-id-right |
| 678 'modeline-modified-buffer-non-highlighted-name ;; " %17b" | |
| 679 "Modeline control for right half of buffer ID." | |
| 680 nil | |
| 681 "button2 cycles to the next buffer") | |
| 428 | 682 |
| 683 (define-key modeline-buffer-id-left-map 'button2 'mouse-unbury-buffer) | |
| 684 (define-key modeline-buffer-id-right-map 'button2 'mouse-bury-buffer) | |
| 685 (define-key modeline-buffer-id-left-map 'button3 'modeline-buffers-menu) | |
| 686 (define-key modeline-buffer-id-right-map 'button3 'modeline-buffers-menu) | |
| 687 | |
| 688 (make-face 'modeline-buffer-id | |
| 689 "Face for the buffer ID string in the modeline.") | |
| 690 (set-face-parent 'modeline-buffer-id 'modeline nil '(default)) | |
| 691 (when (featurep 'window-system) | |
| 440 | 692 (set-face-foreground 'modeline-buffer-id "blue4" nil '(default color win)) |
| 693 (set-face-font 'modeline-buffer-id [bold-italic] nil '(default mono win)) | |
| 771 | 694 (set-face-font 'modeline-buffer-id [bold-italic] nil '(default grayscale |
| 695 win))) | |
| 428 | 696 (when (featurep 'tty) |
| 697 (set-face-font 'modeline-buffer-id [bold-italic] nil '(default tty))) | |
| 698 | |
| 771 | 699 (define-modeline-control buffer-id |
| 700 (list (cons modeline-buffer-id-left-extent 'modeline-buffer-id-left) | |
| 701 (cons modeline-buffer-id-right-extent 'modeline-buffer-id-right)) | |
| 428 | 702 "Modeline control for identifying the buffer being displayed. |
| 442 | 703 Its default value is |
| 704 | |
| 771 | 705 (list (cons modeline-buffer-id-left-extent 'modeline-buffer-id-left) |
| 706 (cons modeline-buffer-id-right-extent 'modeline-buffer-id-right)) | |
| 442 | 707 |
| 708 Major modes that edit things other than ordinary files may change this | |
| 771 | 709 (e.g. Info, Dired,...)." |
| 710 'modeline-buffer-id) | |
| 711 | |
| 712 (defvaralias 'modeline-buffer-identification 'modeline-buffer-id) | |
| 713 | |
| 714 (defvar modeline-modified-buffer-non-highlighted-name nil) | |
| 715 (make-variable-buffer-local 'modeline-modified-buffer-non-highlighted-name) | |
| 716 (put 'modeline-modified-buffer-non-highlighted-name 'permanent-local t) | |
| 717 | |
| 718 (defvar modeline-modified-buffer-highlighted-name nil) | |
| 719 (make-variable-buffer-local 'modeline-modified-buffer-highlighted-name) | |
| 720 (put 'modeline-modified-buffer-highlighted-name 'permanent-local t) | |
| 721 | |
| 722 (defvar modeline-recorded-buffer-name nil) | |
| 723 (make-variable-buffer-local 'modeline-recorded-buffer-name) | |
| 724 (put 'modeline-recorded-buffer-name 'permanent-local t) | |
| 725 | |
| 726 (defvar modeline-recorded-buffer-file-name nil) | |
| 727 (make-variable-buffer-local 'modeline-recorded-buffer-file-name) | |
| 728 (put 'modeline-recorded-buffer-file-name 'permanent-local t) | |
| 729 | |
| 730 (add-hook 'buffer-list-changed-hook 'modeline-update-buffer-names) | |
| 731 | |
| 732 (defvar modeline-max-buffer-name-size 30) | |
| 733 | |
| 734 (defun modeline-update-buffer-names (frame) | |
| 735 (mapc #'(lambda (buf) | |
| 736 (when (or (not (eq (buffer-name buf) | |
| 737 (symbol-value-in-buffer | |
| 738 'modeline-recorded-buffer-name buf))) | |
| 739 (not (eq (buffer-file-name buf) | |
| 740 (symbol-value-in-buffer | |
| 741 'modeline-recorded-buffer-file-name buf)))) | |
| 742 ;(dp "processing %s" buf) | |
| 743 (with-current-buffer buf | |
| 744 (setq modeline-recorded-buffer-name (buffer-name)) | |
| 745 (setq modeline-recorded-buffer-file-name (buffer-file-name)) | |
| 746 (if (not modeline-recorded-buffer-file-name) | |
| 747 (setq modeline-modified-buffer-non-highlighted-name | |
| 748 modeline-recorded-buffer-name | |
| 749 modeline-modified-buffer-highlighted-name nil) | |
| 750 (let ((fn | |
| 751 (if (<= (length modeline-recorded-buffer-file-name) | |
| 752 modeline-max-buffer-name-size) | |
| 753 modeline-recorded-buffer-file-name | |
| 754 (concat "..." | |
| 755 (substring | |
| 756 modeline-recorded-buffer-file-name | |
| 757 (- modeline-max-buffer-name-size)))))) | |
| 758 (setq modeline-modified-buffer-non-highlighted-name | |
| 759 ;; if the filename is very long, the entire | |
| 760 ;; directory will get truncated to | |
| 761 ;; non-existence. | |
| 762 (let ((dir (file-name-directory fn))) | |
| 763 (if dir | |
| 764 (concat " (" | |
| 765 (directory-file-name | |
| 766 (file-name-directory fn)) | |
| 767 ")") | |
| 768 "")) | |
| 769 modeline-modified-buffer-highlighted-name | |
| 770 (file-name-nondirectory fn)))) | |
| 771 (redraw-modeline)))) | |
| 772 (buffer-list))) | |
| 773 | |
| 774 (defcustom modeline-new-buffer-id-format t | |
| 775 "Whether the new format for the modeline buffer ID (with directory) is used. | |
| 776 This option only has an effect when set using `customize-set-variable', | |
| 777 or through the Options menu." | |
| 778 :group 'modeline | |
| 779 :type 'boolean | |
| 780 :set #'(lambda (var val) | |
| 781 (if val | |
| 782 (progn | |
| 783 (setq-default modeline-buffer-id-left | |
| 784 'modeline-modified-buffer-highlighted-name | |
| 785 modeline-buffer-id-right | |
| 786 'modeline-modified-buffer-non-highlighted-name) | |
| 787 (set-extent-face modeline-buffer-id-left-extent | |
| 788 'modeline-mousable)) | |
| 789 (setq-default modeline-buffer-id-left "XEmacs:" | |
| 790 modeline-buffer-id-right '(" %17b")) | |
| 791 (set-extent-face modeline-buffer-id-left-extent nil)))) | |
| 792 | |
| 793 ;; ------------------------ other modeline controls ------------------- | |
| 428 | 794 |
| 795 ;; These are for the sake of minor mode menu. #### All of this is | |
| 796 ;; kind of dirty. `add-minor-mode' started out as a simple substitute | |
| 797 ;; for (or (assq ...) ...) FSF stuff, but now is used for all kind of | |
| 798 ;; stuff. There should perhaps be a separate function to add toggles | |
| 799 ;; to the minor-mode-menu. | |
| 800 (add-minor-mode 'line-number-mode "") | |
| 801 (add-minor-mode 'column-number-mode "") | |
| 802 | |
| 771 | 803 (define-modeline-control coding-system '("%C") |
| 804 "Modeline control for showing current coding system.") | |
| 805 ;; added March 7, 2002 | |
| 806 (define-obsolete-variable-alias 'modeline-multibyte-status | |
| 807 'modeline-coding-system) | |
| 428 | 808 |
| 771 | 809 (define-modeline-control modified '("--%1*%1+-") |
| 810 "Modeline control for displaying whether current buffer is modified." | |
| 811 'modeline-mousable | |
| 812 "button2 toggles the buffer's read-only status") | |
| 428 | 813 (define-key modeline-modified-map 'button2 |
| 814 (make-modeline-command-wrapper 'modeline-toggle-read-only)) | |
| 815 | |
| 816 ;;; Added for XEmacs 20.3. Provide wrapper for vc since it may not always be | |
| 817 ;;; present, and its symbols are not visible this early in the dump if it | |
| 818 ;;; is. | |
| 819 | |
| 820 (defun modeline-toggle-read-only () | |
| 821 "Change whether this buffer is visiting its file read-only. | |
| 822 With arg, set read-only iff arg is positive. | |
| 823 This function is designed to be called when the read-only indicator on the | |
| 824 modeline is clicked. It will call `vc-toggle-read-only' if available, | |
| 825 otherwise it will call the usual `toggle-read-only'." | |
| 826 (interactive) | |
| 502 | 827 (if-fboundp 'vc-toggle-read-only |
| 428 | 828 (vc-toggle-read-only) |
| 829 (toggle-read-only))) | |
| 830 | |
| 771 | 831 (define-modeline-control line-number (list 'line-number-mode "L%l ") |
| 832 "Modeline control for displaying the line number of point.") | |
| 833 (define-modeline-control column-number (list 'column-number-mode "C%c ") | |
| 834 "Modeline control for displaying the column number of point.") | |
| 835 (define-modeline-control percentage (cons -3 "%p") | |
| 836 "Modeline control for displaying percentage of file above point.") | |
| 837 | |
| 838 (define-modeline-control position-status | |
| 839 (cons 15 (list | |
| 840 (cons modeline-line-number-extent | |
| 841 'modeline-line-number) | |
| 842 (cons modeline-column-number-extent | |
| 843 'modeline-column-number) | |
| 844 (cons modeline-percentage-extent | |
| 845 'modeline-percentage))) | |
| 846 "Modeline control for providing status about the location of point. | |
| 847 Generally includes the line number of point, its column number, and the | |
| 848 percentage of the file above point." | |
| 849 'modeline-buffer-id) | |
| 850 | |
| 851 (defconst modeline-tty-frame-specifier (make-specifier 'boolean)) | |
| 852 (add-hook 'create-frame-hook 'modeline-update-tty-frame-specifier) | |
| 853 (defun modeline-update-tty-frame-specifier (f) | |
| 4043 | 854 (if (and (eq (frame-type f) 'tty) |
| 855 (> (frame-property f 'frame-number) 1)) | |
| 856 (set-specifier modeline-tty-frame-specifier t f))) | |
| 771 | 857 |
| 858 (define-modeline-control tty-frame-id (list modeline-tty-frame-specifier | |
| 859 " [%S]" | |
| 860 ) | |
| 861 "Modeline control for showing which TTY frame is selected.") | |
| 862 | |
| 863 (define-modeline-control narrowed '("%n") | |
| 864 "Modeline control for displaying whether current buffer is narrowed." | |
| 865 'modeline-mousable | |
| 866 "button2 widens the buffer") | |
| 867 (define-key modeline-narrowed-map 'button2 | |
| 868 (make-modeline-command-wrapper 'widen)) | |
| 869 | |
| 870 (define-modeline-control process nil | |
| 871 "Modeline control for displaying info on process status. | |
| 872 Normally nil in most modes, since there is no process to display.") | |
| 873 | |
| 874 (setq-default | |
| 875 modeline-format | |
| 876 (list | |
| 877 "" | |
| 878 (cons modeline-coding-system-extent 'modeline-coding-system) | |
| 879 (cons modeline-modified-extent 'modeline-modified) | |
| 880 (cons modeline-position-status-extent 'modeline-position-status) | |
| 881 (cons modeline-tty-frame-id-extent 'modeline-tty-frame-id) | |
| 882 (cons modeline-buffer-id-extent 'modeline-buffer-id) | |
| 883 " " | |
| 884 'global-mode-string | |
| 885 " %[(" | |
| 886 (cons modeline-minor-mode-extent | |
| 887 (list "" 'mode-name 'minor-mode-alist)) | |
| 888 (cons modeline-narrowed-extent 'modeline-narrowed) | |
| 889 (cons modeline-process-extent 'modeline-process) | |
| 890 ")%]%-")) | |
| 891 | |
| 428 | 892 ;;; modeline.el ends here |