source: branches/blt4/gui/scripts/tooltip.tcl @ 1719

Last change on this file since 1719 was 1719, checked in by gah, 13 years ago
File size: 14.2 KB
Line 
1
2# ----------------------------------------------------------------------
3#  COMPONENT: tooltip - help information that pops up beneath a widget
4#
5#  This file provides support for tooltips, which are little bits
6#  of help information that pop up beneath a widget.
7#
8#  Tooltips can be registered for various widgets as follows:
9#
10#    Rappture::Tooltip::for .w "Some help text."
11#    Rappture::Tooltip::for .x.y "Some more help text."
12#
13#  Tooltips can also be popped up as an error cue beneath a widget
14#  with bad information:
15#
16#    Rappture::Tooltip::cue .w "Bad data in this widget."
17#
18# ======================================================================
19#  AUTHOR:  Michael McLennan, Purdue University
20#  Copyright (c) 2004-2005  Purdue Research Foundation
21#
22#  See the file "license.terms" for information on usage and
23#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
24# ======================================================================
25package require Itk
26
27option add *Tooltip.background white widgetDefault
28option add *Tooltip.outline black widgetDefault
29option add *Tooltip.borderwidth 1 widgetDefault
30option add *Tooltip.font -*-helvetica-medium-r-normal-*-12-* widgetDefault
31option add *Tooltip.wrapLength 4i widgetDefault
32
33itcl::class Rappture::Tooltip {
34    inherit itk::Toplevel
35
36    itk_option define -outline outline Outline ""
37    itk_option define -icon icon Icon ""
38    itk_option define -message message Message ""
39
40    constructor {args} { # defined below }
41
42    public method show {where}
43    public method hide {}
44
45    public proc for {widget args}
46    public proc text {widget args}
47    private common catalog    ;# maps widget => message
48
49    public proc tooltip {option args}
50    private common pending "" ;# after ID for pending "tooltip show"
51
52    public proc cue {option args}
53
54    bind RapptureTooltip <Enter> \
55        [list ::Rappture::Tooltip::tooltip pending %W]
56    bind RapptureTooltip <Leave> \
57        [list ::Rappture::Tooltip::tooltip cancel]
58    bind RapptureTooltip <ButtonPress> \
59        [list ::Rappture::Tooltip::tooltip cancel]
60    bind RapptureTooltip <KeyPress> \
61        [list ::Rappture::Tooltip::tooltip cancel]
62}
63
64itk::usual Tooltip {
65    keep -background -outline -cursor -font
66}
67
68# ----------------------------------------------------------------------
69# CONSTRUCTOR
70# ----------------------------------------------------------------------
71itcl::body Rappture::Tooltip::constructor {args} {
72    wm overrideredirect $itk_component(hull) yes
73    wm withdraw $itk_component(hull)
74
75    component hull configure -borderwidth 1 -background black
76    itk_option remove hull.background hull.borderwidth
77
78    itk_component add icon {
79        label $itk_interior.icon -anchor n
80    }
81
82    itk_component add text {
83        label $itk_interior.text -justify left
84    } {
85        usual
86        keep -wraplength
87    }
88    pack $itk_component(text) -expand yes -fill both -ipadx 4 -ipady 4
89
90    eval itk_initialize $args
91}
92
93# ----------------------------------------------------------------------
94# USAGE: show @<x>,<y>|<widget>+/-<x>,<y>
95#
96# Clients use this to pop up the tooltip on the screen.  The position
97# should be either a <widget> name with an optional offset +/-<x>,<y>
98# (tooltip pops up beneath widget by default), or a specific root
99# window coordinate of the form @x,y.
100#
101# If the -message has the form "@command", then the command is executed
102# now, just before the tooltip is popped up, to build the message
103# on-the-fly.
104# ----------------------------------------------------------------------
105itcl::body Rappture::Tooltip::show {where} {
106    set hull $itk_component(hull)
107    set signx "+"
108    set signy "+"
109
110    if {[regexp {^@([0-9]+),([0-9]+)$} $where match x y]} {
111        set xpos $x
112        set ypos $y
113    } elseif {[regexp {^(.*)([-+])([0-9]+),([-+]?)([0-9]+)$} $where match win signx x signy y]} {
114        if {$signy == ""} { set signy $signx }
115        set xpos [expr {[winfo rootx $win] + $x}]
116        set ypos [expr {[winfo rooty $win] + $y}]
117    } elseif {[winfo exists $where]} {
118        set xpos [expr {[winfo rootx $where]+10}]
119        set ypos [expr {[winfo rooty $where]+[winfo height $where]}]
120    } else {
121        error "bad position \"$where\": should be widget+x,y, or @x,y"
122    }
123
124    if {[string index $itk_option(-message) 0] == "@"} {
125        set cmd [string range $itk_option(-message) 1 end]
126        if {[catch $cmd mesg] != 0} {
127            bgerror $mesg
128            return
129        }
130    } else {
131        set mesg $itk_option(-message)
132    }
133
134    # if there's no message to show, forget it
135    if {[string length $mesg] == 0} {
136        return
137    }
138
139    # strings can't be too big, or they'll go off screen!
140    set pos 0
141    ::for {set i 0} {$pos >= 0 && $i < 20} {incr i} {
142        incr pos
143        set pos [string first \n $mesg $pos]
144    }
145    if {$pos > 0} {
146        set mesg "[string range $mesg 0 $pos]..."
147    }
148    if {[string length $mesg] > 1000} {
149        set mesg "[string range $mesg 0 1500]..."
150    }
151    $itk_component(text) configure -text $mesg
152
153    #
154    # Make sure the tooltip doesn't go off screen.
155    #
156    update idletasks
157    if {$signx == "+"} {
158        if {$xpos+[winfo reqwidth $hull] > [winfo screenwidth $hull]} {
159            set xpos [expr {[winfo screenwidth $hull]-[winfo reqwidth $hull]}]
160        }
161        if {$xpos < 0} { set xpos 0 }
162    } else {
163        if {$xpos-[winfo reqwidth $hull] < 0} {
164            set xpos [expr {[winfo screenwidth $hull]-[winfo reqwidth $hull]}]
165        }
166        set xpos [expr {[winfo screenwidth $hull]-$xpos}]
167    }
168
169    if {$signy == "+"} {
170        if {$ypos+[winfo reqheight $hull] > [winfo screenheight $hull]} {
171            set ypos [expr {[winfo screenheight $hull]-[winfo reqheight $hull]}]
172        }
173        if {$ypos < 0} { set ypos 0 }
174    } else {
175        if {$ypos-[winfo reqheight $hull] < 0} {
176            set ypos [expr {[winfo screenheight $hull]-[winfo reqheight $hull]}]
177        }
178        set ypos [expr {[winfo screenheight $hull]-$ypos}]
179    }
180
181    #
182    # Will the tooltip pop up under the mouse pointer?  If so, then
183    # it will just disappear.  Doh!  We should figure out a better
184    # place to pop it up.
185    #
186    set px [winfo pointerx $hull]
187    set py [winfo pointery $hull]
188    if {$px >= $xpos && $px <= $xpos+[winfo reqwidth $hull]
189          && $py >= $ypos && $py <= $ypos+[winfo reqheight $hull]} {
190
191        if {$px > [winfo screenwidth $hull]/2} {
192            set signx "-"
193            set xpos [expr {[winfo screenwidth $hull]-$px+4}]
194        } else {
195            set signx "+"
196            set xpos [expr {$px+4}]
197        }
198        if {$py > [winfo screenheight $hull]/2} {
199            set signy "-"
200            set ypos [expr {[winfo screenheight $hull]-$py+4}]
201        } else {
202            set signy "+"
203            set ypos [expr {$py+4}]
204        }
205    }
206
207    #
208    # Finally, put it up.
209    #
210    wm geometry $hull $signx$xpos$signy$ypos
211    update
212
213    wm deiconify $hull
214    raise $hull
215}
216
217# ----------------------------------------------------------------------
218# USAGE: hide
219#
220# Takes down the tooltip, if it is showing on the screen.
221# ----------------------------------------------------------------------
222itcl::body Rappture::Tooltip::hide {} {
223    wm withdraw $itk_component(hull)
224}
225
226# ----------------------------------------------------------------------
227# USAGE: for <widget> <text>
228#
229# Used to register the tooltip <text> for a particular <widget>.
230# This sets up bindings on the widget so that, when the mouse pointer
231# lingers over the widget, the tooltip pops up automatically after
232# a small delay.  When the mouse pointer leaves the widget or the
233# user clicks on the widget, it cancels the tip.
234#
235# If the <text> has the form "@command", then the command is executed
236# just before the tip pops up to build the message on-the-fly.
237# ----------------------------------------------------------------------
238itcl::body Rappture::Tooltip::for {widget text} {
239    set catalog($widget) $text
240
241    set btags [bindtags $widget]
242    set i [lsearch $btags RapptureTooltip]
243    if {$i < 0} {
244        set i [lsearch $btags [winfo class $widget]]
245        if {$i < 0} {set i 0}
246        set btags [linsert $btags $i RapptureTooltip]
247        bindtags $widget $btags
248    }
249}
250
251# ----------------------------------------------------------------------
252# USAGE: text <widget> ?<text>?
253#
254# Used to query or set the text used for the tooltip for a widget.
255# This is done automatically when you call the "for" proc, but it
256# is sometimes handy to query or change the text later.
257# ----------------------------------------------------------------------
258itcl::body Rappture::Tooltip::text {widget args} {
259    if {[llength $args] == 0} {
260        if {[info exists catalog($widget)]} {
261            return $catalog($widget)
262        }
263        return ""
264    } elseif {[llength $args] == 1} {
265        set str [lindex $args 0]
266        set catalog($widget) $str
267    } else {
268        error "wrong # args: should be \"text widget ?str?\""
269    }
270}
271
272# ----------------------------------------------------------------------
273# USAGE: tooltip pending <widget> ?@<x>,<y>|+<x>,<y>?
274# USAGE: tooltip show <widget> ?@<x>,<y>|+<x>,<y>?
275# USAGE: tooltip cancel
276#
277# This is invoked automatically whenever the user clicks somewhere
278# inside or outside of the editor.  If the <X>,<Y> coordinate is
279# outside the editor, then we assume the user is done and wants to
280# take the editor down.  Otherwise, we do nothing, and let the entry
281# bindings take over.
282# ----------------------------------------------------------------------
283itcl::body Rappture::Tooltip::tooltip {option args} {
284    switch -- $option {
285        pending {
286            if {[llength $args] < 1 || [llength $args] > 2} {
287                error "wrong # args: should be \"tooltip pending widget ?@x,y?\""
288            }
289            set widget [lindex $args 0]
290            set loc [lindex $args 1]
291
292            if {![info exists catalog($widget)]} {
293                return;                        # No tooltip for widget.
294            }
295            if {$pending != ""} {
296                after cancel $pending
297            }
298            set pending [after 750 [itcl::code tooltip show $widget $loc]]
299        }
300        show {
301            if {[llength $args] < 1 || [llength $args] > 2} {
302                error "wrong # args: should be \"tooltip show tag loc\""
303            }
304            set tag [lindex $args 0]
305            set loc [lindex $args 1]
306
307            # tag name may be .g-axis -- get widget ".g" part
308            set widget $tag
309            if {[regexp {^(\.[^-]+)-[^\.]+$} $widget match wname]} {
310                set widget $wname
311            }
312
313            if {[winfo exists $widget] && [info exists catalog($tag)]} {
314                .rappturetooltip configure -message $catalog($tag)
315                if {[string index $loc 0] == "@"} {
316                    .rappturetooltip show $loc
317                } elseif {[regexp {^[-+]} $loc]} {
318                    .rappturetooltip show $widget$loc
319                } else {
320                    .rappturetooltip show $widget
321                }
322            }
323        }
324        cancel {
325            if {$pending != ""} {
326                after cancel $pending
327                set pending ""
328            }
329            .rappturetooltip hide
330        }
331        default {
332            error "bad option \"$option\": should be show, pending, cancel"
333        }
334    }
335}
336
337# ----------------------------------------------------------------------
338# USAGE: cue <location> <message>
339# USAGE: cue hide
340#
341# Clients use this to show a <message> in a tooltip cue at the
342# specified <location>, which can be a widget name or a root coordinate
343# at @x,y.
344# ----------------------------------------------------------------------
345itcl::body Rappture::Tooltip::cue {option args} {
346    if {"hide" == $option} {
347        grab release .rappturetoolcue
348        .rappturetoolcue hide
349    } elseif {[regexp {^@[0-9]+,[0-9]+$} $option] || [winfo exists $option]} {
350        if {[llength $args] != 1} {
351            error "wrong # args: should be \"cue location message\""
352        }
353        set loc $option
354        set mesg [lindex $args 0]
355
356        .rappturetoolcue configure -message $mesg
357        .rappturetoolcue show $loc
358
359        #
360        # Add a binding to all widgets so that any keypress will
361        # take this cue down.
362        #
363        set cmd [bind all <KeyPress>]
364        if {![regexp {Rappture::Tooltip::cue} $cmd]} {
365            bind all <KeyPress> "+[list ::Rappture::Tooltip::cue hide]"
366            bind all <KeyPress-Return> "+ "
367        }
368
369        #
370        # If nobody has the pointer, then grab it.  Otherwise,
371        # we assume the pop-up editor or someone like that has
372        # the grab, so we don't need to impose a grab here.
373        #
374        if {"" == [grab current]} {
375            update
376            while {[catch {grab set -global .rappturetoolcue}]} {
377                after 100
378            }
379        }
380    } else {
381        error "bad option \"$option\": should be hide, a widget name, or @x,y"
382    }
383}
384
385# ----------------------------------------------------------------------
386# CONFIGURATION OPTION: -icon
387# ----------------------------------------------------------------------
388itcl::configbody Rappture::Tooltip::icon {
389    if {"" == $itk_option(-icon)} {
390        $itk_component(icon) configure -image ""
391        pack forget $itk_component(icon)
392    } else {
393        $itk_component(icon) configure -image $itk_option(-icon)
394        pack $itk_component(icon) -before $itk_component(text) \
395            -side left -fill y
396    }
397}
398
399# ----------------------------------------------------------------------
400# CONFIGURATION OPTION: -outline
401# ----------------------------------------------------------------------
402itcl::configbody Rappture::Tooltip::outline {
403    component hull configure -background $itk_option(-outline)
404}
405
406# create a tooltip widget to show tool tips
407Rappture::Tooltip .rappturetooltip
408
409# any click on any widget takes down the tooltip
410bind all <Leave> [list ::Rappture::Tooltip::tooltip cancel]
411bind all <ButtonPress> [list ::Rappture::Tooltip::tooltip cancel]
412
413# create a tooltip widget to show error cues
414Rappture::Tooltip .rappturetoolcue \
415    -icon [Rappture::icon cue24] \
416    -background black -outline #333333 -foreground white
417
418# when cue is up, it has a grab, and any click brings it down
419bind .rappturetoolcue <ButtonPress> [list ::Rappture::Tooltip::cue hide]
Note: See TracBrowser for help on using the repository browser.