diff -r 000000000000 -r ae805ac0140d python-2.5.2/win32/tcl/tix8.4/Control.tcl --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/python-2.5.2/win32/tcl/tix8.4/Control.tcl Fri Apr 03 17:19:34 2009 +0100 @@ -0,0 +1,482 @@ +# -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*- +# +# $Id: Control.tcl,v 1.9 2004/03/28 02:44:57 hobbs Exp $ +# +# Control.tcl -- +# +# Implements the TixControl Widget. It is called the "SpinBox" +# in other toolkits. +# +# 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 tixControl { + -classname TixControl + -superclass tixLabelWidget + -method { + incr decr invoke update + } + -flag { + -allowempty -autorepeat -command -decrcmd -disablecallback + -disabledforeground -incrcmd -initwait -integer -llimit + -repeatrate -max -min -selectmode -step -state -validatecmd + -value -variable -ulimit + } + -forcecall { + -variable -state + } + -configspec { + {-allowempty allowEmpty AllowEmpty false} + {-autorepeat autoRepeat AutoRepeat true} + {-command command Command ""} + {-decrcmd decrCmd DecrCmd ""} + {-disablecallback disableCallback DisableCallback 0 tixVerifyBoolean} + {-disabledforeground disabledForeground DisabledForeground #303030} + {-incrcmd incrCmd IncrCmd ""} + {-initwait initWait InitWait 500} + {-integer integer Integer false} + {-max max Max ""} + {-min min Min ""} + {-repeatrate repeatRate RepeatRate 50} + {-step step Step 1} + {-state state State normal} + {-selectmode selectMode SelectMode normal} + {-validatecmd validateCmd ValidateCmd ""} + {-value value Value 0} + {-variable variable Variable ""} + } + -alias { + {-llimit -min} + {-ulimit -max} + } + -default { + {.borderWidth 0} + {*entry.relief sunken} + {*entry.width 5} + {*label.anchor e} + {*label.borderWidth 0} + {*Button.anchor c} + {*Button.borderWidth 2} + {*Button.highlightThickness 1} + {*Button.takeFocus 0} + } +} + +proc tixControl:InitWidgetRec {w} { + upvar #0 $w data + + tixChainMethod $w InitWidgetRec + + set data(varInited) 0 + set data(serial) 0 +} + +proc tixControl:ConstructFramedWidget {w frame} { + upvar #0 $w data + + tixChainMethod $w ConstructFramedWidget $frame + + set data(w:entry) [entry $frame.entry] + + set data(w:incr) \ + [button $frame.incr -bitmap [tix getbitmap incr] -takefocus 0] + set data(w:decr) \ + [button $frame.decr -bitmap [tix getbitmap decr] -takefocus 0] + +# tixForm $data(w:entry) -left 0 -top 0 -bottom -1 -right $data(w:decr) +# tixForm $data(w:incr) -right -1 -top 0 -bottom %50 +# tixForm $data(w:decr) -right -1 -top $data(w:incr) -bottom -1 + + pack $data(w:entry) -side left -expand yes -fill both + pack $data(w:decr) -side bottom -fill both -expand yes + pack $data(w:incr) -side top -fill both -expand yes + + $data(w:entry) delete 0 end + $data(w:entry) insert 0 $data(-value) + + # This value is used to configure the disable/normal fg of the ebtry + set data(entryfg) [$data(w:entry) cget -fg] + set data(labelfg) [$data(w:label) cget -fg] +} + +proc tixControl:SetBindings {w} { + upvar #0 $w data + + tixChainMethod $w SetBindings + + bind $data(w:incr) \ + [list after idle tixControl:StartRepeat $w 1] + bind $data(w:decr) \ + [list after idle tixControl:StartRepeat $w -1] + + # These bindings will stop the button autorepeat when the + # mouse button is up + foreach btn [list $data(w:incr) $data(w:decr)] { + bind $btn [list tixControl:StopRepeat $w] + } + + tixSetMegaWidget $data(w:entry) $w + + # If user press , verify the value and call the -command + # + tixAddBindTag $data(w:entry) TixControl:Entry +} + +proc tixControlBind {} { + tixBind TixControl:Entry { + tixControl:Invoke [tixGetMegaWidget %W] 1 + } + tixBind TixControl:Entry { + tixControl:Escape [tixGetMegaWidget %W] + } + tixBind TixControl:Entry { + [tixGetMegaWidget %W] incr + } + tixBind TixControl:Entry { + [tixGetMegaWidget %W] decr + } + tixBind TixControl:Entry { + if {"%d" eq "NotifyNonlinear" || "%d" eq "NotifyNonlinearVirtual"} { + tixControl:Tab [tixGetMegaWidget %W] %d + } + } + tixBind TixControl:Entry { + tixControl:KeyPress [tixGetMegaWidget %W] + } + tixBind TixControl:Entry { + # This has a higher priority than the binding + # --> so that data(edited) is not set + } +} + +#---------------------------------------------------------------------- +# CONFIG OPTIONS +#---------------------------------------------------------------------- +proc tixControl:config-state {w arg} { + upvar #0 $w data + + if {$arg eq "normal"} { + $data(w:incr) config -state $arg + $data(w:decr) config -state $arg + catch { + $data(w:label) config -fg $data(labelfg) + } + $data(w:entry) config -state $arg -fg $data(entryfg) + } else { + $data(w:incr) config -state $arg + $data(w:decr) config -state $arg + catch { + $data(w:label) config -fg $data(-disabledforeground) + } + $data(w:entry) config -state $arg -fg $data(-disabledforeground) + } +} + +proc tixControl:config-value {w value} { + upvar #0 $w data + + tixControl:SetValue $w $value 0 1 + + # This will tell the Intrinsics: "Please use this value" + # because "value" might be altered by SetValues + # + return $data(-value) +} + +proc tixControl:config-variable {w arg} { + upvar #0 $w data + + if {[tixVariable:ConfigVariable $w $arg]} { + # The value of data(-value) is changed if tixVariable:ConfigVariable + # returns true + tixControl:SetValue $w $data(-value) 1 1 + } + catch { + unset data(varInited) + } + set data(-variable) $arg +} + +#---------------------------------------------------------------------- +# User Commands +#---------------------------------------------------------------------- +proc tixControl:incr {w {by 1}} { + upvar #0 $w data + + if {$data(-state) ne "disabled"} { + if {![catch {$data(w:entry) index sel.first}]} { + $data(w:entry) select from end + $data(w:entry) select to end + } + # CYGNUS - why set value before changing it? + #tixControl:SetValue $w [$data(w:entry) get] 0 1 + tixControl:AdjustValue $w $by + } +} + +proc tixControl:decr {w {by 1}} { + upvar #0 $w data + + if {$data(-state) ne "disabled"} { + if {![catch {$data(w:entry) index sel.first}]} { + $data(w:entry) select from end + $data(w:entry) select to end + } + # CYGNUS - why set value before changing it? + #tixControl:SetValue $w [$data(w:entry) get] 0 1 + tixControl:AdjustValue $w [expr {0 - $by}] + } +} + +proc tixControl:invoke {w} { + upvar #0 $w data + + tixControl:Invoke $w 0 +} + +proc tixControl:update {w} { + upvar #0 $w data + + if {[info exists data(edited)]} { + tixControl:invoke $w + } +} + +#---------------------------------------------------------------------- +# Internal Commands +#---------------------------------------------------------------------- + +# Change the value by a multiple of the data(-step) +# +proc tixControl:AdjustValue {w amount} { + upvar #0 $w data + + if {$amount == 1 && [llength $data(-incrcmd)]} { + set newValue [tixEvalCmdBinding $w $data(-incrcmd) "" $data(-value)] + } elseif {$amount == -1 && [llength $data(-decrcmd)]} { + set newValue [tixEvalCmdBinding $w $data(-decrcmd) "" $data(-value)] + } else { + set newValue [expr {$data(-value) + $amount * $data(-step)}] + } + + if {$data(-state) ne "disabled"} { + tixControl:SetValue $w $newValue 0 1 + } +} + +proc tixControl:SetValue {w newvalue noUpdate forced} { + upvar #0 $w data + + if {[$data(w:entry) selection present]} { + set oldSelection [list [$data(w:entry) index sel.first] \ + [$data(w:entry) index sel.last]] + } + + set oldvalue $data(-value) + set oldCursor [$data(w:entry) index insert] + set changed 0 + + + if {[llength $data(-validatecmd)]} { + # Call the user supplied validation command + # + set data(-value) [tixEvalCmdBinding $w $data(-validatecmd) "" $newvalue] + } else { + # Here we only allow int or floating numbers + # + # If the new value is not a valid number, the old value will be + # kept due to the "catch" statements + # + if {[catch {expr 0+$newvalue}]} { + set newvalue 0 + set data(-value) 0 + set changed 1 + } + + if {$newvalue == ""} { + if {![string is true -strict $data(-allowempty)]} { + set newvalue 0 + set changed 1 + } else { + set data(-value) "" + } + } + + if {$newvalue != ""} { + # Change this to a valid decimal string (trim leading 0) + # + regsub -- {^[0]*} $newvalue "" newvalue + if {[catch {expr 0+$newvalue}]} { + set newvalue 0 + set data(-value) 0 + set changed 1 + } + if {$newvalue == ""} { + set newvalue 0 + } + + if {[string is true -strict $data(-integer)]} { + set data(-value) [tixGetInt -nocomplain $newvalue] + } else { + if {[catch {set data(-value) [format "%d" $newvalue]}]} { + if {[catch {set data(-value) [expr $newvalue+0.0]}]} { + set data(-value) $oldvalue + } + } + } + + # Now perform boundary checking + # + if {$data(-max) != "" && $data(-value) > $data(-max)} { + set data(-value) $data(-max) + } + if {$data(-min) != "" && $data(-value) < $data(-min)} { + set data(-value) $data(-min) + } + } + } + + if {! $noUpdate} { + tixVariable:UpdateVariable $w + } + + if {$forced || ($newvalue ne $data(-value)) || $changed} { + $data(w:entry) delete 0 end + $data(w:entry) insert 0 $data(-value) + $data(w:entry) icursor $oldCursor + if {[info exists oldSelection]} { + eval [list $data(w:entry) selection range] $oldSelection + } + } + + if {!$data(-disablecallback) && $data(-command) != ""} { + if {![info exists data(varInited)]} { + set bind(specs) "" + tixEvalCmdBinding $w $data(-command) bind $data(-value) + } + } +} + +proc tixControl:Invoke {w forced} { + upvar #0 $w data + + catch { + unset data(edited) + } + + if {[catch {$data(w:entry) index sel.first}] == 0} { + # THIS ENTRY OWNS SELECTION --> TURN IT OFF + # + $data(w:entry) select from end + $data(w:entry) select to end + } + + tixControl:SetValue $w [$data(w:entry) get] 0 $forced +} + +#---------------------------------------------------------------------- +# The three functions StartRepeat, Repeat and StopRepeat make use of the +# data(serial) variable to discard spurious repeats: If a button is clicked +# repeatedly but is not hold down, the serial counter will increase +# successively and all "after" time event handlers will be discarded +#---------------------------------------------------------------------- +proc tixControl:StartRepeat {w amount} { + if {![winfo exists $w]} { + return + } + + upvar #0 $w data + + incr data(serial) + # CYGNUS bug fix + # Need to set a local variable because otherwise the buttonrelease + # callback could change the value of data(serial) between now and + # the time the repeat is scheduled. + set serial $data(serial) + + if {![catch {$data(w:entry) index sel.first}]} { + $data(w:entry) select from end + $data(w:entry) select to end + } + + if {[info exists data(edited)]} { + unset data(edited) + tixControl:SetValue $w [$data(w:entry) get] 0 1 + } + + tixControl:AdjustValue $w $amount + + if {$data(-autorepeat)} { + after $data(-initwait) tixControl:Repeat $w $amount $serial + } + + focus $data(w:entry) +} + +proc tixControl:Repeat {w amount serial} { + if {![winfo exists $w]} { + return + } + upvar #0 $w data + + if {$serial eq $data(serial)} { + tixControl:AdjustValue $w $amount + + if {$data(-autorepeat)} { + after $data(-repeatrate) tixControl:Repeat $w $amount $serial + } + } +} + +proc tixControl:StopRepeat {w} { + upvar #0 $w data + + incr data(serial) +} + +proc tixControl:Destructor {w} { + + tixVariable:DeleteVariable $w + + # Chain this to the superclass + # + tixChainMethod $w Destructor +} + +# ToDo: maybe should return -code break if the value is not good ... +# +proc tixControl:Tab {w detail} { + upvar #0 $w data + + if {![info exists data(edited)]} { + return + } else { + unset data(edited) + } + + tixControl:invoke $w +} + +proc tixControl:Escape {w} { + upvar #0 $w data + + $data(w:entry) delete 0 end + $data(w:entry) insert 0 $data(-value) +} + +proc tixControl:KeyPress {w} { + upvar #0 $w data + + if {$data(-selectmode) eq "normal"} { + set data(edited) 0 + return + } else { + # == "immediate" + after 1 tixControl:invoke $w + } +}