home *** CD-ROM | disk | FTP | other *** search
/ Freelog Special Freeware 31 / FreelogHS31.iso / Texte / scribus / scribus-1.3.3.9-win32-install.exe / tcl / tix8.1 / Control.tcl < prev    next >
Text File  |  2001-12-08  |  13KB  |  482 lines
  1. # -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
  2. #
  3. #    $Id: Control.tcl,v 1.5.2.2 2001/12/09 02:54:02 idiscovery Exp $
  4. #
  5. # Control.tcl --
  6. #
  7. #     Implements the TixControl Widget. It is called the "SpinBox"
  8. #     in other toolkits.
  9. #
  10. # Copyright (c) 1993-1999 Ioi Kim Lam.
  11. # Copyright (c) 2000-2001 Tix Project Group.
  12. #
  13. # See the file "license.terms" for information on usage and redistribution
  14. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15. #
  16.  
  17. tixWidgetClass tixControl {
  18.     -classname  TixControl
  19.     -superclass tixLabelWidget
  20.     -method {
  21.     incr decr invoke update
  22.     }
  23.     -flag {
  24.     -allowempty -autorepeat -command -decrcmd -disablecallback
  25.     -disabledforeground -incrcmd -initwait -integer -llimit
  26.     -repeatrate -max -min -selectmode -step -state -validatecmd
  27.     -value -variable -ulimit
  28.     }
  29.     -forcecall {
  30.     -variable -state
  31.     }
  32.     -configspec {
  33.     {-allowempty allowEmpty AllowEmpty false}
  34.     {-autorepeat autoRepeat AutoRepeat true}
  35.     {-command command Command ""}
  36.     {-decrcmd decrCmd DecrCmd ""}
  37.     {-disablecallback disableCallback DisableCallback 0 tixVerifyBoolean}
  38.     {-disabledforeground disabledForeground DisabledForeground #303030}
  39.     {-incrcmd incrCmd IncrCmd ""}
  40.     {-initwait initWait InitWait 500}
  41.     {-integer integer Integer false}
  42.     {-max max Max ""}
  43.     {-min min Min ""}
  44.     {-repeatrate repeatRate RepeatRate 50}
  45.     {-step step Step 1}
  46.     {-state state State normal}
  47.     {-selectmode selectMode SelectMode normal}
  48.     {-validatecmd validateCmd ValidateCmd ""}
  49.     {-value value Value 0}
  50.     {-variable variable Variable ""}
  51.     }
  52.     -alias {
  53.     {-llimit -min}
  54.     {-ulimit -max}
  55.     }
  56.     -default {
  57.     {.borderWidth             0}
  58.     {*entry.relief            sunken}
  59.     {*entry.width            5}
  60.     {*label.anchor            e}
  61.     {*label.borderWidth        0}
  62.     {*Button.anchor            c}
  63.     {*Button.borderWidth        2}
  64.     {*Button.highlightThickness    1}
  65.     {*Button.takeFocus        0}
  66.     }
  67. }
  68.  
  69. proc tixControl:InitWidgetRec {w} {
  70.     upvar #0 $w data
  71.  
  72.     tixChainMethod $w InitWidgetRec
  73.  
  74.     set data(varInited)      0
  75.     set data(serial)    0
  76. }
  77.  
  78. proc tixControl:ConstructFramedWidget {w frame} {
  79.     upvar #0 $w data
  80.  
  81.     tixChainMethod $w ConstructFramedWidget $frame
  82.  
  83.     set data(w:entry)  [entry $frame.entry]
  84.  
  85.     set data(w:incr) [button $frame.incr -bitmap [tix getbitmap incr] \
  86.     -takefocus 0]
  87.     set data(w:decr) [button $frame.decr -bitmap [tix getbitmap decr] \
  88.     -takefocus 0]
  89.  
  90. #    tixForm $data(w:entry) -left 0 -top 0 -bottom -1 -right $data(w:decr) 
  91. #    tixForm $data(w:incr) -right -1 -top 0 -bottom %50
  92. #    tixForm $data(w:decr) -right -1 -top $data(w:incr) -bottom -1
  93.  
  94.     pack $data(w:entry) -side left   -expand yes -fill both
  95.     pack $data(w:decr)  -side bottom -fill both -expand yes
  96.     pack $data(w:incr)  -side top    -fill both -expand yes
  97.  
  98.     $data(w:entry) delete 0 end
  99.     $data(w:entry) insert 0 $data(-value)
  100.  
  101.     # This value is used to configure the disable/normal fg of the ebtry
  102.     set data(entryfg) [$data(w:entry) cget -fg]
  103.     set data(labelfg) [$data(w:label) cget -fg]
  104. }
  105.  
  106. proc tixControl:SetBindings {w} {
  107.     upvar #0 $w data
  108.  
  109.     tixChainMethod $w SetBindings
  110.  
  111.     bind $data(w:incr) <ButtonPress-1> \
  112.       [format {after idle tixControl:StartRepeat %s  1} $w]
  113.     bind $data(w:decr) <ButtonPress-1> \
  114.       [format {after idle tixControl:StartRepeat %s  -1} $w]
  115.  
  116.     # These bindings will stop the button autorepeat when the 
  117.     # mouse button is up
  118.     foreach btn "$data(w:incr) $data(w:decr)" {
  119.     bind $btn <ButtonRelease-1> "tixControl:StopRepeat $w"
  120.     }
  121.  
  122.     tixSetMegaWidget $data(w:entry) $w
  123.  
  124.     # If user press <return>, verify the value and call the -command
  125.     #
  126.     tixAddBindTag $data(w:entry) TixControl:Entry 
  127. }
  128.  
  129. proc tixControlBind {} {
  130.     tixBind TixControl:Entry <Return> {
  131.     tixControl:Invoke [tixGetMegaWidget %W] 1
  132.     }
  133.     tixBind TixControl:Entry <Escape> {
  134.     tixControl:Escape [tixGetMegaWidget %W]
  135.     }
  136.     tixBind TixControl:Entry <Up> {
  137.     [tixGetMegaWidget %W] incr
  138.     }
  139.     tixBind TixControl:Entry <Down> {
  140.     [tixGetMegaWidget %W] decr
  141.     }
  142.     tixBind TixControl:Entry <FocusOut> {
  143.     if {"%d" == "NotifyNonlinear" || "%d" == "NotifyNonlinearVirtual"} {
  144.         tixControl:Tab [tixGetMegaWidget %W] %d
  145.     }
  146.     }
  147.     tixBind TixControl:Entry <Any-KeyPress> {
  148.     tixControl:KeyPress [tixGetMegaWidget %W]
  149.     }
  150.     tixBind TixControl:Entry <Any-Tab> {
  151.     # This has a higher priority than the <Any-KeyPress>  binding
  152.     # --> so that data(edited) is not set
  153.     }
  154. }
  155.  
  156. #----------------------------------------------------------------------
  157. #                           CONFIG OPTIONS
  158. #----------------------------------------------------------------------
  159. proc tixControl:config-state {w arg} {
  160.     upvar #0 $w data
  161.  
  162.     if {$arg == "normal"} {
  163.     $data(w:incr)  config -state $arg
  164.     $data(w:decr)  config -state $arg
  165.     catch {
  166.         $data(w:label) config -fg $data(labelfg)
  167.     }
  168.     $data(w:entry) config -state $arg -fg $data(entryfg)
  169.     } else {
  170.     $data(w:incr)  config -state $arg
  171.     $data(w:decr)  config -state $arg
  172.     catch {
  173.         $data(w:label) config -fg $data(-disabledforeground)
  174.     }
  175.     $data(w:entry) config -state $arg -fg $data(-disabledforeground)
  176.     }
  177. }
  178.  
  179. proc tixControl:config-value {w value} {
  180.     upvar #0 $w data
  181.  
  182.     tixControl:SetValue $w $value 0 1
  183.  
  184.     # This will tell the Intrinsics: "Please use this value"
  185.     # because "value" might be altered by SetValues
  186.     #
  187.     return $data(-value)
  188. }
  189.  
  190. proc tixControl:config-variable {w arg} {
  191.     upvar #0 $w data
  192.  
  193.     if {[tixVariable:ConfigVariable $w $arg]} {
  194.        # The value of data(-value) is changed if tixVariable:ConfigVariable 
  195.        # returns true
  196.        tixControl:SetValue $w $data(-value) 1 1
  197.     }
  198.     catch {
  199.     unset data(varInited)
  200.     }
  201.     set data(-variable) $arg
  202. }
  203.  
  204. #----------------------------------------------------------------------
  205. #                         User Commands
  206. #----------------------------------------------------------------------
  207. proc tixControl:incr {w {by 1}} {
  208.     upvar #0 $w data
  209.  
  210.     if {$data(-state) != "disabled"} {
  211.     if {[catch {$data(w:entry) index sel.first}] == 0} {
  212.         $data(w:entry) select from end
  213.         $data(w:entry) select to   end
  214.     }
  215.     # CYGNUS - why set value before changing it?
  216.     #tixControl:SetValue $w [$data(w:entry) get] 0 1
  217.     tixControl:AdjustValue $w $by
  218.     }
  219. }
  220.  
  221. proc tixControl:decr {w {by 1}} {
  222.     upvar #0 $w data
  223.  
  224.     if {$data(-state) != "disabled"} {
  225.     if {[catch {$data(w:entry) index sel.first}] == 0} {
  226.         $data(w:entry) select from end
  227.         $data(w:entry) select to   end
  228.     }
  229.     # CYGNUS - why set value before changing it?
  230.     #tixControl:SetValue $w [$data(w:entry) get] 0 1
  231.     tixControl:AdjustValue $w [expr {0 - $by}]
  232.     }
  233. }
  234.  
  235. proc tixControl:invoke {w} {
  236.     upvar #0 $w data
  237.  
  238.     tixControl:Invoke $w 0
  239. }
  240.  
  241. proc tixControl:update {w} {
  242.     upvar #0 $w data
  243.  
  244.     if {[info exists data(edited)]} {
  245.     tixControl:invoke $w
  246.     }
  247. }
  248.  
  249. #----------------------------------------------------------------------
  250. #                       Internal Commands
  251. #----------------------------------------------------------------------
  252.  
  253. # Change the value by a multiple of the data(-step)
  254. #
  255. proc tixControl:AdjustValue {w amount} {
  256.     upvar #0 $w data
  257.  
  258.     if {$amount == 1 && $data(-incrcmd) != ""} {
  259.     set newValue [tixEvalCmdBinding $w $data(-incrcmd) "" $data(-value)]
  260.     } elseif {$amount == -1 && $data(-decrcmd) != ""} {
  261.     set newValue [tixEvalCmdBinding $w $data(-decrcmd) "" $data(-value)]
  262.     } else {
  263.     set newValue [expr $data(-value) + $amount * $data(-step)]
  264.     }
  265.  
  266.     if {$data(-state) != "disabled"} {
  267.     tixControl:SetValue $w $newValue 0 1
  268.     }
  269. }
  270.  
  271. proc tixControl:SetValue {w newvalue noUpdate forced} {
  272.     upvar #0 $w data
  273.  
  274.     if {[$data(w:entry) selection present]} {
  275.     set oldSelection \
  276.         "[$data(w:entry) index sel.first] [$data(w:entry) index sel.last]"
  277.     }
  278.  
  279.     set oldvalue $data(-value)
  280.     set oldCursor [$data(w:entry) index insert]
  281.     set changed 0
  282.  
  283.  
  284.     if {$data(-validatecmd) != ""} {
  285.     # Call the user supplied validation command
  286.     #
  287.        set data(-value) [tixEvalCmdBinding $w $data(-validatecmd) "" $newvalue]
  288.     } else {
  289.     # Here we only allow int or floating numbers
  290.     #
  291.     # If the new value is not a valid number, the old value will be
  292.     # kept due to the "catch" statements
  293.     #
  294.     if {[catch {expr 0+$newvalue}]} {
  295.         set newvalue 0
  296.         set data(-value) 0
  297.         set changed 1
  298.     }
  299.  
  300.     if {$newvalue == ""} {
  301.         if {![tixGetBoolean -nocomplain $data(-allowempty)]} {
  302.         set newvalue 0
  303.         set changed 1
  304.         } else {
  305.         set data(-value) ""
  306.         }
  307.     }
  308.  
  309.     if {$newvalue != ""} {
  310.         # Change this to a valid decimal string (trim leading 0)
  311.         #
  312.         regsub -- {^[0]*} $newvalue "" newvalue
  313.         if {[catch {expr 0+$newvalue}]} {
  314.         set newvalue 0
  315.         set data(-value) 0
  316.         set changed 1
  317.         }
  318.         if {$newvalue == ""} {
  319.         set newvalue 0
  320.         }
  321.  
  322.         if {[tixGetBoolean -nocomplain $data(-integer)]} {
  323.         set data(-value) [tixGetInt -nocomplain $newvalue]
  324.         } else {
  325.         if {[catch {set data(-value) [format "%d" $newvalue]}]} {
  326.             if {[catch {set data(-value) [expr $newvalue+0.0]}]} {
  327.             set data(-value) $oldvalue
  328.             }
  329.         }
  330.         }
  331.         
  332.         # Now perform boundary checking
  333.         #
  334.         if {$data(-max) != "" && $data(-value) > $data(-max)} {
  335.         set data(-value) $data(-max)
  336.         }
  337.         if {$data(-min) != "" && $data(-value) < $data(-min)} {
  338.         set data(-value) $data(-min)
  339.         }
  340.     }
  341.     }
  342.  
  343.     if {! $noUpdate} {
  344.     tixVariable:UpdateVariable $w
  345.     }
  346.  
  347.     if {$forced || "x$newvalue" != "x$data(-value)" || $changed} {
  348.     $data(w:entry) delete 0 end
  349.     $data(w:entry) insert 0 $data(-value)
  350.     $data(w:entry) icursor $oldCursor
  351.     if {[info exists oldSelection]} {
  352.         eval $data(w:entry) selection range $oldSelection
  353.     }
  354.     }
  355.  
  356.     if {!$data(-disablecallback) && $data(-command) != ""} {
  357.     if {![info exists data(varInited)]} {
  358.         set bind(specs) ""
  359.         tixEvalCmdBinding $w $data(-command) bind $data(-value)
  360.     }
  361.     }
  362. }
  363.  
  364. proc tixControl:Invoke {w forced} {
  365.     upvar #0 $w data
  366.  
  367.     catch {
  368.     unset data(edited)
  369.     }
  370.  
  371.     if {[catch {$data(w:entry) index sel.first}] == 0} {
  372.     # THIS ENTRY OWNS SELECTION --> TURN IT OFF
  373.     #
  374.     $data(w:entry) select from end
  375.     $data(w:entry) select to   end
  376.     }
  377.  
  378.     tixControl:SetValue $w [$data(w:entry) get] 0 $forced
  379. }
  380.  
  381. #----------------------------------------------------------------------
  382. # The three functions StartRepeat, Repeat and StopRepeat make use of the
  383. # data(serial) variable to discard spurious repeats: If a button is clicked
  384. # repeatedly but is not hold down, the serial counter will increase
  385. # successively and all "after" time event handlers will be discarded
  386. #----------------------------------------------------------------------
  387. proc tixControl:StartRepeat {w amount} {
  388.     if {![winfo exists $w]} {
  389.     return
  390.     }
  391.  
  392.     upvar #0 $w data
  393.  
  394.     incr data(serial)
  395.     # CYGNUS bug fix
  396.     # Need to set a local variable because otherwise the buttonrelease
  397.     # callback could change the value of data(serial) between now and
  398.     # the time the repeat is scheduled.
  399.     set serial $data(serial)
  400.  
  401.     if {[catch {$data(w:entry) index sel.first}] == 0} {
  402.     $data(w:entry) select from end
  403.     $data(w:entry) select to   end
  404.     }
  405.  
  406.     if {[info exists data(edited)]} {
  407.     unset data(edited)
  408.     tixControl:SetValue $w [$data(w:entry) get] 0 1
  409.     }
  410.  
  411.     tixControl:AdjustValue $w $amount
  412.  
  413.     if {$data(-autorepeat)} {
  414.     after $data(-initwait) tixControl:Repeat $w $amount $serial
  415.     }
  416.  
  417.     focus $data(w:entry)
  418. }
  419.  
  420. proc tixControl:Repeat {w amount serial} {
  421.     if {![winfo exists $w]} {
  422.     return
  423.     }
  424.     upvar #0 $w data
  425.  
  426.     if {$serial == $data(serial)} {
  427.     tixControl:AdjustValue $w $amount
  428.  
  429.     if {$data(-autorepeat)} {
  430.        after $data(-repeatrate) tixControl:Repeat $w $amount $serial
  431.     }
  432.     }
  433. }
  434.  
  435. proc tixControl:StopRepeat {w} {
  436.     upvar #0 $w data
  437.  
  438.     incr data(serial)
  439. }
  440.  
  441. proc tixControl:Destructor {w} {
  442.  
  443.     tixVariable:DeleteVariable $w
  444.  
  445.     # Chain this to the superclass
  446.     #
  447.     tixChainMethod $w Destructor
  448. }
  449.  
  450. # ToDo: maybe should return -code break if the value is not good ...
  451. #
  452. proc tixControl:Tab {w detail} {
  453.     upvar #0 $w data
  454.  
  455.     if {![info exists data(edited)]} {
  456.     return
  457.     } else {
  458.     unset data(edited)
  459.     }
  460.  
  461.     tixControl:invoke $w
  462. }
  463.  
  464. proc tixControl:Escape {w} {
  465.     upvar #0 $w data
  466.  
  467.     $data(w:entry) delete 0 end
  468.     $data(w:entry) insert 0 $data(-value)
  469. }
  470.  
  471. proc tixControl:KeyPress {w} {
  472.     upvar #0 $w data
  473.  
  474.     if {$data(-selectmode) == "normal"} {
  475.     set data(edited) 0
  476.     return
  477.     } else {
  478.     # == "immediate"
  479.     after 1 tixControl:invoke $w
  480.     }
  481. }
  482.