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

Last change on this file since 14 was 14, checked in by mmc, 19 years ago

Added a new <mesh> type and a viewer for mesh geometries.
Needed this for Prophet, and it's a little hard-coded to
their test case. Hack job, but it works. Also fixed the
tooltips so they don't hang around in strange cases.
File size: 12.4 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    # strings can't be too big, or they'll go off screen!
133    if {[string length $mesg] > 1000} {
134        set mesg "[string range $mesg 0 1000]..."
135    }
136    set pos 0
137    ::for {set i 0} {$pos >= 0 && $i < 5} {incr i} {
138        incr pos
139        set pos [string first \n $mesg $pos]
140    }
141    if {$pos > 0} {
142        set mesg "[string range $mesg 0 $pos]..."
143    }
144    $itk_component(text) configure -text $mesg
145
146    #
147    # Make sure the tooltip doesn't go off screen.  Then, put it up.
148    #
149    update
150    if {$xpos+[winfo reqwidth $hull] > [winfo screenwidth $hull]} {
151        set xpos [expr {[winfo screenwidth $hull]-[winfo reqwidth $hull]}]
152    }
153    if {$xpos < 0} { set xpos 0 }
154
155    if {$ypos+[winfo reqheight $hull] > [winfo screenheight $hull]} {
156        set ypos [expr {[winfo screenheight $hull]-[winfo reqheight $hull]}]
157    }
158    if {$ypos < 0} { set ypos 0 }
159
160    wm geometry $hull +$xpos+$ypos
161    update
162
163    wm deiconify $hull
164    raise $hull
165}
166
167# ----------------------------------------------------------------------
168# USAGE: hide
169#
170# Takes down the tooltip, if it is showing on the screen.
171# ----------------------------------------------------------------------
172itcl::body Rappture::Tooltip::hide {} {
173    wm withdraw $itk_component(hull)
174}
175
176# ----------------------------------------------------------------------
177# USAGE: for <widget> <text>
178#
179# Used to register the tooltip <text> for a particular <widget>.
180# This sets up bindings on the widget so that, when the mouse pointer
181# lingers over the widget, the tooltip pops up automatically after
182# a small delay.  When the mouse pointer leaves the widget or the
183# user clicks on the widget, it cancels the tip.
184#
185# If the <text> has the form "@command", then the command is executed
186# just before the tip pops up to build the message on-the-fly.
187# ----------------------------------------------------------------------
188itcl::body Rappture::Tooltip::for {widget text} {
189    set catalog($widget) $text
190
191    set btags [bindtags $widget]
192    set i [lsearch $btags RapptureTooltip]
193    if {$i < 0} {
194        set i [lsearch $btags [winfo class $widget]]
195        if {$i < 0} {set i 0}
196        set btags [linsert $btags $i RapptureTooltip]
197        bindtags $widget $btags
198    }
199}
200
201# ----------------------------------------------------------------------
202# USAGE: text <widget> ?<text>?
203#
204# Used to query or set the text used for the tooltip for a widget.
205# This is done automatically when you call the "for" proc, but it
206# is sometimes handy to query or change the text later.
207# ----------------------------------------------------------------------
208itcl::body Rappture::Tooltip::text {widget args} {
209    if {[llength $args] == 0} {
210        if {[info exists catalog($widget)]} {
211            return $catalog($widget)
212        }
213        return ""
214    } elseif {[llength $args] == 1} {
215        set str [lindex $args 0]
216        set catalog($widget) $str
217    } else {
218        error "wrong # args: should be \"text widget ?str?\""
219    }
220}
221
222# ----------------------------------------------------------------------
223# USAGE: tooltip pending <widget> ?@<x>,<y>|+<x>,<y>?
224# USAGE: tooltip show <widget> ?@<x>,<y>|+<x>,<y>?
225# USAGE: tooltip cancel
226#
227# This is invoked automatically whenever the user clicks somewhere
228# inside or outside of the editor.  If the <X>,<Y> coordinate is
229# outside the editor, then we assume the user is done and wants to
230# take the editor down.  Otherwise, we do nothing, and let the entry
231# bindings take over.
232# ----------------------------------------------------------------------
233itcl::body Rappture::Tooltip::tooltip {option args} {
234    switch -- $option {
235        pending {
236            if {[llength $args] < 1 || [llength $args] > 2} {
237                error "wrong # args: should be \"tooltip pending widget ?@x,y?\""
238            }
239            set widget [lindex $args 0]
240            set loc [lindex $args 1]
241
242            if {![info exists catalog($widget)]} {
243                error "can't find tooltip for $widget"
244            }
245            if {$pending != ""} {
246                after cancel $pending
247            }
248            set pending [after 1500 [itcl::code tooltip show $widget $loc]]
249        }
250        show {
251            if {[llength $args] < 1 || [llength $args] > 2} {
252                error "wrong # args: should be \"tooltip pending widget ?@x,y?\""
253            }
254            set widget [lindex $args 0]
255            set loc [lindex $args 1]
256
257            if {[winfo exists $widget]} {
258                .rappturetooltip configure -message $catalog($widget)
259                if {[string index $loc 0] == "@"} {
260                    .rappturetooltip show $loc
261                } elseif {[string index $loc 0] == "+"} {
262                    .rappturetooltip show $widget$loc
263                } else {
264                    .rappturetooltip show $widget
265                }
266            }
267        }
268        cancel {
269            if {$pending != ""} {
270                after cancel $pending
271                set pending ""
272            }
273            .rappturetooltip hide
274        }
275        default {
276            error "bad option \"$option\": should be show, pending, cancel"
277        }
278    }
279}
280
281# ----------------------------------------------------------------------
282# USAGE: cue <location> <message>
283# USAGE: cue hide
284#
285# Clients use this to show a <message> in a tooltip cue at the
286# specified <location>, which can be a widget name or a root coordinate
287# at @x,y.
288# ----------------------------------------------------------------------
289itcl::body Rappture::Tooltip::cue {option args} {
290    if {"hide" == $option} {
291        grab release .rappturetoolcue
292        .rappturetoolcue hide
293    } elseif {[regexp {^@[0-9]+,[0-9]+$} $option] || [winfo exists $option]} {
294        if {[llength $args] != 1} {
295            error "wrong # args: should be \"cue location message\""
296        }
297        set loc $option
298        set mesg [lindex $args 0]
299
300        .rappturetoolcue configure -message $mesg
301        .rappturetoolcue show $loc
302
303        #
304        # Add a binding to all widgets so that any keypress will
305        # take this cue down.
306        #
307        set cmd [bind all <KeyPress>]
308        if {![regexp {Rappture::Tooltip::cue} $cmd]} {
309            bind all <KeyPress> "+[list ::Rappture::Tooltip::cue hide]"
310            bind all <KeyPress-Return> "+ "
311        }
312
313        #
314        # If nobody has the pointer, then grab it.  Otherwise,
315        # we assume the pop-up editor or someone like that has
316        # the grab, so we don't need to impose a grab here.
317        #
318        if {"" == [grab current]} {
319            update
320            while {[catch {grab set -global .rappturetoolcue}]} {
321                after 100
322            }
323        }
324    } else {
325        error "bad option \"$option\": should be hide, a widget name, or @x,y"
326    }
327}
328
329# ----------------------------------------------------------------------
330# CONFIGURATION OPTION: -icon
331# ----------------------------------------------------------------------
332itcl::configbody Rappture::Tooltip::icon {
333    if {"" == $itk_option(-icon)} {
334        $itk_component(icon) configure -image ""
335        pack forget $itk_component(icon)
336    } else {
337        $itk_component(icon) configure -image $itk_option(-icon)
338        pack $itk_component(icon) -before $itk_component(text) \
339            -side left -fill y
340    }
341}
342
343# ----------------------------------------------------------------------
344# CONFIGURATION OPTION: -outline
345# ----------------------------------------------------------------------
346itcl::configbody Rappture::Tooltip::outline {
347    component hull configure -background $itk_option(-outline)
348}
349
350# create a tooltip widget to show tool tips
351Rappture::Tooltip .rappturetooltip
352
353# any click on any widget takes down the tooltip
354bind all <Leave> [list ::Rappture::Tooltip::tooltip cancel]
355bind all <ButtonPress> [list ::Rappture::Tooltip::tooltip cancel]
356
357# create a tooltip widget to show error cues
358Rappture::Tooltip .rappturetoolcue \
359    -icon $Rappture::Tooltip::icons(cue) \
360    -background black -outline #333333 -foreground white
361
362# when cue is up, it has a grab, and any click brings it down
363bind .rappturetoolcue <ButtonPress> [list ::Rappture::Tooltip::cue hide]
Note: See TracBrowser for help on using the repository browser.