source: trunk/gui/scripts/tooltip.tcl @ 26

Last change on this file since 26 was 26, checked in by mmc, 17 years ago

Fixed the rendering of groups, and groups within groups.
If groups are mixed in with other elements, then they are
drawn with a gray outline/heading, with the title taken
from the <group><about><label>. However, if a group
contains only other groups, then it is treated as a tabbed
notebook, and each group within is put on a separate page.

WARNING: There are many bad interactions between the
blt::tabset, the Rappture::Scroller, and the Rappture::Pager.
Pages shake violently when all are in play. The only way I
could get them to settle down was by putting the tabs above
the pages they control. Have to revisit this some time to
make it look better...

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