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

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