home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 June / PCWorld_2005-06_cd.bin / software / vyzkuste / firewally / firewally.exe / framework-2.3.exe / button.tcl < prev    next >
Text File  |  2003-09-01  |  17KB  |  640 lines
  1. # button.tcl --
  2. #
  3. # This file defines the default bindings for Tk label, button,
  4. # checkbutton, and radiobutton widgets and provides procedures
  5. # that help in implementing those bindings.
  6. #
  7. # RCS: @(#) $Id: button.tcl,v 1.17 2002/09/04 02:05:52 hobbs Exp $
  8. #
  9. # Copyright (c) 1992-1994 The Regents of the University of California.
  10. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  11. # Copyright (c) 2002 ActiveState Corporation.
  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. #-------------------------------------------------------------------------
  18. # The code below creates the default class bindings for buttons.
  19. #-------------------------------------------------------------------------
  20.  
  21. if {[string equal [tk windowingsystem] "classic"]
  22.     || [string equal [tk windowingsystem] "aqua"]} {
  23.     bind Radiobutton <Enter> {
  24.     tk::ButtonEnter %W
  25.     }
  26.     bind Radiobutton <1> {
  27.     tk::ButtonDown %W
  28.     }
  29.     bind Radiobutton <ButtonRelease-1> {
  30.     tk::ButtonUp %W
  31.     }
  32.     bind Checkbutton <Enter> {
  33.     tk::ButtonEnter %W
  34.     }
  35.     bind Checkbutton <1> {
  36.     tk::ButtonDown %W
  37.     }
  38.     bind Checkbutton <ButtonRelease-1> {
  39.     tk::ButtonUp %W
  40.     }
  41. }
  42. if {[string equal "windows" $tcl_platform(platform)]} {
  43.     bind Checkbutton <equal> {
  44.     tk::CheckRadioInvoke %W select
  45.     }
  46.     bind Checkbutton <plus> {
  47.     tk::CheckRadioInvoke %W select
  48.     }
  49.     bind Checkbutton <minus> {
  50.     tk::CheckRadioInvoke %W deselect
  51.     }
  52.     bind Checkbutton <1> {
  53.     tk::CheckRadioDown %W
  54.     }
  55.     bind Checkbutton <ButtonRelease-1> {
  56.     tk::ButtonUp %W
  57.     }
  58.     bind Checkbutton <Enter> {
  59.     tk::CheckRadioEnter %W
  60.     }
  61.  
  62.     bind Radiobutton <1> {
  63.     tk::CheckRadioDown %W
  64.     }
  65.     bind Radiobutton <ButtonRelease-1> {
  66.     tk::ButtonUp %W
  67.     }
  68.     bind Radiobutton <Enter> {
  69.     tk::CheckRadioEnter %W
  70.     }
  71. }
  72. if {[string equal "x11" [tk windowingsystem]]} {
  73.     bind Checkbutton <Return> {
  74.     if {!$tk_strictMotif} {
  75.         tk::CheckRadioInvoke %W
  76.     }
  77.     }
  78.     bind Radiobutton <Return> {
  79.     if {!$tk_strictMotif} {
  80.         tk::CheckRadioInvoke %W
  81.     }
  82.     }
  83.     bind Checkbutton <1> {
  84.     tk::CheckRadioInvoke %W
  85.     }
  86.     bind Radiobutton <1> {
  87.     tk::CheckRadioInvoke %W
  88.     }
  89.     bind Checkbutton <Enter> {
  90.     tk::ButtonEnter %W
  91.     }
  92.     bind Radiobutton <Enter> {
  93.     tk::ButtonEnter %W
  94.     }
  95. }
  96.  
  97. bind Button <space> {
  98.     tk::ButtonInvoke %W
  99. }
  100. bind Checkbutton <space> {
  101.     tk::CheckRadioInvoke %W
  102. }
  103. bind Radiobutton <space> {
  104.     tk::CheckRadioInvoke %W
  105. }
  106.  
  107. bind Button <FocusIn> {}
  108. bind Button <Enter> {
  109.     tk::ButtonEnter %W
  110. }
  111. bind Button <Leave> {
  112.     tk::ButtonLeave %W
  113. }
  114. bind Button <1> {
  115.     tk::ButtonDown %W
  116. }
  117. bind Button <ButtonRelease-1> {
  118.     tk::ButtonUp %W
  119. }
  120.  
  121. bind Checkbutton <FocusIn> {}
  122. bind Checkbutton <Leave> {
  123.     tk::ButtonLeave %W
  124. }
  125.  
  126. bind Radiobutton <FocusIn> {}
  127. bind Radiobutton <Leave> {
  128.     tk::ButtonLeave %W
  129. }
  130.  
  131. if {[string equal "windows" $tcl_platform(platform)]} {
  132.  
  133. #########################
  134. # Windows implementation 
  135. #########################
  136.  
  137. # ::tk::ButtonEnter --
  138. # The procedure below is invoked when the mouse pointer enters a
  139. # button widget.  It records the button we're in and changes the
  140. # state of the button to active unless the button is disabled.
  141. #
  142. # Arguments:
  143. # w -        The name of the widget.
  144.  
  145. proc ::tk::ButtonEnter w {
  146.     variable ::tk::Priv
  147.     if {[$w cget -state] ne "disabled"} {
  148.  
  149.     # If the mouse button is down, set the relief to sunken on entry.
  150.     # Overwise, if there's an -overrelief value, set the relief to that.
  151.  
  152.     set Priv($w,relief) [$w cget -relief]
  153.     if {$Priv(buttonWindow) eq $w} {
  154.         $w configure -relief sunken -state active
  155.         set Priv($w,prelief) sunken
  156.     } elseif {[set over [$w cget -overrelief]] ne ""} {
  157.         $w configure -relief $over
  158.         set Priv($w,prelief) $over
  159.     }
  160.     }
  161.     set Priv(window) $w
  162. }
  163.  
  164. # ::tk::ButtonLeave --
  165. # The procedure below is invoked when the mouse pointer leaves a
  166. # button widget.  It changes the state of the button back to inactive.
  167. # Restore any modified relief too.
  168. #
  169. # Arguments:
  170. # w -        The name of the widget.
  171.  
  172. proc ::tk::ButtonLeave w {
  173.     variable ::tk::Priv
  174.     if {[$w cget -state] ne "disabled"} {
  175.     $w configure -state normal
  176.     }
  177.  
  178.     # Restore the original button relief if it was changed by Tk.
  179.     # That is signaled by the existence of Priv($w,prelief).
  180.  
  181.     if {[info exists Priv($w,relief)]} {
  182.     if {[info exists Priv($w,prelief)] && \
  183.         $Priv($w,prelief) eq [$w cget -relief]} {
  184.         $w configure -relief $Priv($w,relief)
  185.     }
  186.     unset -nocomplain Priv($w,relief) Priv($w,prelief)
  187.     }
  188.  
  189.     set Priv(window) ""
  190. }
  191.  
  192. # ::tk::ButtonDown --
  193. # The procedure below is invoked when the mouse button is pressed in
  194. # a button widget.  It records the fact that the mouse is in the button,
  195. # saves the button's relief so it can be restored later, and changes
  196. # the relief to sunken.
  197. #
  198. # Arguments:
  199. # w -        The name of the widget.
  200.  
  201. proc ::tk::ButtonDown w {
  202.     variable ::tk::Priv
  203.  
  204.     # Only save the button's relief if it does not yet exist.  If there
  205.     # is an overrelief setting, Priv($w,relief) will already have been set,
  206.     # and the current value of the -relief option will be incorrect.
  207.  
  208.     if {![info exists Priv($w,relief)]} {
  209.     set Priv($w,relief) [$w cget -relief]
  210.     }
  211.  
  212.     if {[$w cget -state] ne "disabled"} {
  213.     set Priv(buttonWindow) $w
  214.     $w configure -relief sunken -state active
  215.     set Priv($w,prelief) sunken
  216.  
  217.     # If this button has a repeatdelay set up, get it going with an after
  218.     after cancel $Priv(afterId)
  219.     set delay [$w cget -repeatdelay]
  220.     set Priv(repeated) 0
  221.     if {$delay > 0} {
  222.         set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
  223.     }
  224.     }
  225. }
  226.  
  227. # ::tk::ButtonUp --
  228. # The procedure below is invoked when the mouse button is released
  229. # in a button widget.  It restores the button's relief and invokes
  230. # the command as long as the mouse hasn't left the button.
  231. #
  232. # Arguments:
  233. # w -        The name of the widget.
  234.  
  235. proc ::tk::ButtonUp w {
  236.     variable ::tk::Priv
  237.     if {$Priv(buttonWindow) eq $w} {
  238.     set Priv(buttonWindow) ""
  239.  
  240.     # Restore the button's relief if it was cached.
  241.  
  242.     if {[info exists Priv($w,relief)]} {
  243.         if {[info exists Priv($w,prelief)] && \
  244.             $Priv($w,prelief) eq [$w cget -relief]} {
  245.         $w configure -relief $Priv($w,relief)
  246.         }
  247.         unset -nocomplain Priv($w,relief) Priv($w,prelief)
  248.     }
  249.  
  250.     # Clean up the after event from the auto-repeater
  251.     after cancel $Priv(afterId)
  252.  
  253.     if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
  254.         $w configure -state normal
  255.  
  256.         # Only invoke the command if it wasn't already invoked by the
  257.         # auto-repeater functionality
  258.         if { $Priv(repeated) == 0 } {
  259.         uplevel #0 [list $w invoke]
  260.         }
  261.     }
  262.     }
  263. }
  264.  
  265. # ::tk::CheckRadioEnter --
  266. # The procedure below is invoked when the mouse pointer enters a
  267. # checkbutton or radiobutton widget.  It records the button we're in
  268. # and changes the state of the button to active unless the button is
  269. # disabled.
  270. #
  271. # Arguments:
  272. # w -        The name of the widget.
  273.  
  274. proc ::tk::CheckRadioEnter w {
  275.     variable ::tk::Priv
  276.     if {[$w cget -state] ne "disabled"} {
  277.     if {$Priv(buttonWindow) eq $w} {
  278.         $w configure -state active
  279.     }
  280.     if {[set over [$w cget -overrelief]] ne ""} {
  281.         set Priv($w,relief)  [$w cget -relief]
  282.         set Priv($w,prelief) $over
  283.         $w configure -relief $over
  284.     }
  285.     }
  286.     set Priv(window) $w
  287. }
  288.  
  289. # ::tk::CheckRadioDown --
  290. # The procedure below is invoked when the mouse button is pressed in
  291. # a button widget.  It records the fact that the mouse is in the button,
  292. # saves the button's relief so it can be restored later, and changes
  293. # the relief to sunken.
  294. #
  295. # Arguments:
  296. # w -        The name of the widget.
  297.  
  298. proc ::tk::CheckRadioDown w {
  299.     variable ::tk::Priv
  300.     if {![info exists Priv($w,relief)]} {
  301.     set Priv($w,relief) [$w cget -relief]
  302.     }
  303.     if {[$w cget -state] ne "disabled"} {
  304.     set Priv(buttonWindow) $w
  305.     set Priv(repeated) 0
  306.     $w configure -state active
  307.     }
  308. }
  309.  
  310. }
  311.  
  312. if {[string equal "x11" [tk windowingsystem]]} {
  313.  
  314. #####################
  315. # Unix implementation
  316. #####################
  317.  
  318. # ::tk::ButtonEnter --
  319. # The procedure below is invoked when the mouse pointer enters a
  320. # button widget.  It records the button we're in and changes the
  321. # state of the button to active unless the button is disabled.
  322. #
  323. # Arguments:
  324. # w -        The name of the widget.
  325.  
  326. proc ::tk::ButtonEnter {w} {
  327.     variable ::tk::Priv
  328.     if {[$w cget -state] ne "disabled"} {
  329.     # On unix the state is active just with mouse-over
  330.     $w configure -state active
  331.  
  332.     # If the mouse button is down, set the relief to sunken on entry.
  333.     # Overwise, if there's an -overrelief value, set the relief to that.
  334.  
  335.     set Priv($w,relief) [$w cget -relief]
  336.     if {$Priv(buttonWindow) eq $w} {
  337.         $w configure -relief sunken
  338.         set Priv($w,prelief) sunken
  339.     } elseif {[set over [$w cget -overrelief]] ne ""} {
  340.         $w configure -relief $over
  341.         set Priv($w,prelief) $over
  342.     }
  343.     }
  344.     set Priv(window) $w
  345. }
  346.  
  347. # ::tk::ButtonLeave --
  348. # The procedure below is invoked when the mouse pointer leaves a
  349. # button widget.  It changes the state of the button back to inactive.
  350. # Restore any modified relief too.
  351. #
  352. # Arguments:
  353. # w -        The name of the widget.
  354.  
  355. proc ::tk::ButtonLeave w {
  356.     variable ::tk::Priv
  357.     if {[$w cget -state] ne "disabled"} {
  358.     $w configure -state normal
  359.     }
  360.  
  361.     # Restore the original button relief if it was changed by Tk.
  362.     # That is signaled by the existence of Priv($w,prelief).
  363.  
  364.     if {[info exists Priv($w,relief)]} {
  365.     if {[info exists Priv($w,prelief)] && \
  366.         $Priv($w,prelief) eq [$w cget -relief]} {
  367.         $w configure -relief $Priv($w,relief)
  368.     }
  369.     unset -nocomplain Priv($w,relief) Priv($w,prelief)
  370.     }
  371.  
  372.     set Priv(window) ""
  373. }
  374.  
  375. # ::tk::ButtonDown --
  376. # The procedure below is invoked when the mouse button is pressed in
  377. # a button widget.  It records the fact that the mouse is in the button,
  378. # saves the button's relief so it can be restored later, and changes
  379. # the relief to sunken.
  380. #
  381. # Arguments:
  382. # w -        The name of the widget.
  383.  
  384. proc ::tk::ButtonDown w {
  385.     variable ::tk::Priv
  386.  
  387.     # Only save the button's relief if it does not yet exist.  If there
  388.     # is an overrelief setting, Priv($w,relief) will already have been set,
  389.     # and the current value of the -relief option will be incorrect.
  390.  
  391.     if {![info exists Priv($w,relief)]} {
  392.     set Priv($w,relief) [$w cget -relief]
  393.     }
  394.  
  395.     if {[$w cget -state] ne "disabled"} {
  396.     set Priv(buttonWindow) $w
  397.     $w configure -relief sunken
  398.     set Priv($w,prelief) sunken
  399.  
  400.     # If this button has a repeatdelay set up, get it going with an after
  401.     after cancel $Priv(afterId)
  402.     set delay [$w cget -repeatdelay]
  403.     set Priv(repeated) 0
  404.     if {$delay > 0} {
  405.         set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
  406.     }
  407.     }
  408. }
  409.  
  410. # ::tk::ButtonUp --
  411. # The procedure below is invoked when the mouse button is released
  412. # in a button widget.  It restores the button's relief and invokes
  413. # the command as long as the mouse hasn't left the button.
  414. #
  415. # Arguments:
  416. # w -        The name of the widget.
  417.  
  418. proc ::tk::ButtonUp w {
  419.     variable ::tk::Priv
  420.     if {[string equal $w $Priv(buttonWindow)]} {
  421.     set Priv(buttonWindow) ""
  422.  
  423.     # Restore the button's relief if it was cached.
  424.  
  425.     if {[info exists Priv($w,relief)]} {
  426.         if {[info exists Priv($w,prelief)] && \
  427.             $Priv($w,prelief) eq [$w cget -relief]} {
  428.         $w configure -relief $Priv($w,relief)
  429.         }
  430.         unset -nocomplain Priv($w,relief) Priv($w,prelief)
  431.     }
  432.  
  433.     # Clean up the after event from the auto-repeater
  434.     after cancel $Priv(afterId)
  435.  
  436.     if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
  437.         # Only invoke the command if it wasn't already invoked by the
  438.         # auto-repeater functionality
  439.         if { $Priv(repeated) == 0 } {
  440.         uplevel #0 [list $w invoke]
  441.         }
  442.     }
  443.     }
  444. }
  445.  
  446. }
  447.  
  448. if {[string equal [tk windowingsystem] "classic"]
  449.     || [string equal [tk windowingsystem] "aqua"]} {
  450.  
  451. ####################
  452. # Mac implementation
  453. ####################
  454.  
  455. # ::tk::ButtonEnter --
  456. # The procedure below is invoked when the mouse pointer enters a
  457. # button widget.  It records the button we're in and changes the
  458. # state of the button to active unless the button is disabled.
  459. #
  460. # Arguments:
  461. # w -        The name of the widget.
  462.  
  463. proc ::tk::ButtonEnter {w} {
  464.     variable ::tk::Priv
  465.     if {[$w cget -state] ne "disabled"} {
  466.  
  467.     # If there's an -overrelief value, set the relief to that.
  468.  
  469.     if {$Priv(buttonWindow) eq $w} {
  470.         $w configure -state active
  471.     } elseif {[set over [$w cget -overrelief]] ne ""} {
  472.         set Priv($w,relief)  [$w cget -relief]
  473.         set Priv($w,prelief) $over
  474.         $w configure -relief $over
  475.     }
  476.     }
  477.     set Priv(window) $w
  478. }
  479.  
  480. # ::tk::ButtonLeave --
  481. # The procedure below is invoked when the mouse pointer leaves a
  482. # button widget.  It changes the state of the button back to
  483. # inactive.  If we're leaving the button window with a mouse button
  484. # pressed (Priv(buttonWindow) == $w), restore the relief of the
  485. # button too.
  486. #
  487. # Arguments:
  488. # w -        The name of the widget.
  489.  
  490. proc ::tk::ButtonLeave w {
  491.     variable ::tk::Priv
  492.     if {$w eq $Priv(buttonWindow)} {
  493.     $w configure -state normal
  494.     }
  495.  
  496.     # Restore the original button relief if it was changed by Tk.
  497.     # That is signaled by the existence of Priv($w,prelief).
  498.  
  499.     if {[info exists Priv($w,relief)]} {
  500.     if {[info exists Priv($w,prelief)] && \
  501.         $Priv($w,prelief) eq [$w cget -relief]} {
  502.         $w configure -relief $Priv($w,relief)
  503.     }
  504.     unset -nocomplain Priv($w,relief) Priv($w,prelief)
  505.     }
  506.  
  507.     set Priv(window) ""
  508. }
  509.  
  510. # ::tk::ButtonDown --
  511. # The procedure below is invoked when the mouse button is pressed in
  512. # a button widget.  It records the fact that the mouse is in the button,
  513. # saves the button's relief so it can be restored later, and changes
  514. # the relief to sunken.
  515. #
  516. # Arguments:
  517. # w -        The name of the widget.
  518.  
  519. proc ::tk::ButtonDown w {
  520.     variable ::tk::Priv
  521.  
  522.     if {[$w cget -state] ne "disabled"} {
  523.     set Priv(buttonWindow) $w
  524.     $w configure -state active
  525.  
  526.     # If this button has a repeatdelay set up, get it going with an after
  527.     after cancel $Priv(afterId)
  528.     set Priv(repeated) 0
  529.     if { ![catch {$w cget -repeatdelay} delay] } {
  530.         if {$delay > 0} {
  531.         set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
  532.         }
  533.     }
  534.     }
  535. }
  536.  
  537. # ::tk::ButtonUp --
  538. # The procedure below is invoked when the mouse button is released
  539. # in a button widget.  It restores the button's relief and invokes
  540. # the command as long as the mouse hasn't left the button.
  541. #
  542. # Arguments:
  543. # w -        The name of the widget.
  544.  
  545. proc ::tk::ButtonUp w {
  546.     variable ::tk::Priv
  547.     if {$Priv(buttonWindow) eq $w} {
  548.     set Priv(buttonWindow) ""
  549.     $w configure -state normal
  550.  
  551.     # Restore the button's relief if it was cached.
  552.  
  553.     if {[info exists Priv($w,relief)]} {
  554.         if {[info exists Priv($w,prelief)] && \
  555.             $Priv($w,prelief) eq [$w cget -relief]} {
  556.         $w configure -relief $Priv($w,relief)
  557.         }
  558.         unset -nocomplain Priv($w,relief) Priv($w,prelief)
  559.     }
  560.  
  561.     # Clean up the after event from the auto-repeater
  562.     after cancel $Priv(afterId)
  563.  
  564.     if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
  565.         # Only invoke the command if it wasn't already invoked by the
  566.         # auto-repeater functionality
  567.         if { $Priv(repeated) == 0 } {
  568.         uplevel #0 [list $w invoke]
  569.         }
  570.     }
  571.     }
  572. }
  573.  
  574. }
  575.  
  576. ##################
  577. # Shared routines
  578. ##################
  579.  
  580. # ::tk::ButtonInvoke --
  581. # The procedure below is called when a button is invoked through
  582. # the keyboard.  It simulate a press of the button via the mouse.
  583. #
  584. # Arguments:
  585. # w -        The name of the widget.
  586.  
  587. proc ::tk::ButtonInvoke w {
  588.     if {[$w cget -state] ne "disabled"} {
  589.     set oldRelief [$w cget -relief]
  590.     set oldState [$w cget -state]
  591.     $w configure -state active -relief sunken
  592.     update idletasks
  593.     after 100
  594.     $w configure -state $oldState -relief $oldRelief
  595.     uplevel #0 [list $w invoke]
  596.     }
  597. }
  598.  
  599. # ::tk::ButtonAutoInvoke --
  600. #
  601. #    Invoke an auto-repeating button, and set it up to continue to repeat.
  602. #
  603. # Arguments:
  604. #    w    button to invoke.
  605. #
  606. # Results:
  607. #    None.
  608. #
  609. # Side effects:
  610. #    May create an after event to call ::tk::ButtonAutoInvoke.
  611.  
  612. proc ::tk::ButtonAutoInvoke {w} {
  613.     variable ::tk::Priv
  614.     after cancel $Priv(afterId)
  615.     set delay [$w cget -repeatinterval]
  616.     if {$Priv(window) eq $w} {
  617.     incr Priv(repeated)
  618.     uplevel #0 [list $w invoke]
  619.     }
  620.     if {$delay > 0} {
  621.     set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
  622.     }
  623. }
  624.  
  625. # ::tk::CheckRadioInvoke --
  626. # The procedure below is invoked when the mouse button is pressed in
  627. # a checkbutton or radiobutton widget, or when the widget is invoked
  628. # through the keyboard.  It invokes the widget if it
  629. # isn't disabled.
  630. #
  631. # Arguments:
  632. # w -        The name of the widget.
  633. # cmd -        The subcommand to invoke (one of invoke, select, or deselect).
  634.  
  635. proc ::tk::CheckRadioInvoke {w {cmd invoke}} {
  636.     if {[$w cget -state] ne "disabled"} {
  637.     uplevel #0 [list $w $cmd]
  638.     }
  639. }
  640.