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