Mercurial > hg > xemacs-beta

comparison lisp/packages/balloon-help.el @ 138:6608ceec7cf8 r20-2b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-2b3
author cvs
date Mon, 13 Aug 2007 09:31:46 +0200
parents 8619ce7e4c50
children 5a88923fcbfe
comparison
equal deleted inserted replaced
137:cae984061f40 138:6608ceec7cf8
1 ;;; Balloon help for XEmacs (requires 19.12 or later) 1 ;;; Balloon help for XEmacs (requires 19.15 or later)
2 ;;; Copyright (C) 1995, 1997 Kyle E. Jones 2 ;;; Copyright (C) 1995, 1997 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)
26 ;; Byte-compile the file balloon-help.el (with M-x byte-compile-file) 26 ;; Byte-compile the file balloon-help.el (with M-x byte-compile-file)
27 ;; and put the .elc file in a directory in your load-path. Add the 27 ;; and put the .elc file in a directory in your load-path. Add the
28 ;; following line to your .emacs: 28 ;; following line to your .emacs:
29 ;; 29 ;;
30 ;; (require 'balloon-help) 30 ;; (require 'balloon-help)
31 ;; 31 ;; (balloon-help-mode 1)
32 ;; For 19.12 users: 32 ;;
33 ;; If you are using fvwm, [tv]twm or ol[v]wm, you can also add 33 ;; The balloon-help frame is a transient window that is not
34 ;; the following lines to various configuration file to use 34 ;; normally decorated by window managers, so the following
35 ;; minimal decorations on the balloon help frames. 35 ;; window manager directives may not be needed. But if they
36 ;; 36 ;; are:
37 ;; In .emacs: 37 ;;
38 ;; (setq balloon-help-frame-name "balloon-help") 38 ;; For ol[v]wm use this in .Xdefaults:
39 ;; 39 ;; olvwm.NoDecor: balloon-help
40 ;; For ol[v]wm use this in .Xdefaults: 40 ;; or
41 ;; olvwm.NoDecor: balloon-help 41 ;; olwm.MinimalDecor: balloon-help
42 ;; or 42 ;;
43 ;; olwm.MinimalDecor: balloon-help 43 ;; For fvvm version 1 use this in your .fvwmrc:
44 ;; 44 ;; NoTitle balloon-help
45 ;; For fvvm use this in your .fvwmrc: 45 ;; or
46 ;; NoTitle balloon-help 46 ;; Style "balloon-help" NoTitle, NoHandles, BorderWidth 0
47 ;; or 47 ;;
48 ;; Style "balloon-help" NoTitle, NoHandles, BorderWidth 0 48 ;; For twm use this in your .twmrc:
49 ;; 49 ;; NoTitle { "balloon-help" }
50 ;; For twm use this in your .twmrc: 50 ;;
51 ;; NoTitle { "balloon-help" }
52 ;;
53 ;; Under 19.13 and later versions the balloon-help frame uses a
54 ;; transient window that is not normally decorated by window
55 ;; managers. So the window manager directives should not be
56 ;; needed for XEmacs 19.13 and beyond.
57 51
58 (provide 'balloon-help) 52 (provide 'balloon-help)
59 53
60 (defvar balloon-help-version "1.05" 54 (require 'custom)
55
56 (defgroup balloon-help nil
57 "Balloon-help support in XEmacs"
58 :group 'frames)
59
60 (defvar balloon-help-version "1.06"
61 "Version string for Balloon Help.") 61 "Version string for Balloon Help.")
62 62
63 (defvar balloon-help-mode t 63 (defvar balloon-help-mode nil
64 "*Non-nil means Balloon help mode is enabled.") 64 "*Non-nil means Balloon help mode is enabled.")
65 65
66 (defvar balloon-help-timeout 1500 66 (defcustom balloon-help-timeout 1500
67 "*Display help after this many milliseconds of mouse inactivity.") 67 "*Display help after this many milliseconds of mouse inactivity."
68 68 :type 'integer
69 (defvar balloon-help-foreground "black" 69 :group 'balloon-help)
70 "*The foreground color for displaying balloon help text.") 70
71 71 (defcustom balloon-help-foreground "black"
72 (defvar balloon-help-background "rgb:c0/c0/c0" 72 "*The foreground color for displaying balloon help text."
73 "*The background color for the balloon help frame.") 73 :type 'string
74 74 :group 'balloon-help)
75 (defvar balloon-help-background-pixmap "" 75
76 "*The background pixmap for the balloon help frame.") 76 (defcustom balloon-help-background "gray80"
77 77 "*The background color for the balloon help frame."
78 (defvar balloon-help-font "fixed" 78 :type 'string
79 "*The font for displaying balloon help text.") 79 :group 'balloon-help)
80 80
81 (defvar balloon-help-border-color "black" 81 (defcustom balloon-help-background-pixmap ""
82 "*The color for displaying balloon help frame's border.") 82 "*The background pixmap for the balloon help frame."
83 83 :type 'string
84 (defvar balloon-help-border-width 2 84 :group 'balloon-help)
85 "*The width of the balloon help frame's border.") 85
86 86 (defcustom balloon-help-font "variable"
87 (defvar balloon-help-use-sound nil 87 "*The font for displaying balloon help text."
88 :type 'string
89 :group 'balloon-help)
90
91 (defcustom balloon-help-border-color "black"
92 "*The color for displaying balloon help frame's border."
93 :type 'string
94 :group 'balloon-help)
95
96 (defcustom balloon-help-border-width 1
97 "*The width of the balloon help frame's border."
98 :type 'integer
99 :group 'balloon-help)
100
101 (defcustom balloon-help-use-sound nil
88 "*Non-nil value means play a sound to herald the appearance 102 "*Non-nil value means play a sound to herald the appearance
89 and disappearance of the help frame. 103 and disappearance of the help frame.
90 104
91 `balloon-help-appears' will be played when the frame appears. 105 `balloon-help-appears' will be played when the frame appears.
92 `balloon-help-disappears' will be played when the frame disappears. 106 `balloon-help-disappears' will be played when the frame disappears.
93 107
94 See the documentation for the function load-sound-file to see how 108 See the documentation for the function load-sound-file to see how
95 define sounds.") 109 define sounds."
96 110 :type 'boolean
97 (defvar balloon-help-frame-name nil 111 :group 'balloon-help)
98 "*The frame name to use for the frame to display the balloon help.") 112
99 113 (defcustom balloon-help-frame-name "balloon-help"
100 (defvar balloon-help-aggressively-follow-mouse nil 114 "*The frame name to use for the frame to display the balloon help."
115 :type 'string
116 :group 'balloon-help)
117
118 (defcustom balloon-help-aggressively-follow-mouse nil
101 "*Non-nil means the balloon should move with the mouse even if the mouse 119 "*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.") 120 is over the same object as the last mouse motion event."
121 :type 'boolean
122 :group 'balloon-help)
103 123
104 ;;; 124 ;;;
105 ;;; End of user variables. 125 ;;; End of user variables.
106 ;;; 126 ;;;
107 127
108 (defvar mouse-motion-hook mouse-motion-handler 128 (defvar mouse-motion-hook mouse-motion-handler
109 "Hooks to be run whenever the user moves the mouse. 129 "Hooks to be run whenever the user moves the mouse.
110 Each hook is called with one argument, the mouse motion event.") 130 Each hook is called with one argument, the mouse motion event.
131 This hooks variable does not exist unless the \"balloon-help\" library
132 has been loaded.")
111 133
112 (defun mouse-motion-hook (event) 134 (defun mouse-motion-hook (event)
113 "Run the hooks attached to mouse-motion-hook." 135 "Run the hooks attached to mouse-motion-hook."
114 (run-hook-with-args 'mouse-motion-hook event)) 136 (run-hook-with-args 'mouse-motion-hook event))
115 137
116 (setq mouse-motion-handler 'mouse-motion-hook) 138 (setq mouse-motion-handler 'mouse-motion-hook)
117 139
118 (defvar balloon-help-frame nil 140 (defvar balloon-help-frame nil
119 "Balloon help is displayed in this frame.") 141 "Balloon help is displayed in this frame.")
120 142
143 (defvar balloon-help-junk-frame nil
144 "Junk parent frame of balloon-help-frame.")
145
121 (defvar balloon-help-help-object nil 146 (defvar balloon-help-help-object nil
122 "Object that the mouse is over that has a help property, nil otherwise.") 147 "Object that the mouse is over that has a help property, nil otherwise.")
123 148
124 (defvar balloon-help-help-object-x nil 149 (defvar balloon-help-help-object-x nil
125 "Last horizontal mouse position over balloon-help-help-object.") 150 "Last horizontal mouse position over balloon-help-help-object.")
126 151
127 (defvar balloon-help-help-object-y nil 152 (defvar balloon-help-help-object-y nil
128 "Last vertical mouse position over balloon-help-help-object.") 153 "Last vertical mouse position over balloon-help-help-object.")
129 154
130 (defvar balloon-help-buffer nil 155 (defvar balloon-help-buffer (get-buffer-create " *balloon-help*")
131 "Buffer used to display balloon help.") 156 "Buffer used to display balloon help.")
132 157
133 (defvar balloon-help-timeout-id nil 158 (defvar balloon-help-timeout-id nil
134 "Timeout id for the balloon help timeout.") 159 "Timeout id for the balloon help timeout.")
135 160
164 (if (null balloon-help-mode) 189 (if (null balloon-help-mode)
165 (balloon-help-undisplay-help))) 190 (balloon-help-undisplay-help)))
166 191
167 (defun balloon-help-displayed () 192 (defun balloon-help-displayed ()
168 (and (frame-live-p balloon-help-frame) 193 (and (frame-live-p balloon-help-frame)
169 (frame-visible-p balloon-help-frame))) 194 (frame-visible-p balloon-help-frame)
195 (eq (frame-device balloon-help-frame) (selected-device))))
196
197 (defun balloon-help (&optional event)
198 "Display Balloon Help for the object under EVENT.
199 If EVENT is nil, then point in the selected window is used instead.
200 See the documentation for balloon-help-mode to find out what this means.
201 This command must be bound to a mouse event."
202 (interactive "e")
203 (unless (device-on-window-system-p)
204 (error "Cannot display balloon help on %s device" (device-type)))
205 (let ((balloon-help-mode t))
206 (balloon-help-motion-hook event))
207 (when balloon-help-timeout-id
208 (disable-timeout balloon-help-timeout-id)
209 (setq balloon-help-timeout-id nil))
210 (balloon-help-display-help))
170 211
171 (defun balloon-help-motion-hook (event) 212 (defun balloon-help-motion-hook (event)
172 (cond 213 (cond
173 ((null balloon-help-mode) t) 214 ((null balloon-help-mode) t)
174 ((button-press-event-p event)
175 (setq balloon-help-help-object nil)
176 (if balloon-help-timeout-id
177 (disable-timeout balloon-help-timeout-id))
178 (if (balloon-help-displayed)
179 (balloon-help-undisplay-help)))
180 (t 215 (t
181 (let* ((buffer (event-buffer event)) 216 (let* ((buffer (if event (event-buffer event) (current-buffer)))
182 (frame (event-frame event)) 217 (frame (if event (event-frame event) (selected-frame)))
183 (point (and buffer (event-point event))) 218 (point (if event (event-point event) (point)))
184 (modeline-point (and buffer (event-modeline-position event))) 219 (modeline-point (if event (event-modeline-position event)))
185 (modeline-extent (and modeline-point 220 (modeline-extent (and modeline-point
186 (map-extents 221 (map-extents
187 (function (lambda (e ignored) e)) 222 (function (lambda (e ignored) e))
188 (symbol-value-in-buffer 223 (symbol-value-in-buffer
189 'generated-modeline-string 224 'generated-modeline-string
190 buffer) 225 buffer)
191 modeline-point modeline-point 226 modeline-point modeline-point
192 nil nil 227 nil nil
193 'balloon-help))) 228 'balloon-help)))
194 (glyph-extent (event-glyph-extent event)) 229 (glyph-extent (and event (event-glyph-extent event)))
195 (glyph-extent (if (and glyph-extent 230 (glyph-extent (if (and glyph-extent
196 (extent-property glyph-extent 231 (extent-property glyph-extent
197 'balloon-help)) 232 'balloon-help))
198 glyph-extent)) 233 glyph-extent))
199 (extent (and point 234 (extent (and point
200 (extent-at point buffer 'balloon-help))) 235 (extent-at point buffer 'balloon-help)))
201 (button (event-toolbar-button event)) 236 (button (and event (event-toolbar-button event)))
202 (button (if (and button (toolbar-button-help-string button)) 237 (button (if (and button (toolbar-button-help-string button))
203 button 238 button
204 nil)) 239 nil))
205 (object (or modeline-extent glyph-extent extent button)) 240 (object (or modeline-extent glyph-extent extent button))
206 (id balloon-help-timeout-id)) 241 (id balloon-help-timeout-id))
207 (if (null object) 242 (if (null object)
208 (if (and balloon-help-frame 243 (if (and balloon-help-frame
209 (not (eq frame balloon-help-frame))) 244 (not (eq frame balloon-help-frame)))
210 (progn 245 (progn
211 (setq balloon-help-help-object nil) 246 (setq balloon-help-help-object nil)
212 (if id 247 (when id
213 (disable-timeout id)) 248 (disable-timeout id)
249 (setq balloon-help-timeout-id nil))
214 (if (balloon-help-displayed) 250 (if (balloon-help-displayed)
215 (balloon-help-undisplay-help)))) 251 (balloon-help-undisplay-help))))
216 (let* ((params (frame-parameters frame)) 252 (let* ((params (frame-parameters frame))
217 (top (cdr (assq 'top params))) 253 (top (cdr (assq 'top params)))
218 (left (cdr (assq 'left params))) 254 (left (cdr (assq 'left params)))
230 (if (and buffer 266 (if (and buffer
231 (specifier-instance menubar-visible-p) 267 (specifier-instance menubar-visible-p)
232 (save-excursion (set-buffer buffer) current-menubar)) 268 (save-excursion (set-buffer buffer) current-menubar))
233 22 0))) 269 22 0)))
234 (setq balloon-help-help-object-x 270 (setq balloon-help-help-object-x
235 (+ left xleft-toolbar-width (event-x-pixel event)) 271 (if event
272 (+ left xleft-toolbar-width
273 (event-x-pixel event))
274 (/ (* (device-pixel-width) 2) 5))
236 balloon-help-help-object-y 275 balloon-help-help-object-y
237 (+ top xtop-toolbar-height menubar-height 276 (if event
238 (event-y-pixel event)))) 277 (+ top xtop-toolbar-height menubar-height
278 (event-y-pixel event))
279 (/ (* (device-pixel-height) 2) 5))))
239 (cond ((eq frame balloon-help-frame) t) 280 (cond ((eq frame balloon-help-frame) t)
240 ((eq object balloon-help-help-object) 281 ((eq object balloon-help-help-object)
241 (if (and (balloon-help-displayed) 282 (if (and (balloon-help-displayed)
242 balloon-help-aggressively-follow-mouse) 283 balloon-help-aggressively-follow-mouse)
243 (balloon-help-move-help-frame))) 284 (balloon-help-move-help-frame)))
251 (setq balloon-help-timeout-id 292 (setq balloon-help-timeout-id
252 (add-timeout (/ balloon-help-timeout 1000.0) 293 (add-timeout (/ balloon-help-timeout 1000.0)
253 (function balloon-help-display-help) 294 (function balloon-help-display-help)
254 nil))))))))) 295 nil)))))))))
255 296
256 (defun balloon-help-pre-command-hook (&rest ignored)
257 (setq balloon-help-help-object nil)
258 (if (balloon-help-displayed)
259 (balloon-help-undisplay-help)))
260
261 (fset 'balloon-help-post-command-hook 'balloon-help-pre-command-hook)
262 (fset 'balloon-help-mouse-leave-frame-hook 'balloon-help-pre-command-hook)
263 (fset 'balloon-help-deselect-frame-hook 'balloon-help-pre-command-hook)
264
265 (defun balloon-help-display-help (&rest ignored) 297 (defun balloon-help-display-help (&rest ignored)
266 (setq balloon-help-timeout-id nil) 298 (setq balloon-help-timeout-id nil)
267 (if balloon-help-help-object 299 (if (and balloon-help-help-object (device-on-window-system-p))
268 (let* ((object balloon-help-help-object) 300 (let* ((object balloon-help-help-object)
269 (help (or (and (extent-live-p object) 301 (help (or (and (extent-live-p object)
270 (extent-property object 'balloon-help)) 302 (extent-property object 'balloon-help))
271 (and (toolbar-button-p object) 303 (and (toolbar-button-p object)
272 (toolbar-button-help-string object)) 304 (toolbar-button-help-string object))
279 (setq help (funcall help object)) 311 (setq help (funcall help object))
280 (error 312 (error
281 (setq help (format "help function signaled: %S" data))))) 313 (setq help (format "help function signaled: %S" data)))))
282 (if (stringp help) 314 (if (stringp help)
283 (save-excursion 315 (save-excursion
284 (if (not (bufferp balloon-help-buffer)) 316 (if (or (not (frame-live-p balloon-help-frame))
285 (setq balloon-help-buffer 317 (not (eq (selected-device)
286 (get-buffer-create " *balloon-help*"))) 318 (frame-device balloon-help-frame))))
287 (if (not (frame-live-p balloon-help-frame))
288 (setq balloon-help-frame (balloon-help-make-help-frame))) 319 (setq balloon-help-frame (balloon-help-make-help-frame)))
289 (set-buffer balloon-help-buffer) 320 (set-buffer balloon-help-buffer)
290 (erase-buffer) 321 (erase-buffer)
291 (insert help) 322 (insert help)
292 (if (not (bolp)) 323 (if (not (bolp))
293 (insert ?\n)) 324 (insert ?\n))
294 ;; help strings longer than 2 lines have the last 325 ;;; ;; help strings longer than 2 lines have the last
295 ;; line stolen by the minibuffer, so make sure the 326 ;;; ;; line stolen by the minibuffer, so make sure the
296 ;; last line is blank. Make the top line blank for 327 ;;; ;; last line is blank. Make the top line blank for
297 ;; some symmetry. 328 ;;; ;; some symmetry.
298 (if (< 2 (count-lines (point-min) (point-max))) 329 ;;; (if (< 2 (count-lines (point-min) (point-max)))
299 (progn 330 ;;; (progn
300 (insert ?\n) 331 ;;; (insert ?\n)
301 ;; add a second blank line at the end to 332 ;;; ;; add a second blank line at the end to
302 ;; prevent the modeline bar from clipping the 333 ;;; ;; prevent the modeline bar from clipping the
303 ;; descenders of the last line of text. 334 ;;; ;; descenders of the last line of text.
304 (insert ?\n) 335 ;;; (insert ?\n)
305 (goto-char (point-min)) 336 ;;; (goto-char (point-min))
306 (insert ?\n))) 337 ;;; (insert ?\n)))
307 ;; cursor will be at point-min because we're just 338 ;; indent everything by a space for readability
308 ;; moving point which doesn't affect window-point
309 ;; when the window isn't selected. Indent
310 ;; everything so that the cursor will be over a
311 ;; space. The 1-pixel bar cursor will be
312 ;; completely invisible this way.
313 (indent-rigidly (point-min) (point-max) 1) 339 (indent-rigidly (point-min) (point-max) 1)
340 (balloon-help-set-frame-properties)
341 (balloon-help-resize-help-frame)
314 (balloon-help-move-help-frame) 342 (balloon-help-move-help-frame)
315 (balloon-help-resize-help-frame)
316 (balloon-help-expose-help-frame)))))) 343 (balloon-help-expose-help-frame))))))
317 344
318 (defun balloon-help-undisplay-help () 345 (defun balloon-help-undisplay-help ()
319 (balloon-help-hide-help-frame)) 346 (balloon-help-hide-help-frame))
320 347
332 (make-frame-visible balloon-help-frame) 359 (make-frame-visible balloon-help-frame)
333 (if (and balloon-help-use-sound (null balloon-help-display-pending)) 360 (if (and balloon-help-use-sound (null balloon-help-display-pending))
334 (play-sound 'balloon-help-appears)) 361 (play-sound 'balloon-help-appears))
335 (setq balloon-help-display-pending t)))) 362 (setq balloon-help-display-pending t))))
336 363
364 (defun balloon-help-set-frame-properties ()
365 (let ((frame balloon-help-frame))
366 ;; don't set the font unconditionally because it makes the
367 ;; frame size flap visibly while XEmacs figures out the new
368 ;; frame size.
369 (if (not (equal (face-font 'default frame) balloon-help-font))
370 (set-face-font 'default balloon-help-font frame))
371 (set-face-foreground 'default balloon-help-foreground frame)
372 (set-face-background 'default balloon-help-background frame)
373 (set-face-background 'modeline balloon-help-background frame)
374 (set-face-background-pixmap 'default balloon-help-background-pixmap frame)
375 (set-frame-property frame 'border-color balloon-help-border-color)
376 (set-frame-property frame 'border-width balloon-help-border-width)))
377
378 ;;;(defun balloon-help-resize-help-frame ()
379 ;;; (save-excursion
380 ;;; (set-buffer balloon-help-buffer)
381 ;;; (let ((longest 0)
382 ;;; (lines 0)
383 ;;; (done nil)
384 ;;; (window-min-height 1)
385 ;;; (window-min-width 1))
386 ;;; (goto-char (point-min))
387 ;;; (while (not done)
388 ;;; (end-of-line)
389 ;;; (setq longest (max longest (current-column))
390 ;;; done (not (= 0 (forward-line))))
391 ;;; (and (not done) (setq lines (1+ lines))))
392 ;;; (set-frame-size balloon-help-frame (+ 1 longest) lines))))
393
337 (defun balloon-help-resize-help-frame () 394 (defun balloon-help-resize-help-frame ()
338 (save-excursion 395 (save-excursion
339 (set-buffer balloon-help-buffer) 396 (set-buffer balloon-help-buffer)
340 (let ((longest 0) 397 (let* ((longest 0)
341 (lines 0) 398 (lines 0)
342 (done nil) 399 (done nil)
343 (window-min-height 1) 400 (inst (vector 'string ':data nil))
344 (window-min-width 1)) 401 (window (frame-selected-window balloon-help-frame))
402 (font-width (font-width (face-font 'default) balloon-help-frame))
403 start width
404 (window-min-height 1)
405 (window-min-width 1))
345 (goto-char (point-min)) 406 (goto-char (point-min))
346 (while (not done) 407 (while (not done)
408 (setq start (point))
347 (end-of-line) 409 (end-of-line)
348 (setq longest (max longest (current-column)) 410 (aset inst 2 (buffer-substring start (point)))
411 (setq longest (max longest (glyph-width (make-glyph inst) window))
349 done (not (= 0 (forward-line)))) 412 done (not (= 0 (forward-line))))
350 (and (not done) (setq lines (1+ lines)))) 413 (and (not done) (setq lines (1+ lines))))
351 (set-frame-size balloon-help-frame (+ 1 longest) lines)))) 414 (setq width (/ longest font-width)
415 width (if (> longest (* width font-width)) (1+ width) width))
416 (set-frame-size balloon-help-frame (+ 0 width) lines))))
417
418 (defun balloon-help-compute-help-frame-y-location ()
419 (let* ((device-bottom (device-pixel-height
420 (frame-device balloon-help-frame)))
421 (y-pos (max 0 (+ 48 balloon-help-help-object-y)))
422 (height (frame-pixel-height balloon-help-frame))
423 (bottom (+ y-pos height)))
424 (if (>= bottom device-bottom)
425 (setq y-pos (max 0 (- y-pos (- bottom device-bottom)))))
426 y-pos ))
427
428 (defun balloon-help-compute-help-frame-x-location ()
429 (let* ((device-right (device-pixel-width (frame-device balloon-help-frame)))
430 (x-pos (max 0 (+ 32 balloon-help-help-object-x)))
431 (width (frame-pixel-width balloon-help-frame))
432 (right (+ x-pos width)))
433 (if (>= right device-right)
434 (setq x-pos (max 0 (- x-pos (- right device-right)))))
435 x-pos ))
436
437 (defun balloon-help-move-help-frame ()
438 (let ((x (balloon-help-compute-help-frame-x-location))
439 (y (balloon-help-compute-help-frame-y-location)))
440 (set-frame-position balloon-help-frame x y)))
352 441
353 (defun balloon-help-make-junk-frame () 442 (defun balloon-help-make-junk-frame ()
354 (let ((window-min-height 1) 443 (let ((window-min-height 1)
355 (window-min-width 1)) 444 (window-min-width 1))
356 (save-excursion 445 (when (framep balloon-help-junk-frame)
357 (set-buffer (generate-new-buffer "*junk-frame-buffer*")) 446 (delete-frame balloon-help-junk-frame)
358 (prog1 447 (setq balloon-help-junk-frame nil))
359 (make-frame '(minibuffer t initially-unmapped t width 1 height 1)) 448 (prog1
360 (rename-buffer " *junk-frame-buffer*" t))))) 449 (setq balloon-help-junk-frame
450 (make-frame '(minibuffer t
451 initially-unmapped t
452 width 1
453 height 1)))
454 (set-window-buffer (frame-selected-window balloon-help-junk-frame)
455 balloon-help-buffer))))
361 456
362 (defun balloon-help-make-help-frame () 457 (defun balloon-help-make-help-frame ()
458 (when (framep balloon-help-frame)
459 (delete-frame balloon-help-frame)
460 (setq balloon-help-frame nil))
363 (save-excursion 461 (save-excursion
364 (set-buffer balloon-help-buffer) 462 (set-buffer balloon-help-buffer)
463 (setq truncate-lines t)
365 (set-buffer-menubar nil) 464 (set-buffer-menubar nil)
366 (let* ((x (balloon-help-compute-help-frame-x-location)) 465 (let* ((x (balloon-help-compute-help-frame-x-location))
367 (y (balloon-help-compute-help-frame-y-location)) 466 (y (balloon-help-compute-help-frame-y-location))
368 (window-min-height 1) 467 (window-min-height 1)
369 (window-min-width 1) 468 (window-min-width 1)
469 (junk-frame (balloon-help-make-junk-frame))
370 (frame (make-frame (list 470 (frame (make-frame (list
371 '(initially-unmapped . t) 471 '(initially-unmapped . t)
372 ;; try to evade frame decorations 472 ;; try to evade frame decorations
373 (cons 'name (or balloon-help-frame-name 473 (cons 'name balloon-help-frame-name)
374 "xclock"))
375 (cons 'border-width balloon-help-border-width) 474 (cons 'border-width balloon-help-border-width)
376 (cons 'border-color balloon-help-border-color) 475 (cons 'border-color balloon-help-border-color)
377 (cons 'top y) 476 (cons 'top y)
378 (cons 'left x) 477 (cons 'left x)
379 (cons 'popup (balloon-help-make-junk-frame)) 478 (cons 'popup junk-frame)
479 (cons 'minibuffer
480 (minibuffer-window junk-frame))
380 '(width . 3) 481 '(width . 3)
381 '(height . 1))))) 482 '(height . 1)))))
382 (set-face-font 'default balloon-help-font frame) 483 (set-face-font 'default balloon-help-font frame)
383 (set-face-foreground 'default balloon-help-foreground frame) 484 (set-face-foreground 'default balloon-help-foreground frame)
384 (set-face-background 'default balloon-help-background frame) 485 (set-face-background 'default balloon-help-background frame)
388 (set-specifier has-modeline-p (cons frame nil)) 489 (set-specifier has-modeline-p (cons frame nil))
389 (set-specifier top-toolbar-height (cons frame 0)) 490 (set-specifier top-toolbar-height (cons frame 0))
390 (set-specifier left-toolbar-width (cons frame 0)) 491 (set-specifier left-toolbar-width (cons frame 0))
391 (set-specifier right-toolbar-width (cons frame 0)) 492 (set-specifier right-toolbar-width (cons frame 0))
392 (set-specifier bottom-toolbar-height (cons frame 0)) 493 (set-specifier bottom-toolbar-height (cons frame 0))
494 (set-specifier top-toolbar-visible-p (cons frame nil))
495 (set-specifier left-toolbar-visible-p (cons frame nil))
496 (set-specifier right-toolbar-visible-p (cons frame nil))
497 (set-specifier bottom-toolbar-visible-p (cons frame nil))
393 (set-specifier top-toolbar (cons frame nil)) 498 (set-specifier top-toolbar (cons frame nil))
394 (set-specifier left-toolbar (cons frame nil)) 499 (set-specifier left-toolbar (cons frame nil))
395 (set-specifier right-toolbar (cons frame nil)) 500 (set-specifier right-toolbar (cons frame nil))
396 (set-specifier bottom-toolbar (cons frame nil)) 501 (set-specifier bottom-toolbar (cons frame nil))
397 (set-specifier scrollbar-width (cons frame 0)) 502 (set-specifier scrollbar-width (cons frame 0))
398 (set-specifier scrollbar-height (cons frame 0)) 503 (set-specifier scrollbar-height (cons frame 0))
399 (and (boundp 'text-cursor-visible-p) 504 (set-specifier text-cursor-visible-p (cons frame nil))
400 (specifierp text-cursor-visible-p) 505 (set-specifier has-modeline-p (cons frame nil))
401 (set-specifier text-cursor-visible-p (cons frame nil)))
402 (set-specifier modeline-shadow-thickness (cons frame 0)) 506 (set-specifier modeline-shadow-thickness (cons frame 0))
507 (set-specifier (glyph-image truncation-glyph) [nothing] frame '(x))
403 (set-face-background 'modeline balloon-help-background frame) 508 (set-face-background 'modeline balloon-help-background frame)
404 frame ))) 509 frame )))
405 510
406 (defun balloon-help-compute-help-frame-x-location () 511 (defun balloon-help-pre-command-hook ()
407 (max 0 (+ 32 balloon-help-help-object-x))) 512 (unless (eq this-command 'balloon-help)
408 513 (balloon-help-go-away)))
409 (defun balloon-help-compute-help-frame-y-location () 514
410 (max 0 (+ 48 balloon-help-help-object-y))) 515 (defun balloon-help-go-away (&rest ignored)
411 516 (setq balloon-help-help-object nil)
412 (defun balloon-help-move-help-frame () 517 (if (balloon-help-displayed)
413 (let ((x (balloon-help-compute-help-frame-x-location)) 518 (balloon-help-undisplay-help)))
414 (y (balloon-help-compute-help-frame-y-location))) 519
415 (set-frame-position balloon-help-frame x y))) 520 (defun balloon-help-mouse-leave-frame-hook (&rest ignored)
521 (let* ((mouse (mouse-position))
522 (window (car mouse)))
523 (if (or (null window) (not (eq (window-frame window) balloon-help-frame)))
524 (balloon-help-go-away))))
525
526 ;; loses with ClickToFocus under fvwm
527 ;;(fset 'balloon-help-deselect-frame-hook 'balloon-help-go-away)
528 ;;(add-hook 'deselect-frame-hook 'balloon-help-deselect-frame-hook)
416 529
417 (add-hook 'mouse-motion-hook 'balloon-help-motion-hook) 530 (add-hook 'mouse-motion-hook 'balloon-help-motion-hook)
531
418 (add-hook 'pre-command-hook 'balloon-help-pre-command-hook) 532 (add-hook 'pre-command-hook 'balloon-help-pre-command-hook)
419 (add-hook 'post-command-hook 'balloon-help-post-command-hook)
420 (add-hook 'mouse-leave-frame-hook 'balloon-help-mouse-leave-frame-hook) 533 (add-hook 'mouse-leave-frame-hook 'balloon-help-mouse-leave-frame-hook)
421 ;; loses with ClickToFocus under fvwm
422 ;;(add-hook 'deselect-frame-hook 'balloon-help-deselect-frame-hook)