Mercurial > hg > xemacs-beta

comparison lisp/packages/balloon-help.el @ 102:a145efe76779 r20-1b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b3
author cvs
date Mon, 13 Aug 2007 09:15:49 +0200
parents 0d2f883870bc
children 8619ce7e4c50
comparison
equal deleted inserted replaced
101:a0ec055d74dd 102:a145efe76779
55 ;; managers. So the window manager directives should not be 55 ;; managers. So the window manager directives should not be
56 ;; needed for XEmacs 19.13 and beyond. 56 ;; needed for XEmacs 19.13 and beyond.
57 57
58 (provide 'balloon-help) 58 (provide 'balloon-help)
59 59
60 (defvar balloon-help-version "1.03" 60 (defvar balloon-help-version "1.04"
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 t
64 "*Non-nil means Balloon help mode is enabled.") 64 "*Non-nil means Balloon help mode is enabled.")
65 65
78 (defvar balloon-help-font "fixed" 78 (defvar balloon-help-font "fixed"
79 "*The font for displaying balloon help text.") 79 "*The font for displaying balloon help text.")
80 80
81 (defvar balloon-help-border-color "black" 81 (defvar balloon-help-border-color "black"
82 "*The color for displaying balloon help frame's border.") 82 "*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.")
83 86
84 (defvar balloon-help-use-sound nil 87 (defvar balloon-help-use-sound nil
85 "*Non-nil value means play a sound to herald the appearance 88 "*Non-nil value means play a sound to herald the appearance
86 and disappearance of the help frame. 89 and disappearance of the help frame.
87 90
204 (balloon-help-undisplay-help)))) 207 (balloon-help-undisplay-help))))
205 (let* ((params (frame-parameters frame)) 208 (let* ((params (frame-parameters frame))
206 (top (cdr (assq 'top params))) 209 (top (cdr (assq 'top params)))
207 (left (cdr (assq 'left params))) 210 (left (cdr (assq 'left params)))
208 (xtop-toolbar-height 211 (xtop-toolbar-height
209 (if (specifier-instance top-toolbar) 212 (if (and (specifier-instance top-toolbar-visible-p frame)
210 (specifier-instance top-toolbar-height) 213 (specifier-instance top-toolbar frame))
214 (specifier-instance top-toolbar-height frame)
211 0)) 215 0))
212 (xleft-toolbar-width 216 (xleft-toolbar-width
213 (if (specifier-instance left-toolbar) 217 (if (and (specifier-instance left-toolbar-visible-p frame)
214 (specifier-instance left-toolbar-width) 218 (specifier-instance left-toolbar frame))
219 (specifier-instance left-toolbar-width frame)
215 0)) 220 0))
216 (menubar-height (if current-menubar 22 0))) 221 (menubar-height
222 (if (and buffer
223 (specifier-instance menubar-visible-p)
224 (save-excursion (set-buffer buffer) current-menubar))
225 22 0)))
217 (setq balloon-help-help-object-x 226 (setq balloon-help-help-object-x
218 (+ left xleft-toolbar-width (event-x-pixel event)) 227 (+ left xleft-toolbar-width (event-x-pixel event))
219 balloon-help-help-object-y 228 balloon-help-help-object-y
220 (+ top xtop-toolbar-height menubar-height 229 (+ top xtop-toolbar-height menubar-height
221 (event-y-pixel event)))) 230 (event-y-pixel event))))
333 (setq longest (max longest (current-column)) 342 (setq longest (max longest (current-column))
334 done (not (= 0 (forward-line)))) 343 done (not (= 0 (forward-line))))
335 (and (not done) (setq lines (1+ lines)))) 344 (and (not done) (setq lines (1+ lines))))
336 (set-frame-size balloon-help-frame (+ 1 longest) lines)))) 345 (set-frame-size balloon-help-frame (+ 1 longest) lines))))
337 346
347 (defun balloon-help-make-junk-frame ()
348 (let ((window-min-height 1)
349 (window-min-width 1))
350 (make-frame '(minibuffer t initially-unmapped t width 1 height 1))))
351
338 (defun balloon-help-make-help-frame () 352 (defun balloon-help-make-help-frame ()
339 (save-excursion 353 (save-excursion
340 (setq balloon-help-bar-cursor bar-cursor) 354 (setq balloon-help-bar-cursor bar-cursor)
341 (set-buffer balloon-help-buffer) 355 (set-buffer balloon-help-buffer)
342 (set-buffer-menubar nil) 356 (set-buffer-menubar nil)
347 (frame (make-frame (list 361 (frame (make-frame (list
348 '(initially-unmapped . t) 362 '(initially-unmapped . t)
349 ;; try to evade frame decorations 363 ;; try to evade frame decorations
350 (cons 'name (or balloon-help-frame-name 364 (cons 'name (or balloon-help-frame-name
351 "xclock")) 365 "xclock"))
352 '(border-width . 2) 366 (cons 'border-width balloon-help-border-width)
353 (cons 'border-color balloon-help-border-color) 367 (cons 'border-color balloon-help-border-color)
354 (cons 'top y) 368 (cons 'top y)
355 (cons 'left x) 369 (cons 'left x)
356 (cons 'popup (selected-frame)) 370 (cons 'popup (balloon-help-make-junk-frame))
357 '(width . 3) 371 '(width . 3)
358 '(height . 1))))) 372 '(height . 1)))))
359 (set-face-font 'default balloon-help-font frame) 373 (set-face-font 'default balloon-help-font frame)
360 (set-face-foreground 'default balloon-help-foreground frame) 374 (set-face-foreground 'default balloon-help-foreground frame)
361 (set-face-background 'default balloon-help-background frame) 375 (set-face-background 'default balloon-help-background frame)
371 (set-specifier left-toolbar (cons frame nil)) 385 (set-specifier left-toolbar (cons frame nil))
372 (set-specifier right-toolbar (cons frame nil)) 386 (set-specifier right-toolbar (cons frame nil))
373 (set-specifier bottom-toolbar (cons frame nil)) 387 (set-specifier bottom-toolbar (cons frame nil))
374 (set-specifier scrollbar-width (cons frame 0)) 388 (set-specifier scrollbar-width (cons frame 0))
375 (set-specifier scrollbar-height (cons frame 0)) 389 (set-specifier scrollbar-height (cons frame 0))
390 (and (boundp 'text-cursor-visible-p)
391 (specifierp text-cursor-visible-p)
392 (set-specifier text-cursor-visible-p (cons frame nil)))
376 (set-specifier modeline-shadow-thickness (cons frame 0)) 393 (set-specifier modeline-shadow-thickness (cons frame 0))
377 (set-face-background 'modeline balloon-help-background frame) 394 (set-face-background 'modeline balloon-help-background frame)
378 frame ))) 395 frame )))
379 396
380 (defun balloon-help-compute-help-frame-x-location () 397 (defun balloon-help-compute-help-frame-x-location ()
390 407
391 (add-hook 'mouse-motion-hook 'balloon-help-motion-hook) 408 (add-hook 'mouse-motion-hook 'balloon-help-motion-hook)
392 (add-hook 'pre-command-hook 'balloon-help-pre-command-hook) 409 (add-hook 'pre-command-hook 'balloon-help-pre-command-hook)
393 (add-hook 'post-command-hook 'balloon-help-post-command-hook) 410 (add-hook 'post-command-hook 'balloon-help-post-command-hook)
394 (add-hook 'mouse-leave-frame-hook 'balloon-help-mouse-leave-frame-hook) 411 (add-hook 'mouse-leave-frame-hook 'balloon-help-mouse-leave-frame-hook)
395 (add-hook 'deselect-frame-hook 'balloon-help-deselect-frame-hook) 412 ;; loses with ClickToFocus under fvwm
413 ;;(add-hook 'deselect-frame-hook 'balloon-help-deselect-frame-hook)