Mercurial > hg > xemacs-beta

comparison lisp/packages/balloon-help.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 8fc7fe29b841
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; Balloon help for XEmacs (requires 19.12 or later)
2 ;;; Copyright (C) 1995 Kyle E. Jones
3 ;;;
4 ;;; This program is free software; you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation; either version 1, or (at your option)
7 ;;; any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;;; GNU General Public License for more details.
13 ;;;
14 ;;; A copy of the GNU General Public License can be obtained from this
15 ;;; program's author (send electronic mail to kyle@uunet.uu.net) or from
16 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
17 ;;; 02139, USA.
18 ;;;
19 ;;; Send bug reports to kyle@wonderworks.com
20
21 ;;; Synched up with: Not in FSF.
22
23 ;; Balloon help pops up a small frame to display help text
24 ;; relating to objects that the mouse cursor passes over.
25 ;;
26 ;; Installation:
27 ;;
28 ;; Byte-compile the file balloon-help.el (with M-x byte-compile-file)
29 ;; and put the .elc file in a directory in your load-path. Add the
30 ;; following line to your .emacs:
31 ;;
32 ;; (require 'balloon-help)
33 ;;
34 ;; For 19.12 users:
35 ;; If you are using fvwm, [tv]twm or ol[v]wm, you can also add
36 ;; the following lines to various configuration file to use
37 ;; minimal decorations on the balloon help frames.
38 ;;
39 ;; In .emacs:
40 ;; (setq balloon-help-frame-name "balloon-help")
41 ;;
42 ;; For ol[v]wm use this in .Xdefaults:
43 ;; olvwm.NoDecor: balloon-help
44 ;; or
45 ;; olwm.MinimalDecor: balloon-help
46 ;;
47 ;; For fvvm use this in your .fvwmrc:
48 ;; NoTitle balloon-help
49 ;; or
50 ;; Style "balloon-help" NoTitle, NoHandles, BorderWidth 0
51 ;;
52 ;; For twm use this in your .twmrc:
53 ;; NoTitle { "balloon-help" }
54 ;;
55 ;; Under 19.13 and later versions the balloon-help frame uses a
56 ;; transient window that is not normally decorated by window
57 ;; managers. So the window manager directives should not be
58 ;; needed for XEmacs 19.13 and beyond.
59
60 (provide 'balloon-help)
61
62 (defvar balloon-help-version "1.02"
63 "Version string for Balloon Help.")
64
65 (defvar balloon-help-mode t
66 "*Non-nil means Balloon help mode is enabled.")
67
68 (defvar balloon-help-timeout 1500
69 "*Display help after this many milliseconds of mouse inactivity.")
70
71 (defvar balloon-help-foreground "black"
72 "*The foreground color for displaying balloon help text.")
73
74 (defvar balloon-help-background "rgb:c0/c0/c0"
75 "*The background color for the balloon help frame.")
76
77 (defvar balloon-help-background-pixmap ""
78 "*The background pixmap for the balloon help frame.")
79
80 (defvar balloon-help-font "fixed"
81 "*The font for displaying balloon help text.")
82
83 (defvar balloon-help-border-color "black"
84 "*The color for displaying balloon help frame's border.")
85
86 (defvar balloon-help-use-sound nil
87 "*Non-nil value means play a sound to herald the appearance
88 and disappearance of the help frame.
89
90 `balloon-help-appears' will be played when the frame appears.
91 `balloon-help-disappears' will be played when the frame disappears.
92
93 See the documentation for the function load-sound-file to see how
94 define sounds.")
95
96 (defvar balloon-help-frame-name nil
97 "*The frame name to use for the frame to display the balloon help.")
98
99 ;;;
100 ;;; End of user variables.
101 ;;;
102
103 (defvar mouse-motion-hook mouse-motion-handler
104 "Hooks to be run whenever the user moves the mouse.
105 Each hook is called with one argument, the mouse motion event.")
106
107 (defun mouse-motion-hook (event)
108 "Run the hooks attached to mouse-motion-hook."
109 (run-hook-with-args 'mouse-motion-hook event))
110
111 (setq mouse-motion-handler 'mouse-motion-hook)
112
113 (defvar balloon-help-frame nil
114 "Balloon help is displayed in this frame.")
115
116 (defvar balloon-help-help-object nil
117 "Object that the mouse is over that has a help property, nil otherwise.")
118
119 (defvar balloon-help-help-object-x nil
120 "Last horizontal mouse position over balloon-help-help-object.")
121
122 (defvar balloon-help-help-object-y nil
123 "Last vertical mouse position over balloon-help-help-object.")
124
125 (defvar balloon-help-buffer nil
126 "Buffer used to display balloon help.")
127
128 (defvar balloon-help-timeout-id nil
129 "Timeout id for the balloon help timeout.")
130
131 (defvar balloon-help-display-pending nil
132 "Non-nil value means the help frame will be visible as soon
133 as the X server gets around to displaying it. Nil means it
134 will be invisible as soon as the X server decides to hide it.")
135
136 (defvar balloon-help-bar-cursor nil)
137
138 (defun balloon-help-mode (&optional arg)
139 "Toggle Balloon Help mode.
140 With arg, turn Balloon Help mode on iff arg is positive.
141
142 With Balloon Help enabled, a small frame is displayed whenever
143 the mouse rests on an object that has a help property of some
144 kind. The text of that help property is displayed in the frame.
145
146 For extents, the 'balloon-help' property is
147 checked.
148
149 For toolbar buttons, the help-string slot of the toolbar button
150 is checked.
151
152 If the value is a string, it is used as the help message.
153
154 If the property's value is a symbol, it is assumed to be the name
155 of a function and it will be called with one argument, the object
156 under the mouse, and the return value of that function will be
157 used as the help message."
158 (interactive "P")
159 (setq balloon-help-mode (or (and arg (> (prefix-numeric-value arg) 0))
160 (and (null arg) (null balloon-help-mode))))
161 (if (null balloon-help-mode)
162 (balloon-help-undisplay-help)))
163
164 (defun balloon-help-displayed ()
165 (and (frame-live-p balloon-help-frame)
166 (frame-visible-p balloon-help-frame)))
167
168 (defun balloon-help-motion-hook (event)
169 (cond
170 ((null balloon-help-mode) t)
171 ((button-press-event-p event)
172 (setq balloon-help-help-object nil)
173 (if balloon-help-timeout-id
174 (disable-timeout balloon-help-timeout-id))
175 (if (balloon-help-displayed)
176 (balloon-help-undisplay-help)))
177 (t
178 (let* ((buffer (event-buffer event))
179 (frame (event-frame event))
180 (point (and buffer (event-point event)))
181 (glyph-extent (event-glyph-extent event))
182 (glyph-extent (if (and glyph-extent
183 (extent-property glyph-extent
184 'balloon-help))
185 glyph-extent))
186 (extent (and point
187 (extent-at point buffer 'balloon-help)))
188 (button (event-toolbar-button event))
189 (button (if (and button (toolbar-button-help-string button))
190 button
191 nil))
192 (object (or glyph-extent extent button))
193 (id balloon-help-timeout-id))
194 (if (null object)
195 (if (and balloon-help-frame
196 (not (eq frame balloon-help-frame)))
197 (progn
198 (setq balloon-help-help-object nil)
199 (if id
200 (disable-timeout id))
201 (if (balloon-help-displayed)
202 (balloon-help-undisplay-help))))
203 (let* ((params (frame-parameters frame))
204 (top (cdr (assq 'top params)))
205 (left (cdr (assq 'left params)))
206 (xtop-toolbar-height
207 (if (specifier-instance top-toolbar)
208 (specifier-instance top-toolbar-height)
209 0))
210 (xleft-toolbar-width
211 (if (specifier-instance left-toolbar)
212 (specifier-instance left-toolbar-width)
213 0))
214 (menubar-height (if current-menubar 22 0)))
215 (setq balloon-help-help-object-x
216 (+ left xleft-toolbar-width (event-x-pixel event))
217 balloon-help-help-object-y
218 (+ top xtop-toolbar-height menubar-height
219 (event-y-pixel event))))
220 (cond ((eq frame balloon-help-frame) t)
221 ((eq object balloon-help-help-object)
222 (if (balloon-help-displayed)
223 (balloon-help-move-help-frame)))
224 ((balloon-help-displayed)
225 (setq balloon-help-help-object object)
226 (balloon-help-display-help))
227 (t
228 (setq balloon-help-help-object object)
229 (if id
230 (disable-timeout id))
231 (setq balloon-help-timeout-id
232 (add-timeout (/ balloon-help-timeout 1000.0)
233 (function balloon-help-display-help)
234 nil)))))))))
235
236 (defun balloon-help-pre-command-hook (&rest ignored)
237 (setq balloon-help-help-object nil)
238 (if (balloon-help-displayed)
239 (balloon-help-undisplay-help)))
240
241 (fset 'balloon-help-post-command-hook 'balloon-help-pre-command-hook)
242 (fset 'balloon-help-mouse-leave-frame-hook 'balloon-help-pre-command-hook)
243 (fset 'balloon-help-deselect-frame-hook 'balloon-help-pre-command-hook)
244
245 (defun balloon-help-display-help (&rest ignored)
246 (setq balloon-help-timeout-id nil)
247 (if balloon-help-help-object
248 (let* ((object balloon-help-help-object)
249 (help (or (and (extent-live-p object)
250 (extent-property object 'balloon-help))
251 (and (toolbar-button-p object)
252 (toolbar-button-help-string object))
253 (and (stringp object) object))))
254 ;; if help is non-null and is not a string, run it as
255 ;; function to produuce the help string.
256 (if (or (null help) (not (symbolp help)))
257 nil
258 (condition-case data
259 (setq help (funcall help object))
260 (error
261 (setq help (format "help function signaled: %S" data)))))
262 (if (stringp help)
263 (save-excursion
264 (if (not (bufferp balloon-help-buffer))
265 (setq balloon-help-buffer
266 (get-buffer-create " *balloon-help*")))
267 (if (not (frame-live-p balloon-help-frame))
268 (setq balloon-help-frame (balloon-help-make-help-frame)))
269 (setq bar-cursor t)
270 (set-buffer balloon-help-buffer)
271 (erase-buffer)
272 (insert help)
273 (if (not (bolp))
274 (insert ?\n))
275 ;; help strings longer than 2 lines have the last
276 ;; line stolen by the minibuffer, so make sure the
277 ;; last line is blank. Make the top line blank for
278 ;; some symmetry.
279 (if (< 2 (count-lines (point-min) (point-max)))
280 (progn
281 (insert ?\n)
282 ;; add a second blank line at the end to
283 ;; prevent the modeline bar from clipping the
284 ;; descenders of the last line of text.
285 (insert ?\n)
286 (goto-char (point-min))
287 (insert ?\n)))
288 ;; cursor will be at point-min because we're just
289 ;; moving point which doesn't affect window-point
290 ;; when the window isn't selected. Indent
291 ;; everything so that the cursor will be over a
292 ;; space. The 1-pixel bar cursor will be
293 ;; completely invisible this way.
294 (indent-rigidly (point-min) (point-max) 1)
295 (balloon-help-move-help-frame)
296 (balloon-help-resize-help-frame)
297 (balloon-help-expose-help-frame))))))
298
299 (defun balloon-help-undisplay-help ()
300 (setq bar-cursor balloon-help-bar-cursor)
301 (balloon-help-hide-help-frame))
302
303 (defun balloon-help-hide-help-frame ()
304 (if (balloon-help-displayed)
305 (progn
306 (make-frame-invisible balloon-help-frame)
307 (if (and balloon-help-use-sound balloon-help-display-pending)
308 (play-sound 'balloon-help-disappears))
309 (setq balloon-help-display-pending nil))))
310
311 (defun balloon-help-expose-help-frame ()
312 (if (not (balloon-help-displayed))
313 (progn
314 (make-frame-visible balloon-help-frame)
315 (if (and balloon-help-use-sound (null balloon-help-display-pending))
316 (play-sound 'balloon-help-appears))
317 (setq balloon-help-display-pending t))))
318
319 (defun balloon-help-resize-help-frame ()
320 (save-excursion
321 (set-buffer balloon-help-buffer)
322 (let ((longest 0)
323 (lines 0)
324 (done nil)
325 (window-min-height 1)
326 (window-min-width 1))
327 (goto-char (point-min))
328 (while (not done)
329 (end-of-line)
330 (setq longest (max longest (current-column))
331 done (not (= 0 (forward-line))))
332 (and (not done) (setq lines (1+ lines))))
333 (set-frame-size balloon-help-frame (+ 1 longest) lines))))
334
335 (defun balloon-help-make-help-frame ()
336 (save-excursion
337 (setq balloon-help-bar-cursor bar-cursor)
338 (set-buffer balloon-help-buffer)
339 (set-buffer-menubar nil)
340 (let* ((x (balloon-help-compute-help-frame-x-location))
341 (y (balloon-help-compute-help-frame-y-location))
342 (window-min-height 1)
343 (window-min-width 1)
344 (frame (make-frame (list
345 '(initially-unmapped . t)
346 ;; try to evade frame decorations
347 (cons 'name (or balloon-help-frame-name
348 "xclock"))
349 '(border-width . 2)
350 (cons 'border-color balloon-help-border-color)
351 (cons 'top y)
352 (cons 'left x)
353 (cons 'popup (selected-frame))
354 '(width . 3)
355 '(height . 1)))))
356 (set-face-font 'default balloon-help-font frame)
357 (set-face-foreground 'default balloon-help-foreground frame)
358 (set-face-background 'default balloon-help-background frame)
359 (set-face-background-pixmap 'default balloon-help-background-pixmap
360 frame)
361 (set-window-buffer (frame-selected-window frame) balloon-help-buffer)
362 (set-specifier has-modeline-p (cons frame nil))
363 (set-specifier top-toolbar-height (cons frame 0))
364 (set-specifier left-toolbar-width (cons frame 0))
365 (set-specifier right-toolbar-width (cons frame 0))
366 (set-specifier bottom-toolbar-height (cons frame 0))
367 (set-specifier top-toolbar (cons frame nil))
368 (set-specifier left-toolbar (cons frame nil))
369 (set-specifier right-toolbar (cons frame nil))
370 (set-specifier bottom-toolbar (cons frame nil))
371 (set-specifier scrollbar-width (cons frame 0))
372 (set-specifier scrollbar-height (cons frame 0))
373 (set-specifier modeline-shadow-thickness (cons frame 0))
374 (set-face-background 'modeline balloon-help-background frame)
375 frame )))
376
377 (defun balloon-help-compute-help-frame-x-location ()
378 (max 0 (+ 32 balloon-help-help-object-x)))
379
380 (defun balloon-help-compute-help-frame-y-location ()
381 (max 0 (+ 48 balloon-help-help-object-y)))
382
383 (defun balloon-help-move-help-frame ()
384 (let ((x (balloon-help-compute-help-frame-x-location))
385 (y (balloon-help-compute-help-frame-y-location)))
386 (set-frame-position balloon-help-frame x y)))
387
388 (add-hook 'mouse-motion-hook 'balloon-help-motion-hook)
389 (add-hook 'pre-command-hook 'balloon-help-pre-command-hook)
390 (add-hook 'post-command-hook 'balloon-help-post-command-hook)
391 (add-hook 'mouse-leave-frame-hook 'balloon-help-mouse-leave-frame-hook)
392 (add-hook 'deselect-frame-hook 'balloon-help-deselect-frame-hook)