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