From c599e009061af49582e619ccdeca2a749ee3ab15 Mon Sep 17 00:00:00 2001
From: Hans-Christoph Steiner <eighthave@users.sourceforge.net>
Date: Tue, 25 Jan 2011 00:31:36 +0000
Subject: converted to use tcllib's tooltip package

svn path=/trunk/scripts/guiplugins/buttonbar-plugin/; revision=14816
---
 balloonhelp.tcl      |  97 -----------
 buttonbar-plugin.tcl |   9 +-
 pkgIndex.tcl         |  10 ++
 tooltip-1.4.2.tcl    | 447 +++++++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 462 insertions(+), 101 deletions(-)
 delete mode 100644 balloonhelp.tcl
 create mode 100644 pkgIndex.tcl
 create mode 100644 tooltip-1.4.2.tcl

diff --git a/balloonhelp.tcl b/balloonhelp.tcl
deleted file mode 100644
index 71f6130..0000000
--- a/balloonhelp.tcl
+++ /dev/null
@@ -1,97 +0,0 @@
-package provide balloonhelp 0.1
-
-package require Tk
-
-namespace eval balloonhelp {
-    set mytoplevel ".balloonhelp"
-}
-
-proc ::balloonhelp::setBalloonHelp {w msg args} {
-    variable mytoplevel
-    array set opt [concat {
-        -tag ""
-    } $args]
-    if {$msg ne ""} then {
-        set toolTipScript\
-            [list balloonhelp::showBalloonHelp %W [string map {% %%} $msg]]
-        set enterScript [list after 1000 $toolTipScript]
-        set leaveScript [list after cancel $toolTipScript]
-        append leaveScript \n [list after 200 [list destroy $mytoplevel]]
-    } else {
-        set enterScript {}
-        set leaveScript {}
-    }
-    if {$opt(-tag) ne ""} then {
-        switch -- [winfo class $w] {
-            Text {
-                $w tag bind $opt(-tag) <Enter> $enterScript
-                $w tag bind $opt(-tag) <Leave> $leaveScript
-            }
-            Canvas {
-                $w bind $opt(-tag) <Enter> $enterScript
-                $w bind $opt(-tag) <Leave> $leaveScript
-            }
-            default {
-                bind $w <Enter> $enterScript
-                bind $w <Leave> $leaveScript
-            }
-        }
-    } else {
-        bind $w <Enter> $enterScript
-        bind $w <Leave> $leaveScript
-    }
-}
-
-proc ::balloonhelp::showBalloonHelp {w msg} {
-    variable mytoplevel
-    catch {destroy $mytoplevel}
-    toplevel $mytoplevel -bg grey
-    wm overrideredirect $mytoplevel yes
-    switch -- $::windowingsystem {
-        "aqua" {
-            wm attributes $mytoplevel -topmost 1 -transparent 1 -alpha 0.8
-            ::tk::unsupported::MacWindowStyle style $mytoplevel floating {noTitleBar noShadow}
-        }
-        "x11" {
-            wm attributes $mytoplevel -alpha 0.8
-        }
-        "win32" {
-            wm attributes $mytoplevel -topmost 1 -alpha 0.8
-        }
-    }
-    pack [label $mytoplevel.l -text [subst $msg] -bg yellow -font {Helvetica 9}]\
-        -padx 1\
-        -pady 1
-    set width [expr {[winfo reqwidth $mytoplevel.l] + 2}]
-    set height [expr {[winfo reqheight $mytoplevel.l] + 2}]
-    set xMax [expr {[winfo screenwidth $w] - $width}]
-    set yMax [expr {[winfo screenheight $w] - $height}]
-    set x [expr [winfo pointerx $w] + 5]
-    set y [expr {[winfo pointery $w] + 10}]
-    if {$x > $xMax} then {
-        set x $xMax
-    }
-    if {$y > $yMax} then {
-        set y $yMax
-    }
-    wm geometry $mytoplevel +$x+$y
-    set destroyScript [list destroy .balloonhelp]
-    bind $mytoplevel <Enter> [list after cancel $destroyScript]
-    bind $mytoplevel <Leave> $destroyScript
-}
-
-# demo
-if false {
-    pack [button .b -text tryme -command {puts "you did it!"}]
-    balloonhelp::setBalloonHelp .b "Text that describes\nwhat the button does"
-    #
-    pack [text .t -width 30 -height 5] -expand yes -fill both
-    .t insert end abcDEFghi
-    .t tag configure yellow -background yellow
-    .t tag add yellow 1.1 1.6
-    balloonhelp::setBalloonHelp .t "Colorised Text" -tag yellow
-    #
-    pack [canvas .c] -expand yes -fill both
-    set id [.c create rectangle 10 10 100 100 -fill white]
-    balloonhelp::setBalloonHelp .c {Geometry: [.c coords $::id]} -tag $id
-}
diff --git a/buttonbar-plugin.tcl b/buttonbar-plugin.tcl
index c14e6e3..f2975c3 100644
--- a/buttonbar-plugin.tcl
+++ b/buttonbar-plugin.tcl
@@ -5,9 +5,10 @@
 # not in Edit Mode.  Also, if a patch is switched to Run Mode, the
 # menubar will be removed.
 
+lappend ::auto_path $::current_plugin_loadpath
+
 package require base64
-#package require buttonhelp
-eval [read [open [file join $::current_plugin_loadpath balloonhelp.tcl]]]
+package require tooltip 1.4.2
 
 proc make_pd_button {mytoplevel name description} {
     button $mytoplevel.buttonbar.$name -image buttonimage$name \
@@ -15,7 +16,7 @@ proc make_pd_button {mytoplevel name description} {
         -highlightcolor grey -highlightbackground grey -padx 0 -pady 0 \
         -command "menu_send_float \$::focused_window $name 0"
     pack $mytoplevel.buttonbar.$name -side left -padx 0 -pady 0
-    balloonhelp::setBalloonHelp $mytoplevel.buttonbar.$name $description
+    ::tooltip::tooltip $mytoplevel.buttonbar.$name $description
 }
 
 proc make_iemgui_button {mytoplevel name description} {
@@ -24,7 +25,7 @@ proc make_iemgui_button {mytoplevel name description} {
         -highlightcolor grey -highlightbackground grey -padx 0 -pady 0 \
         -command "menu_send \$::focused_window $name"
     pack $mytoplevel.buttonbar.$name -side left -padx 0 -pady 0
-    balloonhelp::setBalloonHelp $mytoplevel.buttonbar.$name $description
+    ::tooltip::tooltip $mytoplevel.buttonbar.$name $description
 }
 
 proc showhide_buttonbar {mytoplevel} {
diff --git a/pkgIndex.tcl b/pkgIndex.tcl
new file mode 100644
index 0000000..ff70e2d
--- /dev/null
+++ b/pkgIndex.tcl
@@ -0,0 +1,10 @@
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script.  It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands.  When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+package ifneeded tooltip 1.4.2 [list source [file join $dir tooltip-1.4.2.tcl]]
diff --git a/tooltip-1.4.2.tcl b/tooltip-1.4.2.tcl
new file mode 100644
index 0000000..151583a
--- /dev/null
+++ b/tooltip-1.4.2.tcl
@@ -0,0 +1,447 @@
+# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*-
+# -- Tcl Module
+
+# @@ Meta Begin
+# Package tooltip 1.4.2
+# Meta as::origin  http://sourceforge.net/projects/tcllib
+# Meta category    Tooltip management
+# Meta description Tooltip management
+# Meta platform    tcl
+# Meta require     {Tk 8.4}
+# Meta require     msgcat
+# Meta subject     hover help balloon tooltip
+# Meta summary     tooltip
+# @@ Meta End
+
+
+
+# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS
+
+package require Tk 8.4
+package require msgcat
+
+# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS
+
+# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE
+
+package provide tooltip 1.4.2
+
+# ACTIVESTATE TEAPOT-PKG END DECLARE
+# ACTIVESTATE TEAPOT-PKG END TM
+# tooltip.tcl --
+#
+#       Balloon help
+#
+# Copyright (c) 1996-2007 Jeffrey Hobbs
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# 
+# RCS: @(#) $Id: tooltip.tcl,v 1.14 2008/08/08 22:50:13 patthoyts Exp $
+#
+# Initiated: 28 October 1996
+
+
+package require Tk 8.4
+package provide tooltip 1.4.2
+package require msgcat
+
+#------------------------------------------------------------------------
+# PROCEDURE
+#	tooltip::tooltip
+#
+# DESCRIPTION
+#	Implements a tooltip (balloon help) system
+#
+# ARGUMENTS
+#	tooltip <option> ?arg?
+#
+# clear ?pattern?
+#	Stops the specified widgets (defaults to all) from showing tooltips
+#
+# delay ?millisecs?
+#	Query or set the delay.  The delay is in milliseconds and must
+#	be at least 50.  Returns the delay.
+#
+# disable OR off
+#	Disables all tooltips.
+#
+# enable OR on
+#	Enables tooltips for defined widgets.
+#
+# <widget> ?-index index? ?-item id? ?message?
+#	If -index is specified, then <widget> is assumed to be a menu
+#	and the index represents what index into the menu (either the
+#	numerical index or the label) to associate the tooltip message with.
+#	Tooltips do not appear for disabled menu items.
+#	If message is {}, then the tooltip for that widget is removed.
+#	The widget must exist prior to calling tooltip.  The current
+#	tooltip message for <widget> is returned, if any.
+#
+# RETURNS: varies (see methods above)
+#
+# NAMESPACE & STATE
+#	The namespace tooltip is used.
+#	Control toplevel name via ::tooltip::wname.
+#
+# EXAMPLE USAGE:
+#	tooltip .button "A Button"
+#	tooltip .menu -index "Load" "Loads a file"
+#
+#------------------------------------------------------------------------
+
+namespace eval ::tooltip {
+    namespace export -clear tooltip
+    variable tooltip
+    variable G
+
+    array set G {
+	enabled		1
+	fade		1
+	FADESTEP	0.2
+	FADEID		{}
+	DELAY		500
+	AFTERID		{}
+	LAST		-1
+	TOPLEVEL	.__tooltip__
+    }
+    if {[tk windowingsystem] eq "x11"} {
+	set G(fade) 0 ; # don't fade by default on X11
+    }
+    # The extra ::hide call in <Enter> is necessary to catch moving to
+    # child widgets where the <Leave> event won't be generated
+    bind Tooltip <Enter> [namespace code {
+	#tooltip::hide
+	variable tooltip
+	variable G
+	set G(LAST) -1
+	if {$G(enabled) && [info exists tooltip(%W)]} {
+	    set G(AFTERID) \
+		[after $G(DELAY) [namespace code [list show %W $tooltip(%W) cursor]]]
+	}
+    }]
+
+    bind Menu <<MenuSelect>>	[namespace code { menuMotion %W }]
+    bind Tooltip <Leave>	[namespace code [list hide 1]] ; # fade ok
+    bind Tooltip <Any-KeyPress>	[namespace code hide]
+    bind Tooltip <Any-Button>	[namespace code hide]
+}
+
+proc ::tooltip::tooltip {w args} {
+    variable tooltip
+    variable G
+    switch -- $w {
+	clear	{
+	    if {[llength $args]==0} { set args .* }
+	    clear $args
+	}
+	delay	{
+	    if {[llength $args]} {
+		if {![string is integer -strict $args] || $args<50} {
+		    return -code error "tooltip delay must be an\
+			    integer greater than 50 (delay is in millisecs)"
+		}
+		return [set G(DELAY) $args]
+	    } else {
+		return $G(DELAY)
+	    }
+	}
+	fade	{
+	    if {[llength $args]} {
+		set G(fade) [string is true -strict [lindex $args 0]]
+	    }
+	    return $G(fade)
+	}
+	off - disable	{
+	    set G(enabled) 0
+	    hide
+	}
+	on - enable	{
+	    set G(enabled) 1
+	}
+	default {
+	    set i $w
+	    if {[llength $args]} {
+		set i [uplevel 1 [namespace code "register [list $w] $args"]]
+	    }
+	    set b $G(TOPLEVEL)
+	    if {![winfo exists $b]} {
+		toplevel $b -class Tooltip
+		if {[tk windowingsystem] eq "aqua"} {
+		    ::tk::unsupported::MacWindowStyle style $b help none
+		} else {
+		    wm overrideredirect $b 1
+		}
+		catch {wm attributes $b -topmost 1}
+		# avoid the blink issue with 1 to <1 alpha on Windows
+		catch {wm attributes $b -alpha 0.99}
+		wm positionfrom $b program
+		wm withdraw $b
+		label $b.label -highlightthickness 0 -relief solid -bd 1 \
+			-background lightyellow -fg black
+		pack $b.label -ipadx 1
+	    }
+	    if {[info exists tooltip($i)]} { return $tooltip($i) }
+	}
+    }
+}
+
+proc ::tooltip::register {w args} {
+    variable tooltip
+    set key [lindex $args 0]
+    while {[string match -* $key]} {
+	switch -- $key {
+	    -index	{
+		if {[catch {$w entrycget 1 -label}]} {
+		    return -code error "widget \"$w\" does not seem to be a\
+			    menu, which is required for the -index switch"
+		}
+		set index [lindex $args 1]
+		set args [lreplace $args 0 1]
+	    }
+	    -item	{
+		set namedItem [lindex $args 1]
+		if {[catch {$w find withtag $namedItem} item]} {
+		    return -code error "widget \"$w\" is not a canvas, or item\
+			    \"$namedItem\" does not exist in the canvas"
+		}
+		if {[llength $item] > 1} {
+		    return -code error "item \"$namedItem\" specifies more\
+			    than one item on the canvas"
+		}
+		set args [lreplace $args 0 1]
+	    }
+            -tag {
+                set tag [lindex $args 1]
+                set r [catch {lsearch -exact [$w tag names] $tag} ndx]
+                if {$r || $ndx == -1} {
+                    return -code error "widget \"$w\" is not a text widget or\
+                        \"$tag\" is not a text tag"
+                }
+                set args [lreplace $args 0 1]
+            }
+	    default	{
+		return -code error "unknown option \"$key\":\
+			should be -index or -item"
+	    }
+	}
+	set key [lindex $args 0]
+    }
+    if {[llength $args] != 1} {
+	return -code error "wrong # args: should be \"tooltip widget\
+		?-index index? ?-item item? ?-tag tag? message\""
+    }
+    if {$key eq ""} {
+	clear $w
+    } else {
+	if {![winfo exists $w]} {
+	    return -code error "bad window path name \"$w\""
+	}
+	if {[info exists index]} {
+	    set tooltip($w,$index) $key
+	    return $w,$index
+	} elseif {[info exists item]} {
+	    set tooltip($w,$item) $key
+	    enableCanvas $w $item
+	    return $w,$item
+        } elseif {[info exists tag]} {
+            set tooltip($w,t_$tag) $key
+            enableTag $w $tag
+            return $w,$tag
+	} else {
+	    set tooltip($w) $key
+	    bindtags $w [linsert [bindtags $w] end "Tooltip"]
+	    return $w
+	}
+    }
+}
+
+proc ::tooltip::clear {{pattern .*}} {
+    variable tooltip
+    # cache the current widget at pointer
+    set ptrw [winfo containing [winfo pointerx .] [winfo pointery .]]
+    foreach w [array names tooltip $pattern] {
+	unset tooltip($w)
+	if {[winfo exists $w]} {
+	    set tags [bindtags $w]
+	    if {[set i [lsearch -exact $tags "Tooltip"]] != -1} {
+		bindtags $w [lreplace $tags $i $i]
+	    }
+	    ## We don't remove TooltipMenu because there
+	    ## might be other indices that use it
+
+	    # Withdraw the tooltip if we clear the current contained item
+	    if {$ptrw eq $w} { hide }
+	}
+    }
+}
+
+proc ::tooltip::show {w msg {i {}}} {
+    if {![winfo exists $w]} { return }
+
+    # Use string match to allow that the help will be shown when
+    # the pointer is in any child of the desired widget
+    if {([winfo class $w] ne "Menu")
+	&& ![string match $w* [eval [list winfo containing] \
+				   [winfo pointerxy $w]]]} {
+	return
+    }
+
+    variable G
+
+    after cancel $G(FADEID)
+    set b $G(TOPLEVEL)
+    # Use late-binding msgcat (lazy translation) to support programs
+    # that allow on-the-fly l10n changes
+    $b.label configure -text $msg -justify left
+    update idletasks
+    set screenw [winfo screenwidth $w]
+    set screenh [winfo screenheight $w]
+    set reqw [winfo reqwidth $b]
+    set reqh [winfo reqheight $b]
+    # When adjusting for being on the screen boundary, check that we are
+    # near the "edge" already, as Tk handles multiple monitors oddly
+    if {$i eq "cursor"} {
+	set y [expr {[winfo pointery $w]+20}]
+	if {($y < $screenh) && ($y+$reqh) > $screenh} {
+	    set y [expr {[winfo pointery $w]-$reqh-5}]
+	}
+    } elseif {$i ne ""} {
+	set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[$w yposition $i]+25}]
+	if {($y < $screenh) && ($y+$reqh) > $screenh} {
+	    # show above if we would be offscreen
+	    set y [expr {[winfo rooty $w]+[$w yposition $i]-$reqh-5}]
+	}
+    } else {
+	set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[winfo height $w]+5}]
+	if {($y < $screenh) && ($y+$reqh) > $screenh} {
+	    # show above if we would be offscreen
+	    set y [expr {[winfo rooty $w]-$reqh-5}]
+	}
+    }
+    if {$i eq "cursor"} {
+	set x [winfo pointerx $w]
+    } else {
+	set x [expr {[winfo rootx $w]+[winfo vrootx $w]+
+		     ([winfo width $w]-$reqw)/2}]
+    }
+    # only readjust when we would appear right on the screen edge
+    if {$x<0 && ($x+$reqw)>0} {
+	set x 0
+    } elseif {($x < $screenw) && ($x+$reqw) > $screenw} {
+	set x [expr {$screenw-$reqw}]
+    }
+    if {[tk windowingsystem] eq "aqua"} {
+	set focus [focus]
+    }
+    # avoid the blink issue with 1 to <1 alpha on Windows, watch half-fading
+    catch {wm attributes $b -alpha 0.99}
+    wm geometry $b +$x+$y
+    wm deiconify $b
+    raise $b
+    if {[tk windowingsystem] eq "aqua" && $focus ne ""} {
+	# Aqua's help window steals focus on display
+	after idle [list focus -force $focus]
+    }
+}
+
+proc ::tooltip::menuMotion {w} {
+    variable G
+
+    if {$G(enabled)} {
+	variable tooltip
+
+        # Menu events come from a funny path, map to the real path.
+        set m [string map {"#" "."} [winfo name $w]]
+	set cur [$w index active]
+
+	# The next two lines (all uses of LAST) are necessary until the
+	# <<MenuSelect>> event is properly coded for Unix/(Windows)?
+	if {$cur == $G(LAST)} return
+	set G(LAST) $cur
+	# a little inlining - this is :hide
+	after cancel $G(AFTERID)
+	catch {wm withdraw $G(TOPLEVEL)}
+	if {[info exists tooltip($m,$cur)] || \
+		(![catch {$w entrycget $cur -label} cur] && \
+		[info exists tooltip($m,$cur)])} {
+	    set G(AFTERID) [after $G(DELAY) \
+		    [namespace code [list show $w $tooltip($m,$cur) cursor]]]
+	}
+    }
+}
+
+proc ::tooltip::hide {{fadeOk 0}} {
+    variable G
+
+    after cancel $G(AFTERID)
+    after cancel $G(FADEID)
+    if {$fadeOk && $G(fade)} {
+	fade $G(TOPLEVEL) $G(FADESTEP)
+    } else {
+	catch {wm withdraw $G(TOPLEVEL)}
+    }
+}
+
+proc ::tooltip::fade {w step} {
+    if {[catch {wm attributes $w -alpha} alpha] || $alpha <= 0.0} {
+        catch { wm withdraw $w }
+        catch { wm attributes $w -alpha 0.99 }
+    } else {
+	variable G
+        wm attributes $w -alpha [expr {$alpha-$step}]
+        set G(FADEID) [after 50 [namespace code [list fade $w $step]]]
+    }
+}
+
+proc ::tooltip::wname {{w {}}} {
+    variable G
+    if {[llength [info level 0]] > 1} {
+	# $w specified
+	if {$w ne $G(TOPLEVEL)} {
+	    hide
+	    destroy $G(TOPLEVEL)
+	    set G(TOPLEVEL) $w
+	}
+    }
+    return $G(TOPLEVEL)
+}
+
+proc ::tooltip::itemTip {w args} {
+    variable tooltip
+    variable G
+
+    set G(LAST) -1
+    set item [$w find withtag current]
+    if {$G(enabled) && [info exists tooltip($w,$item)]} {
+	set G(AFTERID) [after $G(DELAY) \
+		[namespace code [list show $w $tooltip($w,$item) cursor]]]
+    }
+}
+
+proc ::tooltip::enableCanvas {w args} {
+    if {[string match *itemTip* [$w bind all <Enter>]]} { return }
+    $w bind all <Enter> +[namespace code [list itemTip $w]]
+    $w bind all <Leave>	+[namespace code [list hide 1]] ; # fade ok
+    $w bind all <Any-KeyPress> +[namespace code hide]
+    $w bind all <Any-Button> +[namespace code hide]
+}
+
+proc ::tooltip::tagTip {w tag} {
+    variable tooltip
+    variable G
+    set G(LAST) -1
+    if {$G(enabled) && [info exists tooltip($w,t_$tag)]} {
+        if {[info exists G(AFTERID)]} { after cancel $G(AFTERID) }
+        set G(AFTERID) [after $G(DELAY) \
+            [namespace code [list show $w $tooltip($w,t_$tag) cursor]]]
+    }
+}
+
+proc ::tooltip::enableTag {w tag} {
+    if {[string match *tagTip* [$w tag bind $tag]]} { return }
+    $w tag bind $tag <Enter> +[namespace code [list tagTip $w $tag]]
+    $w tag bind $tag <Leave> +[namespace code [list hide 1]] ; # fade ok
+    $w tag bind $tag <Any-KeyPress> +[namespace code hide]
+    $w tag bind $tag <Any-Button> +[namespace code hide]
+}
-- 
cgit v1.2.1