Mercurial > hg > xemacs-beta

comparison lisp/packages/balloon-help.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents c53a95d3c46d
children 0d2f883870bc
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; Balloon help for XEmacs (requires 19.12 or later) 1 ;;; Balloon help for XEmacs (requires 19.12 or later)
2 ;;; Copyright (C) 1995, 1997 Kyle E. Jones 2 ;;; Copyright (C) 1995 Kyle E. Jones
3 ;;; 3 ;;;
4 ;;; This program is free software; you can redistribute it and/or modify 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 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) 6 ;;; the Free Software Foundation; either version 1, or (at your option)
7 ;;; any later version. 7 ;;; any later version.
15 ;;; program's author (send electronic mail to kyle@uunet.uu.net) or from 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 16 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
17 ;;; 02139, USA. 17 ;;; 02139, USA.
18 ;;; 18 ;;;
19 ;;; Send bug reports to kyle@wonderworks.com 19 ;;; Send bug reports to kyle@wonderworks.com
20
21 ;;; Synched up with: Not in FSF.
20 22
21 ;; Balloon help pops up a small frame to display help text 23 ;; Balloon help pops up a small frame to display help text
22 ;; relating to objects that the mouse cursor passes over. 24 ;; relating to objects that the mouse cursor passes over.
23 ;; 25 ;;
24 ;; Installation: 26 ;; Installation:
55 ;; managers. So the window manager directives should not be 57 ;; managers. So the window manager directives should not be
56 ;; needed for XEmacs 19.13 and beyond. 58 ;; needed for XEmacs 19.13 and beyond.
57 59
58 (provide 'balloon-help) 60 (provide 'balloon-help)
59 61
60 (defvar balloon-help-version "1.05" 62 (defvar balloon-help-version "1.02"
61 "Version string for Balloon Help.") 63 "Version string for Balloon Help.")
62 64
63 (defvar balloon-help-mode t 65 (defvar balloon-help-mode t
64 "*Non-nil means Balloon help mode is enabled.") 66 "*Non-nil means Balloon help mode is enabled.")
65 67
78 (defvar balloon-help-font "fixed" 80 (defvar balloon-help-font "fixed"
79 "*The font for displaying balloon help text.") 81 "*The font for displaying balloon help text.")
80 82
81 (defvar balloon-help-border-color "black" 83 (defvar balloon-help-border-color "black"
82 "*The color for displaying balloon help frame's border.") 84 "*The color for displaying balloon help frame's border.")
83
84 (defvar balloon-help-border-width 2
85 "*The width of the balloon help frame's border.")
86 85
87 (defvar balloon-help-use-sound nil 86 (defvar balloon-help-use-sound nil
88 "*Non-nil value means play a sound to herald the appearance 87 "*Non-nil value means play a sound to herald the appearance
89 and disappearance of the help frame. 88 and disappearance of the help frame.
90 89
94 See the documentation for the function load-sound-file to see how 93 See the documentation for the function load-sound-file to see how
95 define sounds.") 94 define sounds.")
96 95
97 (defvar balloon-help-frame-name nil 96 (defvar balloon-help-frame-name nil
98 "*The frame name to use for the frame to display the balloon help.") 97 "*The frame name to use for the frame to display the balloon help.")
99
100 (defvar balloon-help-aggressively-follow-mouse nil
101 "*Non-nil means the balloon should move with the mouse even if the mouse
102 is over the same object as the last mouse motion event.")
103 98
104 ;;; 99 ;;;
105 ;;; End of user variables. 100 ;;; End of user variables.
106 ;;; 101 ;;;
107 102
135 130
136 (defvar balloon-help-display-pending nil 131 (defvar balloon-help-display-pending nil
137 "Non-nil value means the help frame will be visible as soon 132 "Non-nil value means the help frame will be visible as soon
138 as the X server gets around to displaying it. Nil means it 133 as the X server gets around to displaying it. Nil means it
139 will be invisible as soon as the X server decides to hide it.") 134 will be invisible as soon as the X server decides to hide it.")
135
136 (defvar balloon-help-bar-cursor nil)
140 137
141 (defun balloon-help-mode (&optional arg) 138 (defun balloon-help-mode (&optional arg)
142 "Toggle Balloon Help mode. 139 "Toggle Balloon Help mode.
143 With arg, turn Balloon Help mode on iff arg is positive. 140 With arg, turn Balloon Help mode on iff arg is positive.
144 141
179 (balloon-help-undisplay-help))) 176 (balloon-help-undisplay-help)))
180 (t 177 (t
181 (let* ((buffer (event-buffer event)) 178 (let* ((buffer (event-buffer event))
182 (frame (event-frame event)) 179 (frame (event-frame event))
183 (point (and buffer (event-point event))) 180 (point (and buffer (event-point event)))
184 (modeline-point (and buffer (event-modeline-position event)))
185 (modeline-extent (and modeline-point
186 (map-extents
187 (function (lambda (e ignored) e))
188 (symbol-value-in-buffer
189 'generated-modeline-string
190 buffer)
191 modeline-point modeline-point
192 nil nil
193 'balloon-help)))
194 (glyph-extent (event-glyph-extent event)) 181 (glyph-extent (event-glyph-extent event))
195 (glyph-extent (if (and glyph-extent 182 (glyph-extent (if (and glyph-extent
196 (extent-property glyph-extent 183 (extent-property glyph-extent
197 'balloon-help)) 184 'balloon-help))
198 glyph-extent)) 185 glyph-extent))
200 (extent-at point buffer 'balloon-help))) 187 (extent-at point buffer 'balloon-help)))
201 (button (event-toolbar-button event)) 188 (button (event-toolbar-button event))
202 (button (if (and button (toolbar-button-help-string button)) 189 (button (if (and button (toolbar-button-help-string button))
203 button 190 button
204 nil)) 191 nil))
205 (object (or modeline-extent glyph-extent extent button)) 192 (object (or glyph-extent extent button))
206 (id balloon-help-timeout-id)) 193 (id balloon-help-timeout-id))
207 (if (null object) 194 (if (null object)
208 (if (and balloon-help-frame 195 (if (and balloon-help-frame
209 (not (eq frame balloon-help-frame))) 196 (not (eq frame balloon-help-frame)))
210 (progn 197 (progn
215 (balloon-help-undisplay-help)))) 202 (balloon-help-undisplay-help))))
216 (let* ((params (frame-parameters frame)) 203 (let* ((params (frame-parameters frame))
217 (top (cdr (assq 'top params))) 204 (top (cdr (assq 'top params)))
218 (left (cdr (assq 'left params))) 205 (left (cdr (assq 'left params)))
219 (xtop-toolbar-height 206 (xtop-toolbar-height
220 (if (and (specifier-instance top-toolbar-visible-p frame) 207 (if (specifier-instance top-toolbar)
221 (specifier-instance top-toolbar frame)) 208 (specifier-instance top-toolbar-height)
222 (specifier-instance top-toolbar-height frame)
223 0)) 209 0))
224 (xleft-toolbar-width 210 (xleft-toolbar-width
225 (if (and (specifier-instance left-toolbar-visible-p frame) 211 (if (specifier-instance left-toolbar)
226 (specifier-instance left-toolbar frame)) 212 (specifier-instance left-toolbar-width)
227 (specifier-instance left-toolbar-width frame)
228 0)) 213 0))
229 (menubar-height 214 (menubar-height (if current-menubar 22 0)))
230 (if (and buffer
231 (specifier-instance menubar-visible-p)
232 (save-excursion (set-buffer buffer) current-menubar))
233 22 0)))
234 (setq balloon-help-help-object-x 215 (setq balloon-help-help-object-x
235 (+ left xleft-toolbar-width (event-x-pixel event)) 216 (+ left xleft-toolbar-width (event-x-pixel event))
236 balloon-help-help-object-y 217 balloon-help-help-object-y
237 (+ top xtop-toolbar-height menubar-height 218 (+ top xtop-toolbar-height menubar-height
238 (event-y-pixel event)))) 219 (event-y-pixel event))))
239 (cond ((eq frame balloon-help-frame) t) 220 (cond ((eq frame balloon-help-frame) t)
240 ((eq object balloon-help-help-object) 221 ((eq object balloon-help-help-object)
241 (if (and (balloon-help-displayed) 222 (if (balloon-help-displayed)
242 balloon-help-aggressively-follow-mouse)
243 (balloon-help-move-help-frame))) 223 (balloon-help-move-help-frame)))
244 ((balloon-help-displayed) 224 ((balloon-help-displayed)
245 (setq balloon-help-help-object object) 225 (setq balloon-help-help-object object)
246 (balloon-help-display-help)) 226 (balloon-help-display-help))
247 (t 227 (t
284 (if (not (bufferp balloon-help-buffer)) 264 (if (not (bufferp balloon-help-buffer))
285 (setq balloon-help-buffer 265 (setq balloon-help-buffer
286 (get-buffer-create " *balloon-help*"))) 266 (get-buffer-create " *balloon-help*")))
287 (if (not (frame-live-p balloon-help-frame)) 267 (if (not (frame-live-p balloon-help-frame))
288 (setq balloon-help-frame (balloon-help-make-help-frame))) 268 (setq balloon-help-frame (balloon-help-make-help-frame)))
269 (setq bar-cursor t)
289 (set-buffer balloon-help-buffer) 270 (set-buffer balloon-help-buffer)
290 (erase-buffer) 271 (erase-buffer)
291 (insert help) 272 (insert help)
292 (if (not (bolp)) 273 (if (not (bolp))
293 (insert ?\n)) 274 (insert ?\n))
314 (balloon-help-move-help-frame) 295 (balloon-help-move-help-frame)
315 (balloon-help-resize-help-frame) 296 (balloon-help-resize-help-frame)
316 (balloon-help-expose-help-frame)))))) 297 (balloon-help-expose-help-frame))))))
317 298
318 (defun balloon-help-undisplay-help () 299 (defun balloon-help-undisplay-help ()
300 (setq bar-cursor balloon-help-bar-cursor)
319 (balloon-help-hide-help-frame)) 301 (balloon-help-hide-help-frame))
320 302
321 (defun balloon-help-hide-help-frame () 303 (defun balloon-help-hide-help-frame ()
322 (if (balloon-help-displayed) 304 (if (balloon-help-displayed)
323 (progn 305 (progn
348 (setq longest (max longest (current-column)) 330 (setq longest (max longest (current-column))
349 done (not (= 0 (forward-line)))) 331 done (not (= 0 (forward-line))))
350 (and (not done) (setq lines (1+ lines)))) 332 (and (not done) (setq lines (1+ lines))))
351 (set-frame-size balloon-help-frame (+ 1 longest) lines)))) 333 (set-frame-size balloon-help-frame (+ 1 longest) lines))))
352 334
353 (defun balloon-help-make-junk-frame ()
354 (let ((window-min-height 1)
355 (window-min-width 1))
356 (save-excursion
357 (set-buffer (generate-new-buffer "*junk-frame-buffer*"))
358 (prog1
359 (make-frame '(minibuffer t initially-unmapped t width 1 height 1))
360 (rename-buffer " *junk-frame-buffer*" t)))))
361
362 (defun balloon-help-make-help-frame () 335 (defun balloon-help-make-help-frame ()
363 (save-excursion 336 (save-excursion
337 (setq balloon-help-bar-cursor bar-cursor)
364 (set-buffer balloon-help-buffer) 338 (set-buffer balloon-help-buffer)
365 (set-buffer-menubar nil) 339 (set-buffer-menubar nil)
366 (let* ((x (balloon-help-compute-help-frame-x-location)) 340 (let* ((x (balloon-help-compute-help-frame-x-location))
367 (y (balloon-help-compute-help-frame-y-location)) 341 (y (balloon-help-compute-help-frame-y-location))
368 (window-min-height 1) 342 (window-min-height 1)
370 (frame (make-frame (list 344 (frame (make-frame (list
371 '(initially-unmapped . t) 345 '(initially-unmapped . t)
372 ;; try to evade frame decorations 346 ;; try to evade frame decorations
373 (cons 'name (or balloon-help-frame-name 347 (cons 'name (or balloon-help-frame-name
374 "xclock")) 348 "xclock"))
375 (cons 'border-width balloon-help-border-width) 349 '(border-width . 2)
376 (cons 'border-color balloon-help-border-color) 350 (cons 'border-color balloon-help-border-color)
377 (cons 'top y) 351 (cons 'top y)
378 (cons 'left x) 352 (cons 'left x)
379 (cons 'popup (balloon-help-make-junk-frame)) 353 (cons 'popup (selected-frame))
380 '(width . 3) 354 '(width . 3)
381 '(height . 1))))) 355 '(height . 1)))))
382 (set-face-font 'default balloon-help-font frame) 356 (set-face-font 'default balloon-help-font frame)
383 (set-face-foreground 'default balloon-help-foreground frame) 357 (set-face-foreground 'default balloon-help-foreground frame)
384 (set-face-background 'default balloon-help-background frame) 358 (set-face-background 'default balloon-help-background frame)
394 (set-specifier left-toolbar (cons frame nil)) 368 (set-specifier left-toolbar (cons frame nil))
395 (set-specifier right-toolbar (cons frame nil)) 369 (set-specifier right-toolbar (cons frame nil))
396 (set-specifier bottom-toolbar (cons frame nil)) 370 (set-specifier bottom-toolbar (cons frame nil))
397 (set-specifier scrollbar-width (cons frame 0)) 371 (set-specifier scrollbar-width (cons frame 0))
398 (set-specifier scrollbar-height (cons frame 0)) 372 (set-specifier scrollbar-height (cons frame 0))
399 (and (boundp 'text-cursor-visible-p)
400 (specifierp text-cursor-visible-p)
401 (set-specifier text-cursor-visible-p (cons frame nil)))
402 (set-specifier modeline-shadow-thickness (cons frame 0)) 373 (set-specifier modeline-shadow-thickness (cons frame 0))
403 (set-face-background 'modeline balloon-help-background frame) 374 (set-face-background 'modeline balloon-help-background frame)
404 frame ))) 375 frame )))
405 376
406 (defun balloon-help-compute-help-frame-x-location () 377 (defun balloon-help-compute-help-frame-x-location ()
416 387
417 (add-hook 'mouse-motion-hook 'balloon-help-motion-hook) 388 (add-hook 'mouse-motion-hook 'balloon-help-motion-hook)
418 (add-hook 'pre-command-hook 'balloon-help-pre-command-hook) 389 (add-hook 'pre-command-hook 'balloon-help-pre-command-hook)
419 (add-hook 'post-command-hook 'balloon-help-post-command-hook) 390 (add-hook 'post-command-hook 'balloon-help-post-command-hook)
420 (add-hook 'mouse-leave-frame-hook 'balloon-help-mouse-leave-frame-hook) 391 (add-hook 'mouse-leave-frame-hook 'balloon-help-mouse-leave-frame-hook)
421 ;; loses with ClickToFocus under fvwm 392 (add-hook 'deselect-frame-hook 'balloon-help-deselect-frame-hook)
422 ;;(add-hook 'deselect-frame-hook 'balloon-help-deselect-frame-hook)