git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/modeline.el

   1 ;;; modeline.el --- modeline hackery.
   2
   3 ;; Copyright (C) 1988, 1992-1994, 1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1995, 1996 Ben Wing.
   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
  22 ;; along with XEmacs; see the file COPYING.  If not, write to the
  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
  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)))
  47   "Whether the default toolbar is globally visible. This option can be
  48 customized through the options menu."
  49   :group 'display
  50   :type 'boolean
  51   :set #'(lambda (var val)
  52            (if val
  53                (set-specifier modeline-shadow-thickness 2)
  54              (set-specifier modeline-shadow-thickness 0))
  55            (redraw-modeline t)
  56            (setq modeline-3d-p val))
  57   )
  58
  59 (defcustom drag-divider-event-lag 150
  60   "*The pause (in msecs) between divider drag events before redisplaying.
  61 If this value is too small, dragging will be choppy because redisplay cannot
  62 keep up. If it is too large, dragging will be choppy because of the explicit
  63 redisplay delay specified."
  64   :type 'integer
  65   ;; #### Fix group.
  66   :group 'modeline)
  67
  68 (define-obsolete-variable-alias
  69   'drag-modeline-event-lag
  70   'drag-divider-event-lag)
  71
  72 (defcustom modeline-click-swaps-buffers nil
  73   "*If non-nil, clicking on the modeline changes the current buffer.
  74 Click on the left half of the modeline cycles forward through the
  75 buffer list and clicking on the right half cycles backward."
  76   :type 'boolean
  77   :group 'modeline)
  78
  79 (defcustom modeline-scrolling-method nil
  80   "*If non-nil, dragging the modeline with the mouse may also scroll its
  81 text horizontally (vertical motion controls window resizing and horizontal
  82 motion controls modeline scrolling).
  83
  84 With a value of t, the modeline text is scrolled in the same direction as
  85 the mouse motion. With a value of 'scrollbar, the modeline is considered as
  86 a scrollbar for its own text, which then moves in the opposite direction."
  87   :type '(choice (const :tag "none" nil)
  88                  (const :tag "text" t)
  89                  (const :tag "scrollbar" scrollbar))
  90   :set (lambda (sym val)
  91          (set-default sym val)
  92          (when (featurep 'x)
  93            (cond ((eq val t)
  94                   (set-glyph-image modeline-pointer-glyph "hand2" 'global 'x))
  95                  ((eq val 'scrollbar)
  96                   (set-glyph-image modeline-pointer-glyph "fleur" 'global 'x))
  97                  (t
  98                   (set-glyph-image modeline-pointer-glyph "sb_v_double_arrow"
  99                                    'global 'x))))
 100          (when (featurep 'mswindows)
 101            (cond ((eq val t)
 102                   (set-glyph-image modeline-pointer-glyph
 103                                    [mswindows-resource :resource-type cursor
 104                                                        :resource-id "SizeAll"]
 105                                    'global 'mswindows))
 106                  ((eq val 'scrollbar)
 107                   (set-glyph-image modeline-pointer-glyph
 108                                    [mswindows-resource :resource-type cursor
 109                                                        :resource-id "Normal"]
 110                                    'global 'mswindows))
 111                  (t
 112                   (set-glyph-image modeline-pointer-glyph
 113                                    [mswindows-resource :resource-type cursor
 114                                                        :resource-id "SizeNS"]
 115                                    'global 'mswindows)))))
 116   :group 'modeline)
 117
 118 (defun mouse-drag-modeline (event)
 119   "Resize a window by dragging its modeline.
 120 This command should be bound to a button-press event in modeline-map.
 121 Holding down a mouse button and moving the mouse up and down will
 122 make the clicked-on window taller or shorter.
 123
 124 See also the variable `modeline-scrolling-method'."
 125   (interactive "e")
 126   (or (button-press-event-p event)
 127       (error "%s must be invoked by a mouse-press" this-command))
 128   (or (event-over-modeline-p event)
 129       (error "not over a modeline"))
 130   ;; Give the modeline a "pressed" look.  --hniksic
 131   (let-specifier ((modeline-shadow-thickness
 132                    (- (specifier-instance modeline-shadow-thickness
 133                                           (event-window event)))
 134                    (event-window event)))
 135     (let ((done nil)
 136           (depress-line (event-y event))
 137           (start-event-frame (event-frame event))
 138           (start-event-window (event-window event))
 139           (start-nwindows (count-windows t))
 140           (hscroll-delta (face-width 'modeline))
 141           (start-hscroll (modeline-hscroll (event-window event)))
 142           (start-x-pixel (event-x-pixel event))
 143           (last-timestamp 0)
 144           default-line-height
 145           modeline-height
 146           should-enlarge-minibuffer
 147           event min-height minibuffer y top bot edges wconfig growth)
 148       (setq minibuffer (minibuffer-window start-event-frame)
 149             default-line-height (face-height 'default start-event-window)
 150             min-height (+ (* window-min-height default-line-height)
 151                           ;; Don't let the window shrink by a
 152                           ;; non-multiple of the default line
 153                           ;; height.  (enlarge-window -1) will do
 154                           ;; this if the difference between the
 155                           ;; current window height and the minimum
 156                           ;; window height is less than the height
 157                           ;; of the default font.  These extra
 158                           ;; lost pixels of height don't come back
 159                           ;; if you grow the window again.  This
 160                           ;; can make it impossible to drag back
 161                           ;; to the exact original size, which is
 162                           ;; disconcerting.
 163                           (% (window-pixel-height start-event-window)
 164                              default-line-height))
 165             modeline-height
 166             (if (specifier-instance has-modeline-p start-event-window)
 167                 (+ (face-height 'modeline start-event-window)
 168                    (* 2 (specifier-instance modeline-shadow-thickness
 169                                             start-event-window)))
 170               (* 2 (specifier-instance modeline-shadow-thickness
 171                                        start-event-window))))
 172       (if (not (eq (window-frame minibuffer) start-event-frame))
 173           (setq minibuffer nil))
 174       (if (and (null minibuffer) (one-window-p t))
 175           (error "Attempt to resize sole window"))
 176       ;; if this is the bottommost ordinary window, then to
 177       ;; move its modeline the minibuffer must be enlarged.
 178       (setq should-enlarge-minibuffer
 179             (and minibuffer (window-lowest-p start-event-window)))
 180       ;; loop reading events
 181       (while (not done)
 182         (setq event (next-event event))
 183         ;; requeue event and quit if this is a misc-user, eval or
 184         ;;   keypress event.
 185         ;; quit if this is a button press or release event, or if the event
 186         ;;   occurred in some other frame.
 187         ;; drag if this is a mouse motion event and the time
 188         ;;   between this event and the last event is greater than
 189         ;;   drag-divider-event-lag.
 190         ;; do nothing if this is any other kind of event.
 191         (cond ((or (misc-user-event-p event)
 192                    (key-press-event-p event))
 193                (setq unread-command-events (nconc unread-command-events
 194                                                   (list event))
 195                      done t))
 196               ((button-release-event-p event)
 197                (setq done t)
 198                ;; Consider we have a mouse click neither X pos (modeline
 199                ;; scroll) nore Y pos (modeline drag) have changed.
 200                (and modeline-click-swaps-buffers
 201                     (= depress-line (event-y event))
 202                     (or (not modeline-scrolling-method)
 203                         (= start-hscroll
 204                            (modeline-hscroll start-event-window)))
 205                     (modeline-swap-buffers event)))
 206               ((button-event-p event)
 207                (setq done t))
 208               ((not (motion-event-p event))
 209                (dispatch-event event))
 210               ((not (eq start-event-frame (event-frame event)))
 211                (setq done t))
 212               ((< (abs (- (event-timestamp event) last-timestamp))
 213                   drag-divider-event-lag)
 214                nil)
 215               (t
 216                (when modeline-scrolling-method
 217                  (let ((delta (/ (- (event-x-pixel event) start-x-pixel)
 218                                  hscroll-delta)))
 219                    (set-modeline-hscroll start-event-window
 220                                          (if (eq modeline-scrolling-method t)
 221                                              (- start-hscroll delta)
 222                                            (+ start-hscroll delta)))
 223                    ))
 224                (setq last-timestamp (event-timestamp event)
 225                      y (event-y-pixel event)
 226                      edges (window-pixel-edges start-event-window)
 227                      top (nth 1 edges)
 228                      bot (nth 3 edges))
 229                ;; scale back a move that would make the
 230                ;; window too short.
 231                (cond ((< (- y top (- modeline-height)) min-height)
 232                       (setq y (+ top min-height (- modeline-height)))))
 233                ;; compute size change needed
 234                (setq growth (- y bot (/ (- modeline-height) 2))
 235                      wconfig (current-window-configuration))
 236                ;; grow/shrink minibuffer?
 237                (if should-enlarge-minibuffer
 238                    (progn
 239                      ;; yes.  scale back shrinkage if it
 240                      ;; would make the minibuffer less than 1
 241                      ;; line tall.
 242                      ;;
 243                      ;; also flip the sign of the computed growth,
 244                      ;; since if we want to grow the window with the
 245                      ;; modeline we need to shrink the minibuffer
 246                      ;; and vice versa.
 247                      (if (and (> growth 0)
 248                               (< (- (window-pixel-height minibuffer)
 249                                     growth)
 250                                  default-line-height))
 251                          (setq growth
 252                                (- (window-pixel-height minibuffer)
 253                                   default-line-height)))
 254                      (setq growth (- growth))))
 255                ;; window grow and shrink by lines not pixels, so
 256                ;; divide the pixel height by the height of the
 257                ;; default face.
 258                (setq growth (/ growth default-line-height))
 259                ;; grow/shrink the window
 260                (enlarge-window growth nil (if should-enlarge-minibuffer
 261                                               minibuffer
 262                                             start-event-window))
 263                ;; if this window's growth caused another
 264                ;; window to be deleted because it was too
 265                ;; short, rescind the change.
 266                ;;
 267                ;; if size change caused space to be stolen
 268                ;; from a window above this one, rescind the
 269                ;; change, but only if we didn't grow/shrink
 270                ;; the minibuffer.  minibuffer size changes
 271                ;; can cause all windows to shrink... no way
 272                ;; around it.
 273                (if (or (/= start-nwindows (count-windows t))
 274                        (and (not should-enlarge-minibuffer)
 275                             (/= top (nth 1 (window-pixel-edges
 276                                             start-event-window)))))
 277                    (set-window-configuration wconfig))))))))
 278
 279 ;; from Bob Weiner (bob_weiner@pts.mot.com)
 280 ;; Whether this function should be called is now decided in
 281 ;; mouse-drag-modeline - dverna feb. 98
 282 (defun modeline-swap-buffers (event)
 283   "Handle mouse clicks on modeline by switching buffers.
 284 If click on left half of a frame's modeline, bury current buffer.
 285 If click on right half of a frame's modeline, raise bottommost buffer.
 286 Arg EVENT is the button release event that occurred on the modeline."
 287   (or (event-over-modeline-p event)
 288       (error "not over a modeline"))
 289   (or (button-release-event-p event)
 290       (error "not a button release event"))
 291   (if (< (event-x event) (/ (window-width (event-window event)) 2))
 292       ;; On left half of modeline, bury current buffer,
 293       ;; displaying second buffer on list.
 294       (mouse-bury-buffer event)
 295     ;; On right half of modeline, raise and display bottommost
 296     ;; buffer in buffer list.
 297     (mouse-unbury-buffer event)))
 298
 299 (defconst modeline-menu
 300   '("Window Commands"
 301     ["Delete Window Above"       delete-window                  t]
 302     ["Delete Other Windows"      delete-other-windows           t]
 303     ["Split Window Above"        split-window-vertically        t]
 304     ["Split Window Horizontally" split-window-horizontally      t]
 305     ["Balance Windows"           balance-windows                t]
 306     ))
 307
 308 (defun modeline-menu (event)
 309   (interactive "e")
 310   (popup-menu-and-execute-in-window
 311    (cons (format "Window Commands for %S:"
 312                  (buffer-name (event-buffer event)))
 313          (cdr modeline-menu))
 314    event))
 315
 316 (defvar modeline-map (make-sparse-keymap 'modeline-map)
 317   "Keymap consulted for mouse-clicks on the modeline of a window.
 318 This variable may be buffer-local; its value will be looked up in
 319 the buffer of the window whose modeline was clicked upon.")
 320
 321 (define-key modeline-map 'button1 'mouse-drag-modeline)
 322 ;; button2 selects the window without setting point
 323 (define-key modeline-map 'button2 (lambda () (interactive "@")))
 324 (define-key modeline-map 'button3 'modeline-menu)
 325
 326 (make-face 'modeline-mousable "Face for mousable portions of the modeline.")
 327 (set-face-parent 'modeline-mousable 'modeline nil '(default))
 328 (when (featurep 'window-system)
 329   (set-face-foreground 'modeline-mousable "firebrick" nil '(default color win))
 330   (set-face-font 'modeline-mousable [bold] nil '(default mono win))
 331   (set-face-font 'modeline-mousable [bold] nil '(default grayscale win)))
 332
 333 (defmacro make-modeline-command-wrapper (command)
 334   `#'(lambda (event)
 335        (interactive "e")
 336        (save-selected-window
 337          (select-window (event-window event))
 338          (call-interactively ',(eval command)))))
 339 \f
 340 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 341 ;;;                            Minor modes                              ;;;
 342 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 343
 344 (defvar minor-mode-alist nil
 345   "Alist saying how to show minor modes in the modeline.
 346 Each element looks like (VARIABLE STRING);
 347 STRING is included in the modeline iff VARIABLE's value is non-nil.
 348
 349 Actually, STRING need not be a string; any possible modeline element
 350 is okay.  See `modeline-format'.")
 351
 352 ;; Used by C code (lookup-key and friends) but defined here.
 353 (defvar minor-mode-map-alist nil
 354   "Alist of keymaps to use for minor modes.
 355 Each element looks like (VARIABLE . KEYMAP); KEYMAP is used to read
 356 key sequences and look up bindings iff VARIABLE's value is non-nil.
 357 If two active keymaps bind the same key, the keymap appearing earlier
 358 in the list takes precedence.")
 359
 360 (make-face 'modeline-mousable-minor-mode
 361            "Face for mousable minor-mode strings in the modeline.")
 362 (set-face-parent 'modeline-mousable-minor-mode 'modeline-mousable nil
 363                  '(default))
 364 (when (featurep 'window-system)
 365   (set-face-foreground 'modeline-mousable-minor-mode '("green4" "forestgreen")
 366                        nil '(default color win)))
 367
 368 (defvar modeline-mousable-minor-mode-extent (make-extent nil nil)
 369   ;; alliteration at its finest.
 370   "Extent managing the mousable minor mode modeline strings.")
 371 (set-extent-face modeline-mousable-minor-mode-extent
 372                  'modeline-mousable-minor-mode)
 373
 374 ;; This replaces the idiom
 375 ;;
 376 ;; (or (assq 'isearch-mode minor-mode-alist)
 377 ;;     (setq minor-mode-alist
 378 ;;           (purecopy
 379 ;;            (append minor-mode-alist
 380 ;;                    '((isearch-mode isearch-mode))))))
 381
 382 (defun add-minor-mode (toggle name &optional keymap after toggle-fun)
 383   "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'.
 384
 385 TOGGLE is a symbol whose value as a variable specifies whether the
 386 minor mode is active.
 387
 388 NAME is the name that should appear in the modeline.  It should either
 389 be a string beginning with a space, or a symbol with a similar string
 390 as its value.
 391
 392 KEYMAP is a keymap to make active when the minor mode is active.
 393
 394 AFTER is the toggling symbol used for another minor mode.  If AFTER is
 395 non-nil, then it is used to position the new mode in the minor-mode
 396 alists.
 397
 398 TOGGLE-FUN specifies an interactive function that is called to toggle
 399 the mode on and off; this affects what happens when button2 is pressed
 400 on the mode, and when button3 is pressed somewhere in the list of
 401 modes.  If TOGGLE-FUN is nil and TOGGLE names an interactive function,
 402 TOGGLE is used as the toggle function.
 403
 404 Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map)"
 405   (let* ((add-elt #'(lambda (elt sym)
 406                       (let (place)
 407                         (cond ((null after) ; add to front
 408                                (push elt (symbol-value sym)))
 409                               ((and (not (eq after t))
 410                                     (setq place (memq (assq after
 411                                                             (symbol-value sym))
 412                                                       (symbol-value sym))))
 413                                (push elt (cdr place)))
 414                               (t
 415                                (set sym (append (symbol-value sym)
 416                                                 (list elt))))))
 417                       (symbol-value sym)))
 418          el toggle-keymap)
 419     (if toggle-fun
 420         (check-argument-type 'commandp toggle-fun)
 421       (when (commandp toggle)
 422         (setq toggle-fun toggle)))
 423     (when (and toggle-fun name)
 424       (setq toggle-keymap (make-sparse-keymap
 425                            (intern (concat "modeline-minor-"
 426                                            (symbol-name toggle)
 427                                            "-map"))))
 428       (define-key toggle-keymap 'button2
 429         ;; defeat the DUMB-ASS byte-compiler, which tries to
 430         ;; expand the macro at compile time and fucks up.
 431         (eval '(make-modeline-command-wrapper toggle-fun)))
 432       (put toggle 'modeline-toggle-function toggle-fun))
 433     (when name
 434       (let ((hacked-name
 435              (if toggle-keymap
 436                  (cons (let ((extent (make-extent nil nil)))
 437                          (set-extent-keymap extent toggle-keymap)
 438                          (set-extent-property
 439                           extent 'help-echo
 440                           (concat "button2 turns off "
 441                                   (if (symbolp toggle-fun)
 442                                       (symbol-name toggle-fun)
 443                                     (symbol-name toggle))))
 444                          extent)
 445                        (cons modeline-mousable-minor-mode-extent name))
 446                name)))
 447         (if (setq el (assq toggle minor-mode-alist))
 448             (setcdr el (list hacked-name))
 449           (funcall add-elt
 450                    (list toggle hacked-name)
 451                    'minor-mode-alist))))
 452     (when keymap
 453       (if (setq el (assq toggle minor-mode-map-alist))
 454           (setcdr el keymap)
 455         (funcall add-elt
 456                  (cons toggle keymap)
 457                  'minor-mode-map-alist)))))
 458
 459 ;; #### TODO: Add `:menu-tag' keyword to add-minor-mode.  Or create a
 460 ;; separate function to manage the minor mode menu.
 461
 462 ;(put 'abbrev-mode :menu-tag "Abbreviation Expansion")
 463 (add-minor-mode 'abbrev-mode " Abbrev")
 464 ;; only when visiting a file...
 465 (add-minor-mode 'overwrite-mode 'overwrite-mode)
 466 ;(put 'auto-fill-function :menu-tag "Auto Fill")
 467 (add-minor-mode 'auto-fill-function " Fill" nil nil 'auto-fill-mode)
 468
 469 ;(put 'defining-kbd-macro :menu-tag "Keyboard Macro")
 470 (add-minor-mode 'defining-kbd-macro " Def" nil nil
 471                 (lambda ()
 472                   (interactive)
 473                   (if defining-kbd-macro
 474                       (progn
 475                         ;; #### This means to disregard the last event.
 476                         ;; It is needed because the last recorded
 477                         ;; event is usually the mouse event that
 478                         ;; invoked the menu item (and this function),
 479                         ;; and having it in the macro causes problems.
 480                         (zap-last-kbd-macro-event)
 481                         (end-kbd-macro nil))
 482                     (start-kbd-macro nil))))
 483
 484 (defun modeline-minor-mode-menu (event)
 485   "The menu that pops up when you press `button3' inside the
 486 parentheses on the modeline."
 487   (interactive "e")
 488   (save-excursion
 489     (set-buffer (event-buffer event))
 490     (popup-menu-and-execute-in-window
 491      (cons
 492       "Minor Mode Toggles"
 493       (sort
 494        (delq nil (mapcar
 495                  #'(lambda (x)
 496                      (let* ((toggle-sym (car x))
 497                             (toggle-fun (or (get toggle-sym
 498                                                  'modeline-toggle-function)
 499                                             (and (commandp toggle-sym)
 500                                                  toggle-sym)))
 501                             (menu-tag (symbol-name (if (symbolp toggle-fun)
 502                                                        toggle-fun
 503                                                      toggle-sym))
 504                                       ;; Here a function should
 505                                       ;; maybe be invoked to
 506                                       ;; beautify the symbol's
 507                                       ;; menu appearance.
 508                                       ))
 509                        (and toggle-fun
 510                             (vector menu-tag
 511                                     toggle-fun
 512                                     ;; The following two are wrong
 513                                     ;; because of possible name
 514                                     ;; clashes.
 515                                     ;:active (get toggle-sym :active t)
 516                                     ;:included (get toggle-sym :included t)
 517                                     :style 'toggle
 518                                     :selected (and (boundp toggle-sym)
 519                                                    toggle-sym)))))
 520                  minor-mode-alist))
 521        (lambda (e1 e2)
 522          (string< (aref e1 0) (aref e2 0)))))
 523      event)))
 524
 525 (defvar modeline-minor-mode-map (make-sparse-keymap 'modeline-minor-mode-map)
 526   "Keymap consulted for mouse-clicks on the minor-mode modeline list.")
 527 (define-key modeline-minor-mode-map 'button3 'modeline-minor-mode-menu)
 528
 529 (defvar modeline-minor-mode-extent (make-extent nil nil)
 530   "Extent covering the minor mode modeline strings.")
 531 (set-extent-face modeline-minor-mode-extent 'modeline-mousable)
 532 (set-extent-keymap modeline-minor-mode-extent modeline-minor-mode-map)
 533
 534 \f
 535 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 536 ;;;                              Other                                  ;;;
 537 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 538
 539 (defun modeline-buffers-menu (event)
 540   (interactive "e")
 541   (popup-menu-and-execute-in-window
 542    '("Buffers Popup Menu"
 543      :filter buffers-menu-filter
 544      ["List All Buffers" list-buffers t]
 545      "--"
 546      )
 547    event))
 548
 549 (defvar modeline-buffer-id-left-map
 550   (make-sparse-keymap 'modeline-buffer-id-left-map)
 551 "Keymap consulted for mouse-clicks on the left half of the buffer-id string.")
 552
 553 (defvar modeline-buffer-id-right-map
 554   (make-sparse-keymap 'modeline-buffer-id-right-map)
 555 "Keymap consulted for mouse-clicks on the right half of the buffer-id string.")
 556
 557 (define-key modeline-buffer-id-left-map 'button2 'mouse-unbury-buffer)
 558 (define-key modeline-buffer-id-right-map 'button2 'mouse-bury-buffer)
 559 (define-key modeline-buffer-id-left-map 'button3 'modeline-buffers-menu)
 560 (define-key modeline-buffer-id-right-map 'button3 'modeline-buffers-menu)
 561
 562 (make-face 'modeline-buffer-id
 563            "Face for the buffer ID string in the modeline.")
 564 (set-face-parent 'modeline-buffer-id 'modeline nil '(default))
 565 (when (featurep 'window-system)
 566   (set-face-foreground 'modeline-buffer-id "blue4" nil '(default color win))
 567   (set-face-font 'modeline-buffer-id [bold-italic] nil '(default mono win))
 568   (set-face-font 'modeline-buffer-id [bold-italic] nil '(default grayscale win)))
 569 (when (featurep 'tty)
 570   (set-face-font 'modeline-buffer-id [bold-italic] nil '(default tty)))
 571
 572 (defvar modeline-buffer-id-extent (make-extent nil nil)
 573   "Extent covering the whole of the buffer-id string.")
 574 (set-extent-face modeline-buffer-id-extent 'modeline-buffer-id)
 575
 576 (defvar modeline-buffer-id-left-extent (make-extent nil nil)
 577 "Extent covering the left half of the buffer-id string.")
 578 (set-extent-keymap modeline-buffer-id-left-extent
 579                    modeline-buffer-id-left-map)
 580 (set-extent-property modeline-buffer-id-left-extent 'help-echo
 581                      "button2 cycles to the previous buffer")
 582
 583 (defvar modeline-buffer-id-right-extent (make-extent nil nil)
 584 "Extent covering the right half of the buffer-id string.")
 585 (set-extent-keymap modeline-buffer-id-right-extent
 586                    modeline-buffer-id-right-map)
 587 (set-extent-property modeline-buffer-id-right-extent 'help-echo
 588                      "button2 cycles to the next buffer")
 589
 590 (defconst modeline-buffer-identification
 591   (list (cons modeline-buffer-id-left-extent "XEmacs%N:")
 592                                         ; this used to be "XEmacs:"
 593         (cons modeline-buffer-id-right-extent " %17b"))
 594   "Modeline control for identifying the buffer being displayed.
 595 Its default value is
 596
 597   (list (cons modeline-buffer-id-left-extent \"XEmacs%N:\")
 598         (cons modeline-buffer-id-right-extent \" %17b\")))
 599
 600 Major modes that edit things other than ordinary files may change this
 601 (e.g. Info, Dired,...).")
 602 (make-variable-buffer-local 'modeline-buffer-identification)
 603
 604 ;; These are for the sake of minor mode menu.  #### All of this is
 605 ;; kind of dirty.  `add-minor-mode' started out as a simple substitute
 606 ;; for (or (assq ...) ...) FSF stuff, but now is used for all kind of
 607 ;; stuff.  There should perhaps be a separate function to add toggles
 608 ;; to the minor-mode-menu.
 609 (add-minor-mode 'line-number-mode "")
 610 (add-minor-mode 'column-number-mode "")
 611
 612 (defconst modeline-process nil
 613   "Modeline control for displaying info on process status.
 614 Normally nil in most modes, since there is no process to display.")
 615 (make-variable-buffer-local 'modeline-process)
 616
 617 (defvar modeline-modified-map (make-sparse-keymap 'modeline-modified-map)
 618   "Keymap consulted for mouse-clicks on the modeline-modified string.")
 619 (define-key modeline-modified-map 'button2
 620   (make-modeline-command-wrapper 'modeline-toggle-read-only))
 621
 622 (defvar modeline-modified-extent (make-extent nil nil)
 623   "Extent covering the modeline-modified string.")
 624 (set-extent-face modeline-modified-extent 'modeline-mousable)
 625 (set-extent-keymap modeline-modified-extent modeline-modified-map)
 626 (set-extent-property modeline-modified-extent 'help-echo
 627                      "button2 toggles the buffer's read-only status")
 628
 629 (defconst modeline-modified '("--%1*%1+-")
 630   "Modeline control for displaying whether current buffer is modified.")
 631 (make-variable-buffer-local 'modeline-modified)
 632
 633 (defvar modeline-narrowed-map (make-sparse-keymap 'modeline-narrowed-map)
 634   "Keymap consulted for mouse-clicks on the modeline-narrowed string.")
 635 (define-key modeline-narrowed-map 'button2
 636   (make-modeline-command-wrapper 'widen))
 637
 638 (defvar modeline-narrowed-extent (make-extent nil nil)
 639   "Extent covering the modeline-narrowed string.")
 640 (set-extent-face modeline-narrowed-extent 'modeline-mousable)
 641 (set-extent-keymap modeline-narrowed-extent modeline-narrowed-map)
 642 (set-extent-property modeline-narrowed-extent 'help-echo
 643                      "button2 widens the buffer")
 644
 645 (setq-default
 646  modeline-format
 647  (list
 648   ""
 649   (cons modeline-modified-extent 'modeline-modified)
 650   (cons modeline-buffer-id-extent 'modeline-buffer-identification)
 651   "   "
 652   'global-mode-string
 653   "   %[("
 654   (cons modeline-minor-mode-extent
 655         (list "" 'mode-name 'minor-mode-alist))
 656   (cons modeline-narrowed-extent "%n")
 657   'modeline-process
 658   ")%]----"
 659   (list 'line-number-mode "L%l--")
 660   (list 'column-number-mode "C%c--")
 661   (cons -3 "%p")
 662   "-%-"))
 663
 664 ;;; Added for XEmacs 20.3.  Provide wrapper for vc since it may not always be
 665 ;;; present, and its symbols are not visible this early in the dump if it
 666 ;;; is.
 667
 668 (defun modeline-toggle-read-only ()
 669   "Change whether this buffer is visiting its file read-only.
 670 With arg, set read-only iff arg is positive.
 671 This function is designed to be called when the read-only indicator on the
 672 modeline is clicked.  It will call `vc-toggle-read-only' if available,
 673 otherwise it will call the usual `toggle-read-only'."
 674   (interactive)
 675   (if (fboundp 'vc-toggle-read-only)
 676       (vc-toggle-read-only)
 677     (toggle-read-only)))
 678
 679 ;;; modeline.el ends here