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

Last change on this file since 1 was 1, checked in by mmc, 16 years ago

initial import

File size: 9.7 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  Purdue Research Foundation, West Lafayette, IN
20# ======================================================================
21package require Itk
22
23option add *Tooltip.background white widgetDefault
24option add *Tooltip.outline black widgetDefault
25option add *Tooltip.borderwidth 1 widgetDefault
26option add *Tooltip.font -*-helvetica-medium-r-normal-*-*-120-* widgetDefault
27option add *Tooltip.wrapLength 3i widgetDefault
28
29itcl::class Rappture::Tooltip {
30    inherit itk::Toplevel
31
32    itk_option define -outline outline Outline ""
33    itk_option define -icon icon Icon ""
34    itk_option define -message message Message ""
35
36    constructor {args} { # defined below }
37
38    public method show {where}
39    public method hide {}
40
41    public proc for {widget args}
42    private common catalog    ;# maps widget => message
43
44    public proc tooltip {option {widget ""}}
45    private common pending "" ;# after ID for pending "tooltip show"
46
47    public proc cue {option args}
48
49    bind RapptureTooltip <Enter> \
50        [list ::Rappture::Tooltip::tooltip pending %W]
51    bind RapptureTooltip <Leave> \
52        [list ::Rappture::Tooltip::tooltip cancel]
53    bind RapptureTooltip <ButtonPress> \
54        [list ::Rappture::Tooltip::tooltip cancel]
55    bind RapptureTooltip <KeyPress> \
56        [list ::Rappture::Tooltip::tooltip cancel]
57
58    private common icons
59    set dir [file dirname [info script]]
60    set icons(cue) [image create photo -file [file join $dir images cue24.gif]]
61}
62
63itk::usual Tooltip {
64    keep -background -outline -cursor -font
65}
66
67# ----------------------------------------------------------------------
68# CONSTRUCTOR
69# ----------------------------------------------------------------------
70itcl::body Rappture::Tooltip::constructor {args} {
71    wm overrideredirect $itk_component(hull) yes
72    wm withdraw $itk_component(hull)
73
74    component hull configure -borderwidth 1 -background black
75    itk_option remove hull.background hull.borderwidth
76
77    itk_component add icon {
78        label $itk_interior.icon -anchor n
79    }
80
81    itk_component add text {
82        label $itk_interior.text -justify left
83    } {
84        usual
85        keep -wraplength
86    }
87    pack $itk_component(text) -expand yes -fill both -ipadx 4 -ipady 4
88
89    eval itk_initialize $args
90}
91
92# ----------------------------------------------------------------------
93# USAGE: show @<x>,<y>|<widget>
94#
95# Clients use this to pop up the tooltip on the screen.  The position
96# should be either a <widget> name (tooltip pops up beneath widget)
97# or a specific root window coordinate of the form @x,y.
98#
99# If the -message has the form "@command", then the command is executed
100# now, just before the tooltip is popped up, to build the message
101# on-the-fly.
102# ----------------------------------------------------------------------
103itcl::body Rappture::Tooltip::show {where} {
104    if {[regexp {^@([0-9]+),([0-9]+)$} $where match x y]} {
105        set xpos $x
106        set ypos $y
107    } elseif {[winfo exists $where]} {
108        set xpos [expr {[winfo rootx $where]+10}]
109        set ypos [expr {[winfo rooty $where]+[winfo height $where]}]
110    } else {
111        error "bad position \"$where\": should be widget name or @x,y"
112    }
113
114    if {[string index $itk_option(-message) 0] == "@"} {
115        set cmd [string range $itk_option(-message) 1 end]
116        if {[catch $cmd mesg] != 0} {
117            bgerror $mesg
118            return
119        }
120    } else {
121        set mesg $itk_option(-message)
122    }
123
124    $itk_component(text) configure -text $mesg
125
126    wm geometry $itk_component(hull) +$xpos+$ypos
127    update
128
129    wm deiconify $itk_component(hull)
130    raise $itk_component(hull)
131}
132
133# ----------------------------------------------------------------------
134# USAGE: hide
135#
136# Takes down the tooltip, if it is showing on the screen.
137# ----------------------------------------------------------------------
138itcl::body Rappture::Tooltip::hide {} {
139    wm withdraw $itk_component(hull)
140}
141
142# ----------------------------------------------------------------------
143# USAGE: for <widget> <text>
144#
145# Used to register the tooltip <text> for a particular <widget>.
146# This sets up bindings on the widget so that, when the mouse pointer
147# lingers over the widget, the tooltip pops up automatically after
148# a small delay.  When the mouse pointer leaves the widget or the
149# user clicks on the widget, it cancels the tip.
150#
151# If the <text> has the form "@command", then the command is executed
152# just before the tip pops up to build the message on-the-fly.
153# ----------------------------------------------------------------------
154itcl::body Rappture::Tooltip::for {widget text} {
155    set catalog($widget) $text
156
157    set btags [bindtags $widget]
158    set i [lsearch $btags RapptureTooltip]
159    if {$i < 0} {
160        set i [lsearch $btags [winfo class $widget]]
161        if {$i < 0} {set i 0}
162        set btags [linsert $btags $i RapptureTooltip]
163        bindtags $widget $btags
164    }
165}
166
167# ----------------------------------------------------------------------
168# USAGE: tooltip pending <widget>
169# USAGE: tooltip show
170# USAGE: tooltip cancel
171#
172# This is invoked automatically whenever the user clicks somewhere
173# inside or outside of the editor.  If the <X>,<Y> coordinate is
174# outside the editor, then we assume the user is done and wants to
175# take the editor down.  Otherwise, we do nothing, and let the entry
176# bindings take over.
177# ----------------------------------------------------------------------
178itcl::body Rappture::Tooltip::tooltip {option {widget ""}} {
179    switch -- $option {
180        pending {
181            if {![info exists catalog($widget)]} {
182                error "can't find tooltip for $widget"
183            }
184            if {$pending != ""} {
185                after cancel $pending
186            }
187            set pending [after 1500 [itcl::code tooltip show $widget]]
188        }
189        show {
190            if {[winfo exists $widget]} {
191                .rappturetooltip configure -message $catalog($widget)
192                .rappturetooltip show $widget
193            }
194        }
195        cancel {
196            if {$pending != ""} {
197                after cancel $pending
198                set pending ""
199            }
200            .rappturetooltip hide
201        }
202        default {
203            error "bad option \"$option\": should be show, pending, cancel"
204        }
205    }
206}
207
208# ----------------------------------------------------------------------
209# USAGE: cue <location> <message>
210# USAGE: cue hide
211#
212# Clients use this to show a <message> in a tooltip cue at the
213# specified <location>, which can be a widget name or a root coordinate
214# at @x,y.
215# ----------------------------------------------------------------------
216itcl::body Rappture::Tooltip::cue {option args} {
217    if {"hide" == $option} {
218        grab release .rappturetoolcue
219        .rappturetoolcue hide
220    } elseif {[regexp {^@[0-9]+,[0-9]+$} $option] || [winfo exists $option]} {
221        if {[llength $args] != 1} {
222            error "wrong # args: should be \"cue location message\""
223        }
224        set loc $option
225        set mesg [lindex $args 0]
226
227        .rappturetoolcue configure -message $mesg
228        .rappturetoolcue show $loc
229
230        #
231        # Add a binding to all widgets so that any keypress will
232        # take this cue down.
233        #
234        set cmd [bind all <KeyPress>]
235        if {![regexp {Rappture::Tooltip::cue} $cmd]} {
236            bind all <KeyPress> "+[list ::Rappture::Tooltip::cue hide]"
237            bind all <KeyPress-Return> "+ "
238        }
239
240        #
241        # If nobody has the pointer, then grab it.  Otherwise,
242        # we assume the pop-up editor or someone like that has
243        # the grab, so we don't need to impose a grab here.
244        #
245        if {"" == [grab current]} {
246            update
247            while {[catch {grab set -global .rappturetoolcue}]} {
248                after 100
249            }
250        }
251    } else {
252        error "bad option \"$option\": should be hide, a widget name, or @x,y"
253    }
254}
255
256# ----------------------------------------------------------------------
257# CONFIGURATION OPTION: -icon
258# ----------------------------------------------------------------------
259itcl::configbody Rappture::Tooltip::icon {
260    if {"" == $itk_option(-icon)} {
261        $itk_component(icon) configure -image ""
262        pack forget $itk_component(icon)
263    } else {
264        $itk_component(icon) configure -image $itk_option(-icon)
265        pack $itk_component(icon) -before $itk_component(text) \
266            -side left -fill y
267    }
268}
269
270# ----------------------------------------------------------------------
271# CONFIGURATION OPTION: -outline
272# ----------------------------------------------------------------------
273itcl::configbody Rappture::Tooltip::outline {
274    component hull configure -background $itk_option(-outline)
275}
276
277# create a tooltip widget to show tool tips
278Rappture::Tooltip .rappturetooltip
279
280# create a tooltip widget to show error cues
281Rappture::Tooltip .rappturetoolcue \
282    -icon $Rappture::Tooltip::icons(cue) \
283    -background black -outline #333333 -foreground white
284
285# when cue is up, it has a grab, and any click brings it down
286bind .rappturetoolcue <ButtonPress> [list ::Rappture::Tooltip::cue hide]
Note: See TracBrowser for help on using the repository browser.