Mercurial > hg > xemacs-beta
diff lisp/packages/balloon-help.el @ 70:131b0175ea99 r20-0b30
Import from CVS: tag r20-0b30
author | cvs |
---|---|
date | Mon, 13 Aug 2007 09:02:59 +0200 |
parents | c53a95d3c46d |
children | 0d2f883870bc |
line wrap: on
line diff
--- a/lisp/packages/balloon-help.el Mon Aug 13 09:00:04 2007 +0200 +++ b/lisp/packages/balloon-help.el Mon Aug 13 09:02:59 2007 +0200 @@ -1,5 +1,5 @@ ;;; Balloon help for XEmacs (requires 19.12 or later) -;;; Copyright (C) 1995, 1997 Kyle E. Jones +;;; Copyright (C) 1995 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -18,6 +18,8 @@ ;;; ;;; Send bug reports to kyle@wonderworks.com +;;; Synched up with: Not in FSF. + ;; Balloon help pops up a small frame to display help text ;; relating to objects that the mouse cursor passes over. ;; @@ -57,7 +59,7 @@ (provide 'balloon-help) -(defvar balloon-help-version "1.05" +(defvar balloon-help-version "1.02" "Version string for Balloon Help.") (defvar balloon-help-mode t @@ -81,9 +83,6 @@ (defvar balloon-help-border-color "black" "*The color for displaying balloon help frame's border.") -(defvar balloon-help-border-width 2 - "*The width of the balloon help frame's border.") - (defvar balloon-help-use-sound nil "*Non-nil value means play a sound to herald the appearance and disappearance of the help frame. @@ -97,10 +96,6 @@ (defvar balloon-help-frame-name nil "*The frame name to use for the frame to display the balloon help.") -(defvar balloon-help-aggressively-follow-mouse nil - "*Non-nil means the balloon should move with the mouse even if the mouse -is over the same object as the last mouse motion event.") - ;;; ;;; End of user variables. ;;; @@ -138,6 +133,8 @@ as the X server gets around to displaying it. Nil means it will be invisible as soon as the X server decides to hide it.") +(defvar balloon-help-bar-cursor nil) + (defun balloon-help-mode (&optional arg) "Toggle Balloon Help mode. With arg, turn Balloon Help mode on iff arg is positive. @@ -181,16 +178,6 @@ (let* ((buffer (event-buffer event)) (frame (event-frame event)) (point (and buffer (event-point event))) - (modeline-point (and buffer (event-modeline-position event))) - (modeline-extent (and modeline-point - (map-extents - (function (lambda (e ignored) e)) - (symbol-value-in-buffer - 'generated-modeline-string - buffer) - modeline-point modeline-point - nil nil - 'balloon-help))) (glyph-extent (event-glyph-extent event)) (glyph-extent (if (and glyph-extent (extent-property glyph-extent @@ -202,7 +189,7 @@ (button (if (and button (toolbar-button-help-string button)) button nil)) - (object (or modeline-extent glyph-extent extent button)) + (object (or glyph-extent extent button)) (id balloon-help-timeout-id)) (if (null object) (if (and balloon-help-frame @@ -217,20 +204,14 @@ (top (cdr (assq 'top params))) (left (cdr (assq 'left params))) (xtop-toolbar-height - (if (and (specifier-instance top-toolbar-visible-p frame) - (specifier-instance top-toolbar frame)) - (specifier-instance top-toolbar-height frame) + (if (specifier-instance top-toolbar) + (specifier-instance top-toolbar-height) 0)) (xleft-toolbar-width - (if (and (specifier-instance left-toolbar-visible-p frame) - (specifier-instance left-toolbar frame)) - (specifier-instance left-toolbar-width frame) + (if (specifier-instance left-toolbar) + (specifier-instance left-toolbar-width) 0)) - (menubar-height - (if (and buffer - (specifier-instance menubar-visible-p) - (save-excursion (set-buffer buffer) current-menubar)) - 22 0))) + (menubar-height (if current-menubar 22 0))) (setq balloon-help-help-object-x (+ left xleft-toolbar-width (event-x-pixel event)) balloon-help-help-object-y @@ -238,8 +219,7 @@ (event-y-pixel event)))) (cond ((eq frame balloon-help-frame) t) ((eq object balloon-help-help-object) - (if (and (balloon-help-displayed) - balloon-help-aggressively-follow-mouse) + (if (balloon-help-displayed) (balloon-help-move-help-frame))) ((balloon-help-displayed) (setq balloon-help-help-object object) @@ -286,6 +266,7 @@ (get-buffer-create " *balloon-help*"))) (if (not (frame-live-p balloon-help-frame)) (setq balloon-help-frame (balloon-help-make-help-frame))) + (setq bar-cursor t) (set-buffer balloon-help-buffer) (erase-buffer) (insert help) @@ -316,6 +297,7 @@ (balloon-help-expose-help-frame)))))) (defun balloon-help-undisplay-help () + (setq bar-cursor balloon-help-bar-cursor) (balloon-help-hide-help-frame)) (defun balloon-help-hide-help-frame () @@ -350,17 +332,9 @@ (and (not done) (setq lines (1+ lines)))) (set-frame-size balloon-help-frame (+ 1 longest) lines)))) -(defun balloon-help-make-junk-frame () - (let ((window-min-height 1) - (window-min-width 1)) - (save-excursion - (set-buffer (generate-new-buffer "*junk-frame-buffer*")) - (prog1 - (make-frame '(minibuffer t initially-unmapped t width 1 height 1)) - (rename-buffer " *junk-frame-buffer*" t))))) - (defun balloon-help-make-help-frame () (save-excursion + (setq balloon-help-bar-cursor bar-cursor) (set-buffer balloon-help-buffer) (set-buffer-menubar nil) (let* ((x (balloon-help-compute-help-frame-x-location)) @@ -372,11 +346,11 @@ ;; try to evade frame decorations (cons 'name (or balloon-help-frame-name "xclock")) - (cons 'border-width balloon-help-border-width) + '(border-width . 2) (cons 'border-color balloon-help-border-color) (cons 'top y) (cons 'left x) - (cons 'popup (balloon-help-make-junk-frame)) + (cons 'popup (selected-frame)) '(width . 3) '(height . 1))))) (set-face-font 'default balloon-help-font frame) @@ -396,9 +370,6 @@ (set-specifier bottom-toolbar (cons frame nil)) (set-specifier scrollbar-width (cons frame 0)) (set-specifier scrollbar-height (cons frame 0)) - (and (boundp 'text-cursor-visible-p) - (specifierp text-cursor-visible-p) - (set-specifier text-cursor-visible-p (cons frame nil))) (set-specifier modeline-shadow-thickness (cons frame 0)) (set-face-background 'modeline balloon-help-background frame) frame ))) @@ -418,5 +389,4 @@ (add-hook 'pre-command-hook 'balloon-help-pre-command-hook) (add-hook 'post-command-hook 'balloon-help-post-command-hook) (add-hook 'mouse-leave-frame-hook 'balloon-help-mouse-leave-frame-hook) -;; loses with ClickToFocus under fvwm -;;(add-hook 'deselect-frame-hook 'balloon-help-deselect-frame-hook) +(add-hook 'deselect-frame-hook 'balloon-help-deselect-frame-hook)