source: branches/uq/gui/scripts/tooltip.tcl @ 5315

Last change on this file since 5315 was 5315, checked in by mmh, 10 years ago

fix ScreenSize? bug and support multiple UQ runs with different UQ params
File size: 15.9 KB
Line 
1# -*- mode: tcl; indent-tabs-mode: nil -*-
2# ----------------------------------------------------------------------
3#  COMPONENT: tooltip - help information that pops up beneath a widget
4#
5#  This file provides support for tooltips, which are little bits
6#  of help information that pop up beneath a widget.
7#
8#  Tooltips can be registered for various widgets as follows:
9#
10#    Rappture::Tooltip::for .w "Some help text."
11#    Rappture::Tooltip::for .x.y "Some more help text."
12#
13#  Tooltips can also be popped up as an error cue beneath a widget
14#  with bad information:
15#
16#    Rappture::Tooltip::cue .w "Bad data in this widget."
17#
18# ======================================================================
19#  AUTHOR:  Michael McLennan, Purdue University
20#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
21#
22#  See the file "license.terms" for information on usage and
23#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
24# ======================================================================
25package require Itk
26
27option add *Tooltip.background white widgetDefault
28option add *Tooltip.outline black widgetDefault
29option add *Tooltip.borderwidth 1 widgetDefault
30option add *Tooltip.font -*-helvetica-medium-r-normal-*-12-* widgetDefault
31option add *Tooltip.wrapLength 4i widgetDefault
32
33itcl::class Rappture::Tooltip {
34    inherit itk::Toplevel
35
36    itk_option define -outline outline Outline ""
37    itk_option define -icon icon Icon ""
38    itk_option define -message message Message ""
39    itk_option define -log log Log ""
40
41    constructor {args} { # defined below }
42
43    public method show {where}
44    public method hide {}
45
46    private variable _showing 0  ;# time when tooltip popped up on screen
47
48    public proc for {widget text args}
49    public proc text {widget args}
50    private common catalog    ;# maps widget => -message and -log
51
52    public proc tooltip {option args}
53    private common pending "" ;# after ID for pending "tooltip show"
54
55    public proc cue {option args}
56
57    bind RapptureTooltip <Enter> \
58        [list ::Rappture::Tooltip::tooltip pending %W]
59    bind RapptureTooltip <Leave> \
60        [list ::Rappture::Tooltip::tooltip cancel]
61    bind RapptureTooltip <ButtonPress> \
62        [list ::Rappture::Tooltip::tooltip cancel]
63    bind RapptureTooltip <KeyPress> \
64        [list ::Rappture::Tooltip::tooltip cancel]
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 _showing 0
111
112    set signx "+"
113    set signy "+"
114
115    if {[regexp {^@([0-9]+),([0-9]+)$} $where match x y]} {
116        set xpos $x
117        set ypos $y
118    } elseif {[regexp {^(.*)([-+])([0-9]+),([-+]?)([0-9]+)$} $where match win signx x signy y]} {
119        if {$signy == ""} { set signy $signx }
120        set xpos [expr {[winfo rootx $win] + $x}]
121        set ypos [expr {[winfo rooty $win] + $y}]
122    } elseif {[winfo exists $where]} {
123        set xpos [expr {[winfo rootx $where]+10}]
124        set ypos [expr {[winfo rooty $where]+[winfo height $where]}]
125    } else {
126        error "bad position \"$where\": should be widget+x,y, or @x,y"
127    }
128
129    if {[string index $itk_option(-message) 0] == "@"} {
130        set cmd [string range $itk_option(-message) 1 end]
131        if {[catch $cmd mesg] != 0} {
132            bgerror $mesg
133            return
134        }
135    } else {
136        set mesg $itk_option(-message)
137    }
138
139    # if there's no message to show, forget it
140    if {[string length $mesg] == 0} {
141        return
142    }
143
144    # strings can't be too big, or they'll go off screen!
145    set pos 0
146    ::for {set i 0} {$pos >= 0 && $i < 20} {incr i} {
147        incr pos
148        set pos [string first \n $mesg $pos]
149    }
150    if {$pos > 0} {
151        set mesg "[string range $mesg 0 $pos]..."
152    }
153    if {[string length $mesg] > 1000} {
154        set mesg "[string range $mesg 0 1500]..."
155    }
156    $itk_component(text) configure -text $mesg
157
158    #
159    # Make sure the tooltip doesn't go off screen.
160    #
161    update idletasks
162    foreach {screenw screenh} [Rappture::ScreenSize] break
163    if {$signx == "+"} {
164        if {$xpos+[winfo reqwidth $hull] > $screenw} {
165            set xpos [expr {$screenw-[winfo reqwidth $hull]}]
166        }
167        if {$xpos < 0} { set xpos 0 }
168    } else {
169        if {$xpos-[winfo reqwidth $hull] < 0} {
170            set xpos [expr {$screenw-[winfo reqwidth $hull]}]
171        }
172        set xpos [expr {$screenw-$xpos}]
173    }
174
175    if {$signy == "+"} {
176        if {$ypos+[winfo reqheight $hull] > $screenh} {
177            set ypos [expr {$screenh-[winfo reqheight $hull]}]
178        }
179        if {$ypos < 0} { set ypos 0 }
180    } else {
181        if {$ypos-[winfo reqheight $hull] < 0} {
182            set ypos [expr {$screenh-[winfo reqheight $hull]}]
183        }
184        set ypos [expr {$screenh-$ypos}]
185    }
186
187    #
188    # Will the tooltip pop up under the mouse pointer?  If so, then
189    # it will just disappear.  Doh!  We should figure out a better
190    # place to pop it up.
191    #
192    set px [winfo pointerx $hull]
193    set py [winfo pointery $hull]
194    if {$px >= $xpos && $px <= $xpos+[winfo reqwidth $hull]
195          && $py >= $ypos && $py <= $ypos+[winfo reqheight $hull]} {
196
197        if {$px > $screenw/2} {
198            set signx "-"
199            set xpos [expr {$screenw-$px+4}]
200        } else {
201            set signx "+"
202            set xpos [expr {$px+4}]
203        }
204        if {$py > $screenh/2} {
205            set signy "-"
206            set ypos [expr {$screenh-$py+4}]
207        } else {
208            set signy "+"
209            set ypos [expr {$py+4}]
210        }
211    }
212
213    #
214    # Finally, put it up.
215    #
216    wm geometry $hull $signx$xpos$signy$ypos
217    update
218
219    wm deiconify $hull
220    raise $hull
221
222    #
223    # If logging is enabled, grab the start time.  We'll need this
224    # info later during the "hide" step to log activity.
225    #
226    if {$itk_option(-log) ne ""} {
227        set _showing [clock seconds]
228    }
229}
230
231# ----------------------------------------------------------------------
232# USAGE: hide
233#
234# Takes down the tooltip, if it is showing on the screen.
235# ----------------------------------------------------------------------
236itcl::body Rappture::Tooltip::hide {} {
237    wm withdraw $itk_component(hull)
238
239    #
240    # If logging is enabled and the time is non-zero, then log
241    # the activity on this tooltip.
242    #
243    if {$itk_option(-log) ne "" && $_showing > 0} {
244        set dt [expr {[clock seconds] - $_showing}]
245        if {$dt > 0} {
246            Rappture::Logger::log tooltip -for $itk_option(-log) -time $dt
247        }
248    }
249    set _showing 0
250}
251
252# ----------------------------------------------------------------------
253# USAGE: for <widget> <text> ?-log <name>?
254#
255# Used to register the tooltip <text> for a particular <widget>.
256# This sets up bindings on the widget so that, when the mouse pointer
257# lingers over the widget, the tooltip pops up automatically after
258# a small delay.  When the mouse pointer leaves the widget or the
259# user clicks on the widget, it cancels the tip.
260#
261# If the <text> has the form "@command", then the command is executed
262# just before the tip pops up to build the message on-the-fly.
263#
264# The -log option turns logging on/off for this tooltip.  Logging is
265# useful when you want to keep track of whether the user is looking at
266# tooltips and for how long.  If the <name> is specified, then any
267# activity on the tooltip is reported with that name on the log line.
268# If the name is not specified or "", then the activity is not logged.
269# ----------------------------------------------------------------------
270itcl::body Rappture::Tooltip::for {widget text args} {
271    Rappture::getopts args params {
272        value -log ""
273    }
274    if {[llength $args] > 0} {
275        error "wrong # args: should be \"for widget text ?-log name?\""
276    }
277
278    set catalog($widget-message) $text
279    set catalog($widget-log) $params(-log)
280
281    set btags [bindtags $widget]
282    set i [lsearch $btags RapptureTooltip]
283    if {$i < 0} {
284        set i [lsearch $btags [winfo class $widget]]
285        if {$i < 0} {set i 0}
286        set btags [linsert $btags $i RapptureTooltip]
287        bindtags $widget $btags
288    }
289}
290
291# ----------------------------------------------------------------------
292# USAGE: text <widget> ?<text>? ?-log name?
293#
294# Used to query or set the text used for the tooltip for a widget.
295# This is done automatically when you call the "for" proc, but it
296# is sometimes handy to query or change the text later.
297# ----------------------------------------------------------------------
298itcl::body Rappture::Tooltip::text {widget args} {
299    if {[llength $args] == 0} {
300        if {[info exists catalog($widget-message)]} {
301            return $catalog($widget-message)
302        }
303        return ""
304    }
305
306    # set the text for the tooltip
307    set str [lindex $args 0]
308    set args [lrange $args 1 end]
309
310    Rappture::getopts args params {
311        value -log ""
312    }
313    if {[llength $args] > 0} {
314        error "wrong # args: should be \"text widget ?str? ?-log name?\""
315    }
316
317    set catalog($widget-message) $str
318    set catalog($widget-log) $params(-log)
319}
320
321# ----------------------------------------------------------------------
322# USAGE: tooltip pending <widget> ?@<x>,<y>|+<x>,<y>?
323# USAGE: tooltip show <widget> ?@<x>,<y>|+<x>,<y>?
324# USAGE: tooltip cancel
325#
326# This is invoked automatically whenever the user clicks somewhere
327# inside or outside of the editor.  If the <X>,<Y> coordinate is
328# outside the editor, then we assume the user is done and wants to
329# take the editor down.  Otherwise, we do nothing, and let the entry
330# bindings take over.
331# ----------------------------------------------------------------------
332itcl::body Rappture::Tooltip::tooltip {option args} {
333    switch -- $option {
334        pending {
335            if {[llength $args] < 1 || [llength $args] > 2} {
336                error "wrong # args: should be \"tooltip pending widget ?@x,y?\""
337            }
338            set widget [lindex $args 0]
339            set loc [lindex $args 1]
340
341            if {![info exists catalog($widget-message)]} {
342                return;                        # No tooltip for widget.
343            }
344            if {$pending != ""} {
345                after cancel $pending
346            }
347            set pending [after 750 [itcl::code tooltip show $widget $loc]]
348        }
349        show {
350            if {[llength $args] < 1 || [llength $args] > 2} {
351                error "wrong # args: should be \"tooltip show tag loc\""
352            }
353            set tag [lindex $args 0]
354            set loc [lindex $args 1]
355
356            # tag name may be .g-axis -- get widget ".g" part
357            set widget $tag
358            if {[regexp {^(\.[^-]+)-[^\.]+$} $widget match wname]} {
359                set widget $wname
360            }
361
362            if {[winfo exists $widget] && [info exists catalog($tag-message)]} {
363                .rappturetooltip configure \
364                    -message $catalog($tag-message) \
365                    -log $catalog($tag-log)
366
367                if {[string index $loc 0] == "@"} {
368                    .rappturetooltip show $loc
369                } elseif {[regexp {^[-+]} $loc]} {
370                    .rappturetooltip show $widget$loc
371                } else {
372                    .rappturetooltip show $widget
373                }
374            }
375        }
376        cancel {
377            if {$pending != ""} {
378                after cancel $pending
379                set pending ""
380            }
381            .rappturetooltip hide
382        }
383        default {
384            error "bad option \"$option\": should be show, pending, cancel"
385        }
386    }
387}
388
389# ----------------------------------------------------------------------
390# USAGE: cue <location> <message>
391# USAGE: cue hide
392#
393# Clients use this to show a <message> in a tooltip cue at the
394# specified <location>, which can be a widget name or a root coordinate
395# at @x,y.
396# ----------------------------------------------------------------------
397itcl::body Rappture::Tooltip::cue {option args} {
398    if {"hide" == $option} {
399        grab release .rappturetoolcue
400        .rappturetoolcue hide
401    } elseif {[regexp {^@[0-9]+,[0-9]+$} $option] || [winfo exists $option]} {
402        if {[llength $args] != 1} {
403            error "wrong # args: should be \"cue location message\""
404        }
405        set loc $option
406        set mesg [lindex $args 0]
407
408        .rappturetoolcue configure -message $mesg
409        .rappturetoolcue show $loc
410
411        #
412        # Add a binding to all widgets so that any keypress will
413        # take this cue down.
414        #
415        set cmd [bind all <KeyPress>]
416        if {![regexp {Rappture::Tooltip::cue} $cmd]} {
417            bind all <KeyPress> "+[list ::Rappture::Tooltip::cue hide]"
418            bind all <KeyPress-Return> "+ "
419        }
420
421        #
422        # If nobody has the pointer, then grab it.  Otherwise,
423        # we assume the pop-up editor or someone like that has
424        # the grab, so we don't need to impose a grab here.
425        #
426        if {"" == [grab current]} {
427            update
428            while {[catch {grab set -global .rappturetoolcue}]} {
429                after 100
430            }
431        }
432    } else {
433        error "bad option \"$option\": should be hide, a widget name, or @x,y"
434    }
435}
436
437# ----------------------------------------------------------------------
438# CONFIGURATION OPTION: -icon
439# ----------------------------------------------------------------------
440itcl::configbody Rappture::Tooltip::icon {
441    if {"" == $itk_option(-icon)} {
442        $itk_component(icon) configure -image ""
443        pack forget $itk_component(icon)
444    } else {
445        $itk_component(icon) configure -image $itk_option(-icon)
446        pack $itk_component(icon) -before $itk_component(text) \
447            -side left -fill y
448    }
449}
450
451# ----------------------------------------------------------------------
452# CONFIGURATION OPTION: -outline
453# ----------------------------------------------------------------------
454itcl::configbody Rappture::Tooltip::outline {
455    component hull configure -background $itk_option(-outline)
456}
457
458# ----------------------------------------------------------------------
459# CONFIGURATION OPTION: -log
460# ----------------------------------------------------------------------
461itcl::configbody Rappture::Tooltip::log {
462    # logging options changed -- reset showing time
463    set _showing 0
464}
465
466# create a tooltip widget to show tool tips
467Rappture::Tooltip .rappturetooltip
468
469# any click on any widget takes down the tooltip
470bind all <Leave> [list ::Rappture::Tooltip::tooltip cancel]
471bind all <ButtonPress> [list ::Rappture::Tooltip::tooltip cancel]
472
473# create a tooltip widget to show error cues
474Rappture::Tooltip .rappturetoolcue \
475    -icon [Rappture::icon cue24] \
476    -background black -outline #333333 -foreground white
477
478# when cue is up, it has a grab, and any click brings it down
479bind .rappturetoolcue <ButtonPress> [list ::Rappture::Tooltip::cue hide]
Note: See TracBrowser for help on using the repository browser.