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

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

Fixed all fonts to set pixelsize instead of pointsize, so that fonts in
the latest X distribution look right.

Added initial Rappture::bugreport::submit command for submitting bug
reports to nanoHUB.org. This isn't tied in yet, but it's a start.

File size: 14.1 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-*-12-* 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 750 [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.