Mercurial > hg > xemacs-beta

comparison lisp/prim/modeline.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; modeline.el --- modeline hackery.
2
3 ;; Copyright (C) 1988, 1992, 1993, 1994 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995, 1996 Ben Wing.
5
6 ;; This file is part of XEmacs.
7
8 ;; XEmacs is free software; you can redistribute it and/or modify it
9 ;; under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2, or (at your option)
11 ;; any later version.
12
13 ;; XEmacs is distributed in the hope that it will be useful, but
14 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;; General Public License for more details.
17
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with XEmacs; see the file COPYING. If not, write to the Free
20 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
21
22 ;;; Synched up with: Not in FSF.
23
24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25 ;;; General mouse modeline stuff ;;;
26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27
28 (defvar drag-modeline-event-lag 150
29 "*The amount of time to wait (in msecs) between drag modeline events
30 before updating the display. If this value is too small, dragging will
31 be choppy because redisplay cannot keep up. If it is too large, dragging
32 will be choppy because of the explicit redisplay delay specified.")
33
34 (defvar modeline-click-swaps-buffers nil
35 "*If non-nil, clicking on the modeline changes the current buffer.
36 Click on the left half of the modeline cycles forward through the
37 buffer list and clicking on the right half cycles backward.")
38
39 (defun mouse-drag-modeline (event)
40 "Resize the window by dragging the modeline.
41 This should be bound to a mouse button in `modeline-map'."
42 (interactive "e")
43 (or (button-press-event-p event)
44 (error "%s must be invoked by a mouse-press" this-command))
45 (or (event-over-modeline-p event)
46 (error "not over a modeline"))
47 (let ((depress-line (event-y event))
48 (mouse-down t)
49 (window (event-window event))
50 (old-window (selected-window))
51 (def-line-height (face-height 'default))
52 (prior-drag-modeline-event-time 0)
53 delta)
54 (while mouse-down
55 (setq event (next-event event))
56 (cond ((motion-event-p event)
57 (if (window-lowest-p window)
58 (error "can't drag bottommost modeline"))
59 (cond ((> (- (event-timestamp event)
60 prior-drag-modeline-event-time)
61 drag-modeline-event-lag)
62
63 (setq prior-drag-modeline-event-time (event-timestamp event))
64
65 (if (event-over-modeline-p event)
66 (setq delta 0)
67 (setq delta (- (event-y-pixel event)
68 (nth 3 (window-pixel-edges window))))
69 (if (> delta 0)
70 (setq delta (+ delta def-line-height)))
71 (setq delta (/ delta def-line-height)))
72
73 ;; cough sputter hack kludge. It shouldn't be possible
74 ;; to get in here when we are over the minibuffer. But
75 ;; it is happening and that cause next-vertical-window to
76 ;; return nil which does not lead to window-height returning
77 ;; anything remotely resembling a sensible value. So catch
78 ;; the situation and die a happy death.
79 ;;
80 ;; Oh, and the BLAT FOOP error messages suck as well but
81 ;; I don't know what should be there. This should be
82 ;; looked at again when the new redisplay is done.
83 (if (not (next-vertical-window window))
84 (error "Try again: dragging in minibuffer does nothing"))
85 (cond ((and (> delta 0)
86 (<= (- (window-height (next-vertical-window window))
87 delta)
88 window-min-height))
89 (setq delta (- (window-height
90 (next-vertical-window window))
91 window-min-height))
92 (if (< delta 0) (error "BLAT")))
93 ((and (< delta 0)
94 (< (+ (window-height window) delta)
95 window-min-height))
96 (setq delta (- window-min-height
97 (window-height window)))
98 (if (> delta 0) (error "FOOP"))))
99 (if (= delta 0)
100 nil
101 (select-window window)
102 (enlarge-window delta)
103 ;; The call to enlarge-window may have caused the old
104 ;; window to disappear. Don't try and select it in
105 ;; that case.
106 (if (window-live-p old-window)
107 (select-window old-window))
108 (sit-for 0)
109 ))))
110 ((button-release-event-p event)
111 (setq mouse-down nil)
112 (if modeline-click-swaps-buffers
113 (mouse-release-modeline event depress-line)))
114 ((or (button-press-event-p event)
115 (key-press-event-p event))
116 (error ""))
117 (t
118 (dispatch-event event)))
119 )))
120
121 ;; from Bob Weiner (bob_weiner@pts.mot.com)
122 (defun mouse-release-modeline (event line-num)
123 "Handle modeline click EVENT on LINE-NUM by switching buffers.
124 If click on left half of a frame's modeline, bury current buffer.
125 If click on right half of a frame's modeline, raise bottommost buffer.
126 Args are: EVENT, the mouse release event, and LINE-NUM, the line number
127 within the frame at which the mouse was first depressed."
128 (if (= line-num (event-y event))
129 ;; Button press and release are at same line, treat this as
130 ;; a click and switch buffers.
131 (if (< (event-x event) (/ (window-width (event-window event)) 2))
132 ;; On left half of modeline, bury current buffer,
133 ;; displaying second buffer on list.
134 (mouse-bury-buffer event)
135 ;; On right half of modeline, raise and display bottommost
136 ;; buffer in buffer list.
137 (mouse-unbury-buffer event))))
138
139 (defconst modeline-menu
140 '("Window Commands"
141 ["Delete Window Above" delete-window t]
142 ["Delete Other Windows" delete-other-windows t]
143 ["Split Window Above" split-window-vertically t]
144 ["Split Window Horizontally" split-window-horizontally t]
145 ["Balance Windows" balance-windows t]
146 ))
147
148 (defun modeline-menu (event)
149 (interactive "e")
150 (popup-menu-and-execute-in-window
151 (cons (format "Window Commands for %S:"
152 (buffer-name (event-buffer event)))
153 (cdr modeline-menu))
154 event))
155
156 (defvar modeline-map (make-sparse-keymap 'modeline-map)
157 "Keymap consulted for mouse-clicks on the modeline of a window.
158 This variable may be buffer-local; its value will be looked up in
159 the buffer of the window whose modeline was clicked upon.")
160
161 (define-key modeline-map 'button1 'mouse-drag-modeline)
162 ;; button2 selects the window without setting point
163 (define-key modeline-map 'button2 (lambda () (interactive "@")))
164 (define-key modeline-map 'button3 'modeline-menu)
165
166 (make-face 'modeline-mousable "Face for mousable portions of the modeline.")
167
168 (defmacro make-modeline-command-wrapper (command)
169 `#'(lambda (event)
170 (interactive "e")
171 (save-selected-window
172 (select-window (event-window event))
173 (call-interactively ',(eval command)))))
174
175 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
176 ;;; Minor modes ;;;
177 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
178
179 (defvar minor-mode-alist nil
180 "Alist saying how to show minor modes in the modeline.
181 Each element looks like (VARIABLE STRING);
182 STRING is included in the modeline iff VARIABLE's value is non-nil.
183
184 Actually, STRING need not be a string; any possible modeline element
185 is okay. See `modeline-format'.")
186
187 ;; Used by C code (lookup-key and friends) but defined here.
188 (defvar minor-mode-map-alist nil
189 "Alist of keymaps to use for minor modes.
190 Each element looks like (VARIABLE . KEYMAP); KEYMAP is used to read
191 key sequences and look up bindings iff VARIABLE's value is non-nil.
192 If two active keymaps bind the same key, the keymap appearing earlier
193 in the list takes precedence.")
194
195 (make-face 'modeline-mousable-minor-mode
196 "Face for mousable minor-mode strings in the modeline.")
197
198 (defvar modeline-mousable-minor-mode-extent (make-extent nil nil)
199 ;; alliteration at its finest.
200 "Extent managing the mousable minor mode modeline strings.")
201 (set-extent-face modeline-mousable-minor-mode-extent
202 'modeline-mousable-minor-mode)
203
204 ;; This replaces the idiom
205 ;;
206 ;; (or (assq 'isearch-mode minor-mode-alist)
207 ;; (setq minor-mode-alist
208 ;; (purecopy
209 ;; (append minor-mode-alist
210 ;; '((isearch-mode isearch-mode))))))
211
212 (defun add-minor-mode (toggle name &optional keymap after toggle-fun)
213 "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'.
214 TOGGLE is a symbol whose value as a variable specifies whether the
215 minor mode is active. NAME is the name that should appear in the
216 modeline (it should be a string beginning with a space). KEYMAP is a
217 keymap to make active when the minor mode is active. AFTER is the
218 toggling symbol used for another minor mode. If AFTER is non-nil,
219 then it is used to position the new mode in the minor-mode alists.
220 TOGGLE-FUN specifies an interactive function that is called to toggle
221 the mode on and off; this affects what happens when button2 is pressed
222 on the mode, and when button3 is pressed somewhere in the list of
223 modes. If TOGGLE-FUN is nil and TOGGLE names an interactive function,
224 TOGGLE is used as the toggle function.
225
226 Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map)"
227 (let (el place
228 (add-elt #'(lambda (elt sym)
229 (cond ((null after) ; add to front
230 (set sym (cons elt (symbol-value sym))))
231 ((and (not (eq after t))
232 (setq place (memq (assq after
233 (symbol-value sym))
234 (symbol-value sym))))
235 (setq elt (cons elt (cdr place)))
236 (setcdr place elt))
237 (t
238 (set sym (append (symbol-value sym) (list elt))))
239 )
240 (symbol-value sym)))
241 toggle-keymap)
242 (if toggle-fun
243 (if (not (commandp toggle-fun))
244 (error "not an interactive function: %S" toggle-fun))
245 (if (commandp toggle)
246 (setq toggle-fun toggle)))
247 (if (and toggle-fun name)
248 (progn
249 (setq toggle-keymap (make-sparse-keymap
250 (intern (concat "modeline-minor-"
251 (symbol-name toggle)
252 "-map"))))
253 (define-key toggle-keymap 'button2
254 ;; defeat the DUMB-ASS byte-compiler, which tries to
255 ;; expand the macro at compile time and fucks up.
256 (eval '(make-modeline-command-wrapper toggle-fun)))
257 (put toggle 'modeline-toggle-function toggle-fun)))
258 (and name
259 (let ((hacked-name
260 (if toggle-keymap
261 (cons (let ((extent (make-extent nil nil)))
262 (set-extent-keymap extent toggle-keymap)
263 (set-extent-property
264 extent 'help-echo
265 (concat "button2 turns off "
266 (if (symbolp toggle-fun)
267 (symbol-name toggle-fun)
268 (symbol-name toggle))))
269 extent)
270 (cons
271 modeline-mousable-minor-mode-extent
272 name))
273 name)))
274 (if (setq el (assq toggle minor-mode-alist))
275 (setcdr el (list hacked-name))
276 (funcall add-elt
277 (list toggle hacked-name)
278 'minor-mode-alist))))
279 (and keymap
280 (if (setq el (assq toggle minor-mode-map-alist))
281 (setcdr el keymap)
282 (funcall add-elt
283 (cons toggle keymap)
284 'minor-mode-map-alist)))
285 ))
286
287 (add-minor-mode 'abbrev-mode " Abbrev")
288 (add-minor-mode 'overwrite-mode 'overwrite-mode)
289 (add-minor-mode 'auto-fill-function " Fill" nil nil 'auto-fill-mode)
290 ;; not really a minor mode...
291 (add-minor-mode 'defining-kbd-macro " Def")
292
293 (defun modeline-minor-mode-menu (event)
294 (interactive "e")
295 (popup-menu-and-execute-in-window
296 (cons (format "Minor Mode Commands for %S:"
297 (buffer-name (event-buffer event)))
298 (apply 'nconc
299 (mapcar
300 #'(lambda (x)
301 (let* ((toggle-sym (car x))
302 (toggle-fun
303 (or (get toggle-sym
304 'modeline-toggle-function)
305 (and (fboundp toggle-sym)
306 (commandp toggle-sym)
307 toggle-sym))))
308 (if (not toggle-fun) nil
309 (list (vector
310 (concat (if (and (boundp toggle-sym)
311 (symbol-value toggle-sym))
312 "turn off " "turn on ")
313 (if (symbolp toggle-fun)
314 (symbol-name toggle-fun)
315 (symbol-name toggle-sym)))
316
317 toggle-fun
318 t)))))
319 minor-mode-alist)))
320 event))
321
322 (defvar modeline-minor-mode-map (make-sparse-keymap 'modeline-minor-mode-map)
323 "Keymap consulted for mouse-clicks on the minor-mode modeline list.")
324 (define-key modeline-minor-mode-map 'button3 'modeline-minor-mode-menu)
325
326 (defvar modeline-minor-mode-extent (make-extent nil nil)
327 "Extent covering the minor mode modeline strings.")
328 (set-extent-face modeline-minor-mode-extent 'modeline-mousable)
329 (set-extent-keymap modeline-minor-mode-extent modeline-minor-mode-map)
330
331
332 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
333 ;;; Other ;;;
334 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
335
336 (defun modeline-buffers-menu (event)
337 (interactive "e")
338 (popup-menu-and-execute-in-window
339 '("Buffers Popup Menu"
340 :filter buffers-menu-filter
341 ["List All Buffers" list-buffers t]
342 "--"
343 )
344 event))
345
346 (defvar modeline-buffer-id-left-map
347 (make-sparse-keymap 'modeline-buffer-id-left-map)
348 "Keymap consulted for mouse-clicks on the left half of the buffer-id string.")
349
350 (defvar modeline-buffer-id-right-map
351 (make-sparse-keymap 'modeline-buffer-id-right-map)
352 "Keymap consulted for mouse-clicks on the right half of the buffer-id string.")
353
354 (define-key modeline-buffer-id-left-map 'button2 'mouse-unbury-buffer)
355 (define-key modeline-buffer-id-right-map 'button2 'mouse-bury-buffer)
356 (define-key modeline-buffer-id-left-map 'button3 'modeline-buffers-menu)
357 (define-key modeline-buffer-id-right-map 'button3 'modeline-buffers-menu)
358
359 (make-face 'modeline-buffer-id
360 "Face for the buffer ID string in the modeline.")
361
362 (defvar modeline-buffer-id-extent (make-extent nil nil)
363 "Extent covering the whole of the buffer-id string.")
364 (set-extent-face modeline-buffer-id-extent 'modeline-buffer-id)
365
366 (defvar modeline-buffer-id-left-extent (make-extent nil nil)
367 "Extent covering the left half of the buffer-id string.")
368 (set-extent-keymap modeline-buffer-id-left-extent
369 modeline-buffer-id-left-map)
370 (set-extent-property modeline-buffer-id-left-extent 'help-echo
371 "button2 cycles to the previous buffer")
372
373 (defvar modeline-buffer-id-right-extent (make-extent nil nil)
374 "Extent covering the right half of the buffer-id string.")
375 (set-extent-keymap modeline-buffer-id-right-extent
376 modeline-buffer-id-right-map)
377 (set-extent-property modeline-buffer-id-right-extent 'help-echo
378 "button2 cycles to the next buffer")
379
380 (defconst modeline-buffer-identification
381 (list (cons modeline-buffer-id-left-extent (purecopy "XEmacs:"))
382 (cons modeline-buffer-id-right-extent (purecopy " %17b")))
383 "Modeline control for identifying the buffer being displayed.
384 Its default value is \"XEmacs: %17b\" (NOT!). Major modes that edit things
385 other than ordinary files may change this (e.g. Info, Dired,...)")
386 (make-variable-buffer-local 'modeline-buffer-identification)
387
388 (defconst modeline-process nil
389 "Modeline control for displaying info on process status.
390 Normally nil in most modes, since there is no process to display.")
391 (make-variable-buffer-local 'modeline-process)
392
393 (defvar modeline-modified-map (make-sparse-keymap 'modeline-modified-map)
394 "Keymap consulted for mouse-clicks on the modeline-modified string.")
395 (define-key modeline-modified-map 'button2
396 (make-modeline-command-wrapper 'toggle-read-only))
397
398 (defvar modeline-modified-extent (make-extent nil nil)
399 "Extent covering the modeline-modified string.")
400 (set-extent-face modeline-modified-extent 'modeline-mousable)
401 (set-extent-keymap modeline-modified-extent modeline-modified-map)
402 (set-extent-property modeline-modified-extent 'help-echo
403 "button2 toggles the buffer's read-only status")
404
405 (defconst modeline-modified (purecopy '("--%1*%1+-"))
406 "Modeline control for displaying whether current buffer is modified.")
407 (make-variable-buffer-local 'modeline-modified)
408
409 (defvar modeline-narrowed-map (make-sparse-keymap 'modeline-narrowed-map)
410 "Keymap consulted for mouse-clicks on the modeline-narrowed string.")
411 (define-key modeline-narrowed-map 'button2
412 (make-modeline-command-wrapper 'widen))
413
414 (defvar modeline-narrowed-extent (make-extent nil nil)
415 "Extent covering the modeline-narrowed string.")
416 (set-extent-face modeline-narrowed-extent 'modeline-mousable)
417 (set-extent-keymap modeline-narrowed-extent modeline-narrowed-map)
418 (set-extent-property modeline-narrowed-extent 'help-echo
419 "button2 widens the buffer")
420
421 (setq-default modeline-format
422 (list (purecopy "")
423 (cons modeline-modified-extent
424 'modeline-modified)
425 (cons modeline-buffer-id-extent
426 'modeline-buffer-identification)
427 (purecopy " ")
428 'global-mode-string
429 (purecopy " %[(")
430 (cons modeline-minor-mode-extent
431 (list "" 'mode-name 'minor-mode-alist))
432 (cons modeline-narrowed-extent "%n")
433 'modeline-process
434 (purecopy ")%]----")
435 (purecopy '(line-number-mode "L%l--"))
436 (purecopy '(-3 . "%p"))
437 (purecopy "-%-")))