Mercurial > hg > xemacs-beta
annotate lisp/modeline.el @ 5753:dbd8305e13cb
Warn about non-string non-integer ARG to #'gensym, bytecomp.el.
lisp/ChangeLog addition:
2013-08-21 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el:
* bytecomp.el (gensym):
* bytecomp.el (byte-compile-gensym): New.
Warn that gensym called in a for-effect context is unlikely to be
useful.
Warn about non-string non-integer ARGs, this is incorrect.
Am not changing the function to error with same, most code that
makes the mistake is has no problems, which is why it has survived
so long.
* window-xemacs.el (save-window-excursion/mapping):
* window.el (save-window-excursion):
Call #'gensym with a string, not a symbol.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 21 Aug 2013 19:02:59 +0100 |
| 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 |