Mercurial > hg > xemacs-beta

comparison lisp/utils/floating-toolbar.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents 8fc7fe29b841
children c53a95d3c46d
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
1 ;;; floating-toolbar.el -- popup toolbar support for XEmacs.
2 ;; Copyright (C) 1997 Kyle E. Jones
3
4 ;; Author: Kyle Jones <kyle_jones@wonderworks.com>
5 ;; Keywords: lisp
6
7 ;; This file is part of XEmacs.
8
9 ;; XEmacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 1, or (at your option)
12 ;; any later version.
13
14 ;; XEmacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
18
19 ;; A copy of the GNU General Public License can be obtained from this
20 ;; program's author (send electronic mail to kyle@uunet.uu.net) or from
21 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
23
24 ;;; Commentary:
25
26 ;; Popup toolbar for XEmacs (probably require XEmacs 19.14 or later)
27 ;; Send bug reports to kyle_jones@wonderworks.com
28
29 ;; The command `floating-toolbar' pops up a small frame
30 ;; containing a toolbar. The command should be bound to a
31 ;; button-press event. If the mouse press happens over an
32 ;; extent that has a non-nil 'floating-toolbar property, the
33 ;; value of that property is the toolbar instantiator that will
34 ;; be displayed. Otherwise the toolbar displayed is taken from
35 ;; the variable `floating-toolbar'. This variable can be made
36 ;; buffer local to produce buffer local floating toolbars.
37 ;;
38 ;; `floating-toolbar-or-popup-mode-menu' works like `floating-toolbar'
39 ;; except that if no toolbar is found, `popup-mode-menu' is called.
40 ;;
41 ;; `floating-toolbar-from-extent-or-popup-mode-menu' works like
42 ;; `floating-toolbar-or-popup-mode-menu' except only extent local
43 ;; toolbars are used; the value of floating-toolbar is not used.
44 ;;
45 ;; Installation:
46 ;;
47 ;; Byte-compile the file floating-toolbar.el (with M-x byte-compile-file)
48 ;; and put the .elc file in a directory in your load-path. Add the
49 ;; following line to your .emacs:
50 ;;
51 ;; (require 'floating-toolbar)
52 ;;
53 ;; You will also need to bind a mouse click to `floating-toolbar' or to
54 ;; `floating-toolbar-or-popup-mode-menu'.
55 ;;
56 ;; For 19.12 users:
57 ;; If you are using fvwm, [tv]twm or ol[v]wm, you can also add
58 ;; the following lines to various configuration file to use
59 ;; minimal decorations on the toolbar frame.
60 ;;
61 ;; In .emacs:
62 ;; (setq floating-toolbar-frame-name "floating-toolbar")
63 ;;
64 ;; For ol[v]wm use this in .Xdefaults:
65 ;; olvwm.NoDecor: floating-toolbar
66 ;; or
67 ;; olwm.MinimalDecor: floating-toolbar
68 ;;
69 ;; For fvvm use this in your .fvwmrc:
70 ;; NoTitle floating-toolbar
71 ;; or
72 ;; Style "floating-toolbar" NoTitle, NoHandles, BorderWidth 0
73 ;;
74 ;; For twm use this in your .twmrc:
75 ;; NoTitle { "floating-toolbar" }
76 ;;
77 ;; Under 19.13 and later versions the floating-toolbar frame uses a
78 ;; transient window that is not normally decorated by window
79 ;; managers. So the window manager directives should not be
80 ;; needed for XEmacs 19.13 and beyond.
81
82 ;;; Code:
83
84 (provide 'floating-toolbar)
85
86 (require 'toolbar)
87 (require 'x)
88
89 (defvar floating-toolbar-version "1.01"
90 "Version string for the floating-toolbar package.")
91
92 (defvar floating-toolbar-use-sound nil
93 "*Non-nil value means play a sound to herald the appearance
94 and disappearance of the floating toolbar.
95
96 `floating-toolbar-appears' will be played when the toolbar appears.
97 `floating-toolbar-disappears' will be played when the toolbar disappears.
98
99 See the documentation for the function `load-sound-file' to see how
100 define sounds.")
101
102 (defvar floating-toolbar nil
103 "*Toolbar instantiator used if mouse event is not over an extent
104 with a non-nil 'floating-toolbar property. This variable can be
105 made local to a buffer to have buffer local floating toolbars.")
106
107 (defvar floating-toolbar-help-font nil
108 "*Non-nil value should be a font to be used to display toolbar help
109 messages. The floating toolbar frame will have a minibuffer window
110 so that it can display any help text that is attached to the toolbar
111 buttons.")
112
113 (defvar floating-toolbar-frame-name nil
114 "*The frame name for the frame used to display the floating toolbar.")
115
116 ;;;
117 ;;; End of user variables.
118 ;;;
119
120 (defvar floating-toolbar-frame nil
121 "The floating toolbar is displayed in this frame.")
122
123 (defvar floating-toolbar-display-pending nil
124 "Non-nil value means the toolbar frame will be visible as soon
125 as the X server gets around to displaying it. Nil means it
126 will be invisible as soon as the X server decides to hide it.")
127
128 (defun floating-toolbar-displayed ()
129 (and (frame-live-p floating-toolbar-frame)
130 (frame-visible-p floating-toolbar-frame)))
131
132 ;;;###autoload
133 (defun floating-toolbar (event &optional extent-local-only)
134 "Popup a toolbar near the current mouse position.
135 The toolbar instantiator used is taken from the 'floating-toolbar
136 property of any extent under the mouse. If no such non-nil
137 property exists for any extent under the mouse, then the value of the
138 variable `floating-toolbar' is checked. If its value si nil, then
139 no toolbar will be displayed.
140
141 This command should be bound to a button press event.
142
143 When called from a program, first arg EVENT should be the button
144 press event. Optional second arg EXTENT-LOCAL-ONLY specifies
145 that only extent local toolbars should be used; this means the
146 `floating-toolbar' variable will not be consulted."
147 (interactive "_e")
148 (if (not (mouse-event-p event))
149 nil
150 (let* ((buffer (event-buffer event))
151 (window (event-window event))
152 (frame (event-frame event))
153 (point (and buffer (event-point event)))
154 (glyph-extent (event-glyph-extent event))
155 (glyph-extent (if (and glyph-extent
156 (extent-property glyph-extent
157 'floating-toolbar))
158 glyph-extent))
159 (extent (or glyph-extent
160 (and point
161 (extent-at point buffer 'floating-toolbar))))
162 (toolbar (or (and extent (get extent 'floating-toolbar))
163 (and (not extent-local-only)
164 (symbol-value-in-buffer 'floating-toolbar
165 buffer nil))))
166 (x nil)
167 (y nil)
168 (echo-keystrokes 0)
169 (awaiting-release t)
170 (done nil))
171 (if (not (consp toolbar))
172 nil
173 ;; event-[xy]-pixel are relative to the top left corner
174 ;; of the frame. The presence of top and left toolbar
175 ;; and the menubar can move this position down and
176 ;; leftward, but XEmacs doesn't compensate for this in
177 ;; the values returned. So we do it here, as best we
178 ;; can.
179 (let* ((params (frame-parameters frame))
180 (top (cdr (assq 'top params)))
181 (left (cdr (assq 'left params)))
182 (xtop-toolbar-height
183 (if (specifier-instance top-toolbar)
184 (specifier-instance top-toolbar-height)
185 0))
186 (xleft-toolbar-width
187 (if (specifier-instance left-toolbar)
188 (specifier-instance left-toolbar-width)
189 0))
190 ;; better than nothing
191 (menubar-height (if current-menubar 22 0)))
192 (setq x (+ left xleft-toolbar-width (event-x-pixel event))
193 y (+ top xtop-toolbar-height menubar-height
194 (event-y-pixel event))))
195 ;; for toolbar spec buffer local variable values
196 (and buffer (set-buffer buffer))
197 (floating-toolbar-display-toolbar toolbar x y)
198 (while (not done)
199 (setq event (next-command-event))
200 (cond ((and awaiting-release (button-release-event-p event))
201 (setq awaiting-release nil))
202 ((and (button-release-event-p event)
203 (event-over-toolbar-p event)
204 (eq floating-toolbar-frame (event-frame event)))
205 (floating-toolbar-undisplay-toolbar)
206 (and window (select-frame (window-frame window)))
207 (and window (select-window window))
208 (dispatch-event event)
209 (setq done t))
210 ((and (button-press-event-p event)
211 (event-over-toolbar-p event)
212 (eq floating-toolbar-frame (event-frame event)))
213 (setq awaiting-release nil)
214 (dispatch-event event))
215 (t
216 ;; push back the event if it was in another frame.
217 ;; eat it if it was in the toolbar frame.
218 (if (and (event-frame event)
219 (not (eq floating-toolbar-frame
220 (event-frame event))))
221 (setq unread-command-events
222 (cons event unread-command-events)))
223 (floating-toolbar-undisplay-toolbar)
224 (setq done t))))
225 t ))))
226
227 ;;;###autoload
228 (defun floating-toolbar-or-popup-mode-menu (event)
229 "Like floating-toolbar, but if no toolbar is displayed
230 run popup-mode-menu."
231 (interactive "_e")
232 (or (floating-toolbar event) (popup-mode-menu)))
233
234 ;;;###autoload
235 (defun floating-toolbar-from-extent-or-popup-mode-menu (event)
236 "Like floating-toolbar-or-popup-mode-menu, but search only for an
237 extent local toolbar."
238 (interactive "_e")
239 (or (floating-toolbar event t) (popup-mode-menu)))
240
241 (defun floating-toolbar-display-toolbar (toolbar x y)
242 (if (not (frame-live-p floating-toolbar-frame))
243 (setq floating-toolbar-frame (floating-toolbar-make-toolbar-frame x y)))
244 (set-specifier top-toolbar
245 (cons (window-buffer
246 (frame-selected-window floating-toolbar-frame))
247 toolbar))
248 (floating-toolbar-resize-toolbar-frame toolbar)
249 ;; fiddle with the x value to try to center the toolbar relative to
250 ;; the mouse position.
251 (setq x (max 0 (- x (/ (frame-pixel-width floating-toolbar-frame) 2))))
252 (floating-toolbar-set-toolbar-frame-position x y)
253 (floating-toolbar-expose-toolbar-frame))
254
255 (defun floating-toolbar-undisplay-toolbar ()
256 (floating-toolbar-hide-toolbar-frame))
257
258 (defun floating-toolbar-hide-toolbar-frame ()
259 (if (floating-toolbar-displayed)
260 (progn
261 (make-frame-invisible floating-toolbar-frame)
262 (if (and floating-toolbar-use-sound floating-toolbar-display-pending)
263 (play-sound 'floating-toolbar-disappears))
264 (setq floating-toolbar-display-pending nil))))
265
266 (defun floating-toolbar-expose-toolbar-frame ()
267 (if (not (floating-toolbar-displayed))
268 (progn
269 (make-frame-visible floating-toolbar-frame)
270 (if (and floating-toolbar-use-sound
271 (null floating-toolbar-display-pending))
272 (play-sound 'floating-toolbar-appears))
273 (setq floating-toolbar-display-pending t))))
274
275 (defun floating-toolbar-resize-toolbar-frame (toolbar)
276 (let ((width 0)
277 (height nil)
278 (bevel (* 2 (or (cdr (assq 'toolbar-shadow-thickness (frame-parameters)))
279 0)))
280 (captioned (specifier-instance toolbar-buttons-captioned-p))
281 button glyph glyph-list)
282 (while toolbar
283 (setq button (car toolbar))
284 (cond ((null button)
285 (setq width (+ width 8)))
286 ((eq (elt button 0) ':size)
287 (setq width (+ width (elt button 1))))
288 ((and (eq (elt button 0) ':style)
289 (= (length button) 4)
290 (eq (elt button 2) ':size))
291 (setq width (+ width bevel (elt button 3))))
292 (t
293 (setq glyph-list (elt button 0))
294 (if (symbolp glyph-list)
295 (setq glyph-list (symbol-value glyph-list)))
296 (if (and captioned (> (length glyph-list) 3))
297 (setq glyph (or (nth 3 glyph-list)
298 (nth 4 glyph-list)
299 (nth 5 glyph-list)))
300 (setq glyph (car glyph-list)))
301 (setq width (+ width bevel (glyph-width glyph)))
302 (or height (setq height (+ bevel (glyph-height glyph))))))
303 (setq toolbar (cdr toolbar)))
304 (set-specifier top-toolbar-height height floating-toolbar-frame)
305 (set-frame-width floating-toolbar-frame
306 (1+ (/ width (font-width (face-font 'default)
307 floating-toolbar-frame))))))
308
309 (defun floating-toolbar-set-toolbar-frame-position (x y)
310 (set-frame-position floating-toolbar-frame x y))
311
312 (defun floating-toolbar-make-junk-frame ()
313 (let ((window-min-height 1)
314 (window-min-width 1))
315 (make-frame '(minibuffer t initially-unmapped t width 1 height 1))))
316
317 (defun floating-toolbar-make-toolbar-frame (x y)
318 (save-excursion
319 (let ((window-min-height 1)
320 (window-min-width 1)
321 (bg-color (or (x-get-resource "backgroundToolBarColor"
322 "BackgroundToolBarColor"
323 'string
324 'global
325 (selected-device)
326 t)
327 "grey75"))
328 (buffer (get-buffer-create " *floating-toolbar-buffer*"))
329 (frame nil))
330 (set-buffer buffer)
331 (set-buffer-menubar nil)
332 (if floating-toolbar-help-font
333 (progn (set-buffer (window-buffer (minibuffer-window)))
334 (set-buffer-menubar nil)))
335 (setq frame (make-frame (list
336 '(initially-unmapped . t)
337 ;; try to evade frame decorations
338 (cons 'name (or floating-toolbar-frame-name
339 "xclock"))
340 '(border-width . 2)
341 (cons 'border-color bg-color)
342 (cons 'top y)
343 (cons 'left x)
344 (cons 'popup
345 (floating-toolbar-make-junk-frame))
346 (if floating-toolbar-help-font
347 '(minibuffer . only)
348 '(minibuffer . nil))
349 '(width . 3)
350 '(height . 1))))
351 (set-specifier text-cursor-visible-p (cons frame nil))
352 (if floating-toolbar-help-font
353 (set-face-font 'default floating-toolbar-help-font frame)
354 (set-face-font 'default "nil2" frame))
355 (set-face-background 'default bg-color frame)
356 (set-face-background 'modeline bg-color frame)
357 (set-specifier modeline-shadow-thickness (cons frame 1))
358 (set-specifier has-modeline-p (cons frame nil))
359 (set-face-background-pixmap 'default "" frame)
360 (set-window-buffer (frame-selected-window frame) buffer)
361 (set-specifier top-toolbar-height (cons frame 0))
362 (set-specifier left-toolbar-width (cons frame 0))
363 (set-specifier right-toolbar-width (cons frame 0))
364 (set-specifier bottom-toolbar-height (cons frame 0))
365 (set-specifier top-toolbar (cons frame nil))
366 (set-specifier left-toolbar (cons frame nil))
367 (set-specifier right-toolbar (cons frame nil))
368 (set-specifier bottom-toolbar (cons frame nil))
369 (set-specifier scrollbar-width (cons frame 0))
370 (set-specifier scrollbar-height (cons frame 0))
371 frame )))
372
373 ;; first popup should be faster if we go ahead and make the frame now.
374 (or floating-toolbar-frame
375 (not (eq (device-type) 'x))
376 (setq floating-toolbar-frame (floating-toolbar-make-toolbar-frame 0 0)))
377
378 ;;; floating-toolbar.el ends here