--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/python-2.5.2/win32/tcl/tix8.4/Balloon.tcl Fri Apr 03 17:19:34 2009 +0100
@@ -0,0 +1,579 @@
+# -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
+#
+# $Id: Balloon.tcl,v 1.6 2004/03/28 02:44:57 hobbs Exp $
+#
+# Balloon.tcl --
+#
+# The help widget. It provides both "balloon" type of help
+# message and "status bar" type of help message. You can use
+# this widget to indicate the function of the widgets inside
+# your application.
+#
+# Copyright (c) 1993-1999 Ioi Kim Lam.
+# Copyright (c) 2000-2001 Tix Project Group.
+# Copyright (c) 2004 ActiveState
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+
+tixWidgetClass tixBalloon {
+ -classname TixBalloon
+ -superclass tixShell
+ -method {
+ bind post unbind
+ }
+ -flag {
+ -installcolormap -initwait -state -statusbar -cursor
+ }
+ -configspec {
+ {-installcolormap installColormap InstallColormap false}
+ {-initwait initWait InitWait 1000}
+ {-state state State both}
+ {-statusbar statusBar StatusBar ""}
+ {-cursor cursor Cursor left_ptr}
+ }
+ -default {
+ {*background #ffff60}
+ {*foreground black}
+ {*borderWidth 0}
+ {.borderWidth 1}
+ {.background black}
+ {*Label.anchor w}
+ {*Label.justify left}
+ }
+}
+# static seem to be -installcolormap -initwait -statusbar -cursor
+
+# Class Record
+#
+global tixBalloon
+set tixBalloon(bals) ""
+
+proc tixBalloon:InitWidgetRec {w} {
+ upvar #0 $w data
+ global tixBalloon
+
+ tixChainMethod $w InitWidgetRec
+
+ set data(isActive) 0
+ set data(client) ""
+
+ lappend tixBalloon(bals) $w
+}
+
+proc tixBalloon:ConstructWidget {w} {
+ upvar #0 $w data
+
+ tixChainMethod $w ConstructWidget
+
+ wm overrideredirect $w 1
+ wm withdraw $w
+
+ # Frame 1 : arrow
+ frame $w.f1 -bd 0
+ set data(w:label) [label $w.f1.lab -bd 0 -relief flat \
+ -bitmap [tix getbitmap balarrow]]
+ pack $data(w:label) -side left -padx 1 -pady 1
+
+ # Frame 2 : Message
+ frame $w.f2 -bd 0
+ set data(w:message) [label $w.f2.message -padx 0 -pady 0 -bd 0]
+ pack $data(w:message) -side left -expand yes -fill both -padx 10 -pady 1
+
+ # Pack all
+ pack $w.f1 -fill both
+ pack $w.f2 -fill both
+
+ # This is an event tag used by the clients
+ #
+ bind TixBal$w <Destroy> [list tixBalloon:ClientDestroy $w %W]
+}
+
+proc tixBalloon:Destructor {w} {
+ global tixBalloon
+
+ set bals ""
+ foreach b $tixBalloon(bals) {
+ if {$w != $b} {
+ lappend bals $b
+ }
+ }
+ set tixBalloon(bals) $bals
+
+ tixChainMethod $w Destructor
+}
+
+#----------------------------------------------------------------------
+# Config:
+#----------------------------------------------------------------------
+proc tixBalloon:config-state {w value} {
+ upvar #0 $w data
+
+ set re {^(none|balloon|status|both)$}
+ if {![regexp -- $re $value]} {
+ error "invalid value $value, must be none, balloon, status, or both"
+ }
+}
+
+#----------------------------------------------------------------------
+# "RAW" event bindings:
+#----------------------------------------------------------------------
+
+bind all <B1-Motion> "+tixBalloon_XXMotion %X %Y 1"
+bind all <B2-Motion> "+tixBalloon_XXMotion %X %Y 2"
+bind all <B3-Motion> "+tixBalloon_XXMotion %X %Y 3"
+bind all <B4-Motion> "+tixBalloon_XXMotion %X %Y 4"
+bind all <B5-Motion> "+tixBalloon_XXMotion %X %Y 5"
+bind all <Any-Motion> "+tixBalloon_XXMotion %X %Y 0"
+# Should %b be 0? %b is illegal
+bind all <Leave> "+tixBalloon_XXMotion %X %Y 0"
+bind all <Button> "+tixBalloon_XXButton %X %Y %b"
+bind all <ButtonRelease> "+tixBalloon_XXButtonUp %X %Y %b"
+
+proc tixBalloon_XXMotion {rootX rootY b} {
+ global tixBalloon
+
+ foreach w $tixBalloon(bals) {
+ tixBalloon:XXMotion $w $rootX $rootY $b
+ }
+}
+
+proc tixBalloon_XXButton {rootX rootY b} {
+ global tixBalloon
+
+ foreach w $tixBalloon(bals) {
+ tixBalloon:XXButton $w $rootX $rootY $b
+ }
+}
+
+proc tixBalloon_XXButtonUp {rootX rootY b} {
+ global tixBalloon
+
+ foreach w $tixBalloon(bals) {
+ tixBalloon:XXButtonUp $w $rootX $rootY $b
+ }
+}
+
+# return true if d is a descendant of w
+#
+proc tixIsDescendant {w d} {
+ return [expr {$w eq "." || [string match $w.* $d]}]
+}
+
+# All the button events are fine if the ballooned widget is
+# a descendant of the grabbing widget
+#
+proc tixBalloon:GrabBad {w cw} {
+ global tixBalloon
+
+ set g [grab current $w]
+ if {$g == ""} {
+ return 0
+ }
+ if {[info exists tixBalloon(g_ignore,$g)]} {
+ return 1
+ }
+ if {[info exists tixBalloon(g_ignore,[winfo class $g])]} {
+ return 1
+ }
+ if {$g == $cw || [tixIsDescendant $g $cw]} {
+ return 0
+ }
+ return 1
+}
+
+proc tixBalloon:XXMotion {w rootX rootY b} {
+ upvar #0 $w data
+
+ if {![info exists data(-state)]} {
+ # puts "tixBalloon:XXMotion called without a state\n$w"
+ set data(state) none
+ return
+ }
+ if {$data(-state) eq "none"} {
+ return
+ }
+
+ if {$b == 0} {
+ if {[info exists data(b:1)]} {unset data(b:1)}
+ if {[info exists data(b:2)]} {unset data(b:2)}
+ if {[info exists data(b:3)]} {unset data(b:3)}
+ if {[info exists data(b:4)]} {unset data(b:4)}
+ if {[info exists data(b:5)]} {unset data(b:5)}
+ }
+
+ if {[llength [array names data b:*]]} {
+ # Some buttons are down. Do nothing
+ #
+ return
+ }
+
+ set cw [winfo containing -displayof $w $rootX $rootY]
+ if {[tixBalloon:GrabBad $w $cw]} {
+ return
+ }
+
+ # Find the a client window that matches
+ #
+ if {$w eq $cw || [string match $w.* $cw]} {
+ # Cursor moved over the balloon -- Ignore
+ return
+ }
+
+ while {$cw != ""} {
+ if {[info exists data(m:$cw)]} {
+ set client $cw
+ break
+ } else {
+ set cw [winfo parent $cw]
+ }
+ }
+ if {![info exists client]} {
+ # The cursor is at a position covered by a non-client
+ # Popdown the balloon if it is up
+ if {$data(isActive)} {
+ tixBalloon:Deactivate $w
+ }
+ set data(client) ""
+ if {[info exists data(cancel)]} {
+ unset data(cancel)
+ }
+ return
+ }
+
+ if {$data(client) ne $client} {
+ if {$data(isActive)} {
+ tixBalloon:Deactivate $w
+ }
+ set data(client) $client
+ after $data(-initwait) tixBalloon:SwitchToClient $w $client
+ }
+}
+
+proc tixBalloon:XXButton {w rootX rootY b} {
+ upvar #0 $w data
+
+ tixBalloon:XXMotion $w $rootX $rootY $b
+
+ set data(b:$b) 1
+
+ if {$data(isActive)} {
+ tixBalloon:Deactivate $w
+ } else {
+ set data(cancel) 1
+ }
+}
+
+proc tixBalloon:XXButtonUp {w rootX rootY b} {
+ upvar #0 $w data
+
+ tixBalloon:XXMotion $w $rootX $rootY $b
+ if {[info exists data(b:$b)]} {
+ unset data(b:$b)
+ }
+}
+
+#----------------------------------------------------------------------
+# "COOKED" event bindings:
+#----------------------------------------------------------------------
+
+# switch the balloon to a new client
+#
+proc tixBalloon:SwitchToClient {w client} {
+ upvar #0 $w data
+
+ if {![winfo exists $w]} {
+ return
+ }
+ if {![winfo exists $client]} {
+ return
+ }
+ if {$client ne $data(client)} {
+ return
+ }
+ if {[info exists data(cancel)]} {
+ unset data(cancel)
+ return
+ }
+
+ if {[tixBalloon:GrabBad $w $w]} {
+ return
+ }
+
+ tixBalloon:Activate $w
+}
+
+proc tixBalloon:ClientDestroy {w client} {
+ if {![winfo exists $w]} {
+ return
+ }
+
+ upvar #0 $w data
+
+ if {$data(client) eq $client} {
+ tixBalloon:Deactivate $w
+ set data(client) ""
+ }
+
+ # Maybe thses have already been unset by the Destroy method
+ #
+ if {[info exists data(m:$client)]} {unset data(m:$client)}
+ if {[info exists data(s:$client)]} {unset data(s:$client)}
+}
+
+#----------------------------------------------------------------------
+# Popping up balloon:
+#----------------------------------------------------------------------
+proc tixBalloon:Activate {w} {
+ upvar #0 $w data
+
+ if {[tixBalloon:GrabBad $w $w]} {
+ return
+ }
+ if {[winfo containing -displayof $w \
+ [winfo pointerx $w] [winfo pointery $w]] == ""} {
+ return
+ }
+
+ if {![info exists data(-state)]} {
+ # puts "tixBalloon:Activate called without a state\n$w"
+ set data(state) none
+ return
+ }
+ if {$data(-state) eq "none"} {
+ return
+ }
+
+ switch -exact -- $data(-state) {
+ "both" {
+ tixBalloon:PopUp $w
+ tixBalloon:SetStatus $w
+ }
+ "balloon" {
+ tixBalloon:PopUp $w
+ }
+ "status" {
+ tixBalloon:SetStatus $w
+ }
+ }
+
+ set data(isActive) 1
+
+ after 200 tixBalloon:Verify $w
+}
+
+
+# %% Perhaps this is no more needed
+#
+proc tixBalloon:Verify {w} {
+ upvar #0 $w data
+
+ if {![winfo exists $w]} {
+ return
+ }
+ if {!$data(isActive)} {
+ return
+ }
+
+ if {[tixBalloon:GrabBad $w $w]} {
+ tixBalloon:Deactivate $w
+ return
+ }
+ if {[winfo containing -displayof $w \
+ [winfo pointerx $w] [winfo pointery $w]] == ""} {
+ tixBalloon:Deactivate $w
+ return
+ }
+ after 200 tixBalloon:Verify $w
+}
+
+proc tixBalloon:Deactivate {w} {
+ upvar #0 $w data
+
+ tixBalloon:PopDown $w
+ tixBalloon:ClearStatus $w
+ set data(isActive) 0
+ if {[info exists data(cancel)]} {
+ unset data(cancel)
+ }
+}
+
+proc tixBalloon:PopUp {w} {
+ upvar #0 $w data
+
+ if {[string is true -strict $data(-installcolormap)]} {
+ wm colormapwindows [winfo toplevel $data(client)] $w
+ }
+
+ # trick: the following lines allow the balloon window to
+ # acquire a stable width and height when it is finally
+ # put on the visible screen
+ #
+ set client $data(client)
+ if {$data(m:$client) == ""} {return ""}
+
+ $data(w:message) config -text $data(m:$client)
+ wm geometry $w +10000+10000
+ wm deiconify $w
+ raise $w
+ update
+
+ # The windows may become destroyed as a result of the "update" command
+ #
+ if {![winfo exists $w]} {
+ return
+ }
+ if {![winfo exists $client]} {
+ return
+ }
+ # Put it on the visible screen
+ #
+ set x [expr {[winfo rootx $client]+[winfo width $client]/2}]
+ set y [expr {int([winfo rooty $client]+[winfo height $client]/1.3)}]
+
+ set width [winfo reqwidth $w]
+ set height [winfo reqheight $w]
+ set scrwidth [winfo vrootwidth $w]
+ set scrheight [winfo vrootheight $w]
+
+ # If the balloon is too far right, pull it back to the left
+ #
+ if {($x + $width) > $scrwidth} {
+ set x [expr {$scrwidth - $width}]
+ }
+
+ # If the balloon is too far left, pull it back to the right
+ #
+ if {$x < 0} {
+ set x 0
+ }
+
+ # If the listbox is below bottom of screen, put it upwards
+ #
+ if {($y + $height) > $scrheight} {
+ set y [expr {$scrheight-$height}]
+ }
+ if {$y < 0} {
+ set y 0
+ }
+
+ wm geometry $w +$x+$y
+ after idle raise $w
+}
+
+proc tixBalloon:PopDown {w} {
+ upvar #0 $w data
+
+ # Close the balloon
+ #
+ wm withdraw $w
+
+ # We don't set the data(client) to be zero, so that the balloon
+ # will re-appear only if you move out then in the client window
+ # set data(client) ""
+}
+
+proc tixBalloon:SetStatus {w} {
+ upvar #0 $w data
+
+ if {![winfo exists $data(-statusbar)]
+ || ![info exists data(s:$data(client))]} {
+ return
+ }
+
+ set vv [$data(-statusbar) cget -textvariable]
+ if {$vv == ""} {
+ $data(-statusbar) config -text $data(s:$data(client))
+ } else {
+ uplevel #0 set $vv [list $data(s:$data(client))]
+ }
+}
+
+proc tixBalloon:ClearStatus {w} {
+ upvar #0 $w data
+
+ if {![winfo exists $data(-statusbar)]} {
+ return
+ }
+
+ # Clear the StatusBar widget
+ #
+ set vv [$data(-statusbar) cget -textvariable]
+ if {$vv == ""} {
+ $data(-statusbar) config -text ""
+ } else {
+ uplevel #0 set $vv [list ""]
+ }
+}
+
+#----------------------------------------------------------------------
+# PublicMethods:
+#----------------------------------------------------------------------
+
+# %% if balloon is already popped-up for this client, change mesage
+#
+proc tixBalloon:bind {w client args} {
+ upvar #0 $w data
+
+ set alreadyBound [info exists data(m:$client)]
+
+ set opt(-balloonmsg) ""
+ set opt(-statusmsg) ""
+ set opt(-msg) ""
+
+ tixHandleOptions opt {-balloonmsg -msg -statusmsg} $args
+
+ if {$opt(-balloonmsg) != ""} {
+ set data(m:$client) $opt(-balloonmsg)
+ } else {
+ set data(m:$client) $opt(-msg)
+ }
+ if {$opt(-statusmsg) != ""} {
+ set data(s:$client) $opt(-statusmsg)
+ } else {
+ set data(s:$client) $opt(-msg)
+ }
+
+ tixAppendBindTag $client TixBal$w
+}
+
+proc tixBalloon:post {w client} {
+ upvar #0 $w data
+
+ if {![info exists data(m:$client)] || $data(m:$client) == ""} {
+ return
+ }
+ tixBalloon:Enter $w $client
+ incr data(fakeEnter)
+}
+
+proc tixBalloon:unbind {w client} {
+ upvar #0 $w data
+
+ if {[info exists data(m:$client)]} {
+ if {[info exists data(m:$client)]} {unset data(m:$client)}
+ if {[info exists data(s:$client)]} {unset data(s:$client)}
+
+ if {[winfo exists $client]} {
+ catch {tixDeleteBindTag $client TixBal$w}
+ }
+ }
+}
+
+#----------------------------------------------------------------------
+#
+# Utility function
+#
+#----------------------------------------------------------------------
+#
+# $w can be a widget name or a classs name
+proc tixBalIgnoreWhenGrabbed {wc} {
+ global tixBalloon
+ set tixBalloon(g_ignore,$wc) ""
+}
+
+tixBalIgnoreWhenGrabbed TixComboBox
+tixBalIgnoreWhenGrabbed Menu
+tixBalIgnoreWhenGrabbed Menubutton