|
22
|
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
|
