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

Last change on this file since 213 was 213, checked in by mmc, 18 years ago
  • Fixed up the tool tips for upload to remind the user about allowing pop ups, and to catch errors when the user uploads nothing.
  • Added a protocol version number to the filexfer applet, so Rappture can warn when the applet is out-of-date with respect to the application. (Thanks, Rick!)
File size: 13.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    private common icons
63    set dir [file dirname [info script]]
64    set icons(cue) [image create photo -file [file join $dir images cue24.gif]]
65}
66
67itk::usual Tooltip {
68    keep -background -outline -cursor -font
69}
70
71# ----------------------------------------------------------------------
72# CONSTRUCTOR
73# ----------------------------------------------------------------------
74itcl::body Rappture::Tooltip::constructor {args} {
75    wm overrideredirect $itk_component(hull) yes
76    wm withdraw $itk_component(hull)
77
78    component hull configure -borderwidth 1 -background black
79    itk_option remove hull.background hull.borderwidth
80
81    itk_component add icon {
82        label $itk_interior.icon -anchor n
83    }
84
85    itk_component add text {
86        label $itk_interior.text -justify left
87    } {
88        usual
89        keep -wraplength
90    }
91    pack $itk_component(text) -expand yes -fill both -ipadx 4 -ipady 4
92
93    eval itk_initialize $args
94}
95
96# ----------------------------------------------------------------------
97# USAGE: show @<x>,<y>|<widget>+/-<x>,<y>
98#
99# Clients use this to pop up the tooltip on the screen.  The position
100# should be either a <widget> name with an optional offset +/-<x>,<y>
101# (tooltip pops up beneath widget by default), or a specific root
102# window coordinate of the form @x,y.
103#
104# If the -message has the form "@command", then the command is executed
105# now, just before the tooltip is popped up, to build the message
106# on-the-fly.
107# ----------------------------------------------------------------------
108itcl::body Rappture::Tooltip::show {where} {
109    set hull $itk_component(hull)
110    set signx "+"
111    set signy "+"
112
113    if {[regexp {^@([0-9]+),([0-9]+)$} $where match x y]} {
114        set xpos $x
115        set ypos $y
116    } elseif {[regexp {^(.*)([-+])([0-9]+),([-+]?)([0-9]+)$} $where match win signx x signy y]} {
117        if {$signy == ""} { set signy $signx }
118        set xpos [expr {[winfo rootx $win] + $x}]
119        set ypos [expr {[winfo rooty $win] + $y}]
120    } elseif {[winfo exists $where]} {
121        set xpos [expr {[winfo rootx $where]+10}]
122        set ypos [expr {[winfo rooty $where]+[winfo height $where]}]
123    } else {
124        error "bad position \"$where\": should be widget+x,y, or @x,y"
125    }
126
127    if {[string index $itk_option(-message) 0] == "@"} {
128        set cmd [string range $itk_option(-message) 1 end]
129        if {[catch $cmd mesg] != 0} {
130            bgerror $mesg
131            return
132        }
133    } else {
134        set mesg $itk_option(-message)
135    }
136
137    # if there's no message to show, forget it
138    if {[string length $mesg] == 0} {
139        return
140    }
141
142    # strings can't be too big, or they'll go off screen!
143    if {[string length $mesg] > 1000} {
144        set mesg "[string range $mesg 0 1000]..."
145    }
146    set pos 0
147    ::for {set i 0} {$pos >= 0 && $i < 20} {incr i} {
148        incr pos
149        set pos [string first \n $mesg $pos]
150    }
151    if {$pos > 0} {
152        set mesg "[string range $mesg 0 $pos]..."
153    }
154    $itk_component(text) configure -text $mesg
155
156    #
157    # Make sure the tooltip doesn't go off screen.  Then, put it up.
158    #
159    update idletasks
160    if {$signx == "+"} {
161        if {$xpos+[winfo reqwidth $hull] > [winfo screenwidth $hull]} {
162            set xpos [expr {[winfo screenwidth $hull]-[winfo reqwidth $hull]}]
163        }
164        if {$xpos < 0} { set xpos 0 }
165    } else {
166        if {$xpos-[winfo reqwidth $hull] < 0} {
167            set xpos [expr {[winfo screenwidth $hull]-[winfo reqwidth $hull]}]
168        }
169        set xpos [expr {[winfo screenwidth $hull]-$xpos}]
170    }
171
172    if {$signy == "+"} {
173        if {$ypos+[winfo reqheight $hull] > [winfo screenheight $hull]} {
174            set ypos [expr {[winfo screenheight $hull]-[winfo reqheight $hull]}]
175        }
176        if {$ypos < 0} { set ypos 0 }
177    } else {
178        if {$ypos-[winfo reqheight $hull] < 0} {
179            set ypos [expr {[winfo screenheight $hull]-[winfo reqheight $hull]}]
180        }
181        set ypos [expr {[winfo screenheight $hull]-$ypos}]
182    }
183
184    wm geometry $hull $signx$xpos$signy$ypos
185    update
186
187    wm deiconify $hull
188    raise $hull
189}
190
191# ----------------------------------------------------------------------
192# USAGE: hide
193#
194# Takes down the tooltip, if it is showing on the screen.
195# ----------------------------------------------------------------------
196itcl::body Rappture::Tooltip::hide {} {
197    wm withdraw $itk_component(hull)
198}
199
200# ----------------------------------------------------------------------
201# USAGE: for <widget> <text>
202#
203# Used to register the tooltip <text> for a particular <widget>.
204# This sets up bindings on the widget so that, when the mouse pointer
205# lingers over the widget, the tooltip pops up automatically after
206# a small delay.  When the mouse pointer leaves the widget or the
207# user clicks on the widget, it cancels the tip.
208#
209# If the <text> has the form "@command", then the command is executed
210# just before the tip pops up to build the message on-the-fly.
211# ----------------------------------------------------------------------
212itcl::body Rappture::Tooltip::for {widget text} {
213    set catalog($widget) $text
214
215    set btags [bindtags $widget]
216    set i [lsearch $btags RapptureTooltip]
217    if {$i < 0} {
218        set i [lsearch $btags [winfo class $widget]]
219        if {$i < 0} {set i 0}
220        set btags [linsert $btags $i RapptureTooltip]
221        bindtags $widget $btags
222    }
223}
224
225# ----------------------------------------------------------------------
226# USAGE: text <widget> ?<text>?
227#
228# Used to query or set the text used for the tooltip for a widget.
229# This is done automatically when you call the "for" proc, but it
230# is sometimes handy to query or change the text later.
231# ----------------------------------------------------------------------
232itcl::body Rappture::Tooltip::text {widget args} {
233    if {[llength $args] == 0} {
234        if {[info exists catalog($widget)]} {
235            return $catalog($widget)
236        }
237        return ""
238    } elseif {[llength $args] == 1} {
239        set str [lindex $args 0]
240        set catalog($widget) $str
241    } else {
242        error "wrong # args: should be \"text widget ?str?\""
243    }
244}
245
246# ----------------------------------------------------------------------
247# USAGE: tooltip pending <widget> ?@<x>,<y>|+<x>,<y>?
248# USAGE: tooltip show <widget> ?@<x>,<y>|+<x>,<y>?
249# USAGE: tooltip cancel
250#
251# This is invoked automatically whenever the user clicks somewhere
252# inside or outside of the editor.  If the <X>,<Y> coordinate is
253# outside the editor, then we assume the user is done and wants to
254# take the editor down.  Otherwise, we do nothing, and let the entry
255# bindings take over.
256# ----------------------------------------------------------------------
257itcl::body Rappture::Tooltip::tooltip {option args} {
258    switch -- $option {
259        pending {
260            if {[llength $args] < 1 || [llength $args] > 2} {
261                error "wrong # args: should be \"tooltip pending widget ?@x,y?\""
262            }
263            set widget [lindex $args 0]
264            set loc [lindex $args 1]
265
266            if {![info exists catalog($widget)]} {
267                error "can't find tooltip for $widget"
268            }
269            if {$pending != ""} {
270                after cancel $pending
271            }
272            set pending [after 1500 [itcl::code tooltip show $widget $loc]]
273        }
274        show {
275            if {[llength $args] < 1 || [llength $args] > 2} {
276                error "wrong # args: should be \"tooltip pending widget ?@x,y?\""
277            }
278            set widget [lindex $args 0]
279            set loc [lindex $args 1]
280
281            if {[winfo exists $widget]} {
282                .rappturetooltip configure -message $catalog($widget)
283                if {[string index $loc 0] == "@"} {
284                    .rappturetooltip show $loc
285                } elseif {[regexp {^[-+]} $loc]} {
286                    .rappturetooltip show $widget$loc
287                } else {
288                    .rappturetooltip show $widget
289                }
290            }
291        }
292        cancel {
293            if {$pending != ""} {
294                after cancel $pending
295                set pending ""
296            }
297            .rappturetooltip hide
298        }
299        default {
300            error "bad option \"$option\": should be show, pending, cancel"
301        }
302    }
303}
304
305# ----------------------------------------------------------------------
306# USAGE: cue <location> <message>
307# USAGE: cue hide
308#
309# Clients use this to show a <message> in a tooltip cue at the
310# specified <location>, which can be a widget name or a root coordinate
311# at @x,y.
312# ----------------------------------------------------------------------
313itcl::body Rappture::Tooltip::cue {option args} {
314    if {"hide" == $option} {
315        grab release .rappturetoolcue
316        .rappturetoolcue hide
317    } elseif {[regexp {^@[0-9]+,[0-9]+$} $option] || [winfo exists $option]} {
318        if {[llength $args] != 1} {
319            error "wrong # args: should be \"cue location message\""
320        }
321        set loc $option
322        set mesg [lindex $args 0]
323
324        .rappturetoolcue configure -message $mesg
325        .rappturetoolcue show $loc
326
327        #
328        # Add a binding to all widgets so that any keypress will
329        # take this cue down.
330        #
331        set cmd [bind all <KeyPress>]
332        if {![regexp {Rappture::Tooltip::cue} $cmd]} {
333            bind all <KeyPress> "+[list ::Rappture::Tooltip::cue hide]"
334            bind all <KeyPress-Return> "+ "
335        }
336
337        #
338        # If nobody has the pointer, then grab it.  Otherwise,
339        # we assume the pop-up editor or someone like that has
340        # the grab, so we don't need to impose a grab here.
341        #
342        if {"" == [grab current]} {
343            update
344            while {[catch {grab set -global .rappturetoolcue}]} {
345                after 100
346            }
347        }
348    } else {
349        error "bad option \"$option\": should be hide, a widget name, or @x,y"
350    }
351}
352
353# ----------------------------------------------------------------------
354# CONFIGURATION OPTION: -icon
355# ----------------------------------------------------------------------
356itcl::configbody Rappture::Tooltip::icon {
357    if {"" == $itk_option(-icon)} {
358        $itk_component(icon) configure -image ""
359        pack forget $itk_component(icon)
360    } else {
361        $itk_component(icon) configure -image $itk_option(-icon)
362        pack $itk_component(icon) -before $itk_component(text) \
363            -side left -fill y
364    }
365}
366
367# ----------------------------------------------------------------------
368# CONFIGURATION OPTION: -outline
369# ----------------------------------------------------------------------
370itcl::configbody Rappture::Tooltip::outline {
371    component hull configure -background $itk_option(-outline)
372}
373
374# create a tooltip widget to show tool tips
375Rappture::Tooltip .rappturetooltip
376
377# any click on any widget takes down the tooltip
378bind all <Leave> [list ::Rappture::Tooltip::tooltip cancel]
379bind all <ButtonPress> [list ::Rappture::Tooltip::tooltip cancel]
380
381# create a tooltip widget to show error cues
382Rappture::Tooltip .rappturetoolcue \
383    -icon $Rappture::Tooltip::icons(cue) \
384    -background black -outline #333333 -foreground white
385
386# when cue is up, it has a grab, and any click brings it down
387bind .rappturetoolcue <ButtonPress> [list ::Rappture::Tooltip::cue hide]
Note: See TracBrowser for help on using the repository browser.