home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / comanche.exe / lib / tk8.0 / button.tcl < prev    next >
Text File  |  1999-02-24  |  11KB  |  457 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.3 1998/09/14 18:23:22 stanton Exp $
  8. #
  9. # Copyright (c) 1992-1994 The Regents of the University of California.
  10. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  11. #
  12. # See the file "license.terms" for information on usage and redistribution
  13. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14. #
  15.  
  16. #-------------------------------------------------------------------------
  17. # The code below creates the default class bindings for buttons.
  18. #-------------------------------------------------------------------------
  19.  
  20. if {$tcl_platform(platform) == "macintosh"} {
  21.     bind Radiobutton <Enter> {
  22.     tkButtonEnter %W
  23.     }
  24.     bind Radiobutton <1> {
  25.     tkButtonDown %W
  26.     }
  27.     bind Radiobutton <ButtonRelease-1> {
  28.     tkButtonUp %W
  29.     }
  30.     bind Checkbutton <Enter> {
  31.     tkButtonEnter %W
  32.     }
  33.     bind Checkbutton <1> {
  34.     tkButtonDown %W
  35.     }
  36.     bind Checkbutton <ButtonRelease-1> {
  37.     tkButtonUp %W
  38.     }
  39. }
  40. if {$tcl_platform(platform) == "windows"} {
  41.     bind Checkbutton <equal> {
  42.     tkCheckRadioInvoke %W select
  43.     }
  44.     bind Checkbutton <plus> {
  45.     tkCheckRadioInvoke %W select
  46.     }
  47.     bind Checkbutton <minus> {
  48.     tkCheckRadioInvoke %W deselect
  49.     }
  50.     bind Checkbutton <1> {
  51.     tkCheckRadioDown %W
  52.     }
  53.     bind Checkbutton <ButtonRelease-1> {
  54.     tkButtonUp %W
  55.     }
  56.     bind Checkbutton <Enter> {
  57.     tkCheckRadioEnter %W
  58.     }
  59.  
  60.     bind Radiobutton <1> {
  61.     tkCheckRadioDown %W
  62.     }
  63.     bind Radiobutton <ButtonRelease-1> {
  64.     tkButtonUp %W
  65.     }
  66.     bind Radiobutton <Enter> {
  67.     tkCheckRadioEnter %W
  68.     }
  69. }
  70. if {$tcl_platform(platform) == "unix"} {
  71.     bind Checkbutton <Return> {
  72.     if {!$tk_strictMotif} {
  73.         tkCheckRadioInvoke %W
  74.     }
  75.     }
  76.     bind Radiobutton <Return> {
  77.     if {!$tk_strictMotif} {
  78.         tkCheckRadioInvoke %W
  79.     }
  80.     }
  81.     bind Checkbutton <1> {
  82.     tkCheckRadioInvoke %W
  83.     }
  84.     bind Radiobutton <1> {
  85.     tkCheckRadioInvoke %W
  86.     }
  87.     bind Checkbutton <Enter> {
  88.     tkButtonEnter %W
  89.     }
  90.     bind Radiobutton <Enter> {
  91.     tkButtonEnter %W
  92.     }
  93. }
  94.  
  95. bind Button <space> {
  96.     tkButtonInvoke %W
  97. }
  98. bind Checkbutton <space> {
  99.     tkCheckRadioInvoke %W
  100. }
  101. bind Radiobutton <space> {
  102.     tkCheckRadioInvoke %W
  103. }
  104.  
  105. bind Button <FocusIn> {}
  106. bind Button <Enter> {
  107.     tkButtonEnter %W
  108. }
  109. bind Button <Leave> {
  110.     tkButtonLeave %W
  111. }
  112. bind Button <1> {
  113.     tkButtonDown %W
  114. }
  115. bind Button <ButtonRelease-1> {
  116.     tkButtonUp %W
  117. }
  118.  
  119. bind Checkbutton <FocusIn> {}
  120. bind Checkbutton <Leave> {
  121.     tkButtonLeave %W
  122. }
  123.  
  124. bind Radiobutton <FocusIn> {}
  125. bind Radiobutton <Leave> {
  126.     tkButtonLeave %W
  127. }
  128.  
  129. if {$tcl_platform(platform) == "windows"} {
  130.  
  131. #########################
  132. # Windows implementation 
  133. #########################
  134.  
  135. # tkButtonEnter --
  136. # The procedure below is invoked when the mouse pointer enters a
  137. # button widget.  It records the button we're in and changes the
  138. # state of the button to active unless the button is disabled.
  139. #
  140. # Arguments:
  141. # w -        The name of the widget.
  142.  
  143. proc tkButtonEnter w {
  144.     global tkPriv
  145.     if {[$w cget -state] != "disabled"} {
  146.     if {$tkPriv(buttonWindow) == $w} {
  147.         $w configure -state active -relief sunken
  148.     }
  149.     }
  150.     set tkPriv(window) $w
  151. }
  152.  
  153. # tkButtonLeave --
  154. # The procedure below is invoked when the mouse pointer leaves a
  155. # button widget.  It changes the state of the button back to
  156. # inactive.  If we're leaving the button window with a mouse button
  157. # pressed (tkPriv(buttonWindow) == $w), restore the relief of the
  158. # button too.
  159. #
  160. # Arguments:
  161. # w -        The name of the widget.
  162.  
  163. proc tkButtonLeave w {
  164.     global tkPriv
  165.     if {[$w cget -state] != "disabled"} {
  166.     $w config -state normal
  167.     }
  168.     if {$w == $tkPriv(buttonWindow)} {
  169.     $w configure -relief $tkPriv(relief)
  170.     }
  171.     set tkPriv(window) ""
  172. }
  173.  
  174. # tkCheckRadioEnter --
  175. # The procedure below is invoked when the mouse pointer enters a
  176. # checkbutton or radiobutton widget.  It records the button we're in
  177. # and changes the state of the button to active unless the button is
  178. # disabled.
  179. #
  180. # Arguments:
  181. # w -        The name of the widget.
  182.  
  183. proc tkCheckRadioEnter w {
  184.     global tkPriv
  185.     if {[$w cget -state] != "disabled"} {
  186.     if {$tkPriv(buttonWindow) == $w} {
  187.         $w configure -state active
  188.     }
  189.     }
  190.     set tkPriv(window) $w
  191. }
  192.  
  193. # tkButtonDown --
  194. # The procedure below is invoked when the mouse button is pressed in
  195. # a button widget.  It records the fact that the mouse is in the button,
  196. # saves the button's relief so it can be restored later, and changes
  197. # the relief to sunken.
  198. #
  199. # Arguments:
  200. # w -        The name of the widget.
  201.  
  202. proc tkButtonDown w {
  203.     global tkPriv
  204.     set tkPriv(relief) [lindex [$w conf -relief] 4]
  205.     if {[$w cget -state] != "disabled"} {
  206.     set tkPriv(buttonWindow) $w
  207.     $w config -relief sunken -state active
  208.     }
  209. }
  210.  
  211. # tkCheckRadioDown --
  212. # The procedure below is invoked when the mouse button is pressed in
  213. # a button widget.  It records the fact that the mouse is in the button,
  214. # saves the button's relief so it can be restored later, and changes
  215. # the relief to sunken.
  216. #
  217. # Arguments:
  218. # w -        The name of the widget.
  219.  
  220. proc tkCheckRadioDown w {
  221.     global tkPriv
  222.     set tkPriv(relief) [lindex [$w conf -relief] 4]
  223.     if {[$w cget -state] != "disabled"} {
  224.     set tkPriv(buttonWindow) $w
  225.     $w config -state active
  226.     }
  227. }
  228.  
  229. # tkButtonUp --
  230. # The procedure below is invoked when the mouse button is released
  231. # in a button widget.  It restores the button's relief and invokes
  232. # the command as long as the mouse hasn't left the button.
  233. #
  234. # Arguments:
  235. # w -        The name of the widget.
  236.  
  237. proc tkButtonUp w {
  238.     global tkPriv
  239.     if {$w == $tkPriv(buttonWindow)} {
  240.     set tkPriv(buttonWindow) ""
  241.     if {($w == $tkPriv(window))
  242.         && ([$w cget -state] != "disabled")} {
  243.         $w config -relief $tkPriv(relief) -state normal
  244.         uplevel #0 [list $w invoke]
  245.     }
  246.     }
  247. }
  248.  
  249. }
  250.  
  251. if {$tcl_platform(platform) == "unix"} {
  252.  
  253. #####################
  254. # Unix implementation
  255. #####################
  256.  
  257. # tkButtonEnter --
  258. # The procedure below is invoked when the mouse pointer enters a
  259. # button widget.  It records the button we're in and changes the
  260. # state of the button to active unless the button is disabled.
  261. #
  262. # Arguments:
  263. # w -        The name of the widget.
  264.  
  265. proc tkButtonEnter {w} {
  266.     global tkPriv
  267.     if {[$w cget -state] != "disabled"} {
  268.     $w config -state active
  269.     if {$tkPriv(buttonWindow) == $w} {
  270.         $w configure -state active -relief sunken
  271.     }
  272.     }
  273.     set tkPriv(window) $w
  274. }
  275.  
  276. # tkButtonLeave --
  277. # The procedure below is invoked when the mouse pointer leaves a
  278. # button widget.  It changes the state of the button back to
  279. # inactive.  If we're leaving the button window with a mouse button
  280. # pressed (tkPriv(buttonWindow) == $w), restore the relief of the
  281. # button too.
  282. #
  283. # Arguments:
  284. # w -        The name of the widget.
  285.  
  286. proc tkButtonLeave w {
  287.     global tkPriv
  288.     if {[$w cget -state] != "disabled"} {
  289.     $w config -state normal
  290.     }
  291.     if {$w == $tkPriv(buttonWindow)} {
  292.     $w configure -relief $tkPriv(relief)
  293.     }
  294.     set tkPriv(window) ""
  295. }
  296.  
  297. # tkButtonDown --
  298. # The procedure below is invoked when the mouse button is pressed in
  299. # a button widget.  It records the fact that the mouse is in the button,
  300. # saves the button's relief so it can be restored later, and changes
  301. # the relief to sunken.
  302. #
  303. # Arguments:
  304. # w -        The name of the widget.
  305.  
  306. proc tkButtonDown w {
  307.     global tkPriv
  308.     set tkPriv(relief) [lindex [$w config -relief] 4]
  309.     if {[$w cget -state] != "disabled"} {
  310.     set tkPriv(buttonWindow) $w
  311.     $w config -relief sunken
  312.     }
  313. }
  314.  
  315. # tkButtonUp --
  316. # The procedure below is invoked when the mouse button is released
  317. # in a button widget.  It restores the button's relief and invokes
  318. # the command as long as the mouse hasn't left the button.
  319. #
  320. # Arguments:
  321. # w -        The name of the widget.
  322.  
  323. proc tkButtonUp w {
  324.     global tkPriv
  325.     if {$w == $tkPriv(buttonWindow)} {
  326.     set tkPriv(buttonWindow) ""
  327.     $w config -relief $tkPriv(relief)
  328.     if {($w == $tkPriv(window))
  329.         && ([$w cget -state] != "disabled")} {
  330.         uplevel #0 [list $w invoke]
  331.     }
  332.     }
  333. }
  334.  
  335. }
  336.  
  337. if {$tcl_platform(platform) == "macintosh"} {
  338.  
  339. ####################
  340. # Mac implementation
  341. ####################
  342.  
  343. # tkButtonEnter --
  344. # The procedure below is invoked when the mouse pointer enters a
  345. # button widget.  It records the button we're in and changes the
  346. # state of the button to active unless the button is disabled.
  347. #
  348. # Arguments:
  349. # w -        The name of the widget.
  350.  
  351. proc tkButtonEnter {w} {
  352.     global tkPriv
  353.     if {[$w cget -state] != "disabled"} {
  354.     if {$tkPriv(buttonWindow) == $w} {
  355.         $w configure -state active
  356.     }
  357.     }
  358.     set tkPriv(window) $w
  359. }
  360.  
  361. # tkButtonLeave --
  362. # The procedure below is invoked when the mouse pointer leaves a
  363. # button widget.  It changes the state of the button back to
  364. # inactive.  If we're leaving the button window with a mouse button
  365. # pressed (tkPriv(buttonWindow) == $w), restore the relief of the
  366. # button too.
  367. #
  368. # Arguments:
  369. # w -        The name of the widget.
  370.  
  371. proc tkButtonLeave w {
  372.     global tkPriv
  373.     if {$w == $tkPriv(buttonWindow)} {
  374.     $w configure -state normal
  375.     }
  376.     set tkPriv(window) ""
  377. }
  378.  
  379. # tkButtonDown --
  380. # The procedure below is invoked when the mouse button is pressed in
  381. # a button widget.  It records the fact that the mouse is in the button,
  382. # saves the button's relief so it can be restored later, and changes
  383. # the relief to sunken.
  384. #
  385. # Arguments:
  386. # w -        The name of the widget.
  387.  
  388. proc tkButtonDown w {
  389.     global tkPriv
  390.     if {[$w cget -state] != "disabled"} {
  391.     set tkPriv(buttonWindow) $w
  392.     $w config -state active
  393.     }
  394. }
  395.  
  396. # tkButtonUp --
  397. # The procedure below is invoked when the mouse button is released
  398. # in a button widget.  It restores the button's relief and invokes
  399. # the command as long as the mouse hasn't left the button.
  400. #
  401. # Arguments:
  402. # w -        The name of the widget.
  403.  
  404. proc tkButtonUp w {
  405.     global tkPriv
  406.     if {$w == $tkPriv(buttonWindow)} {
  407.     $w config -state normal
  408.     set tkPriv(buttonWindow) ""
  409.     if {($w == $tkPriv(window))
  410.         && ([$w cget -state] != "disabled")} {
  411.         uplevel #0 [list $w invoke]
  412.     }
  413.     }
  414. }
  415.  
  416. }
  417.  
  418. ##################
  419. # Shared routines
  420. ##################
  421.  
  422. # tkButtonInvoke --
  423. # The procedure below is called when a button is invoked through
  424. # the keyboard.  It simulate a press of the button via the mouse.
  425. #
  426. # Arguments:
  427. # w -        The name of the widget.
  428.  
  429. proc tkButtonInvoke w {
  430.     if {[$w cget -state] != "disabled"} {
  431.     set oldRelief [$w cget -relief]
  432.     set oldState [$w cget -state]
  433.     $w configure -state active -relief sunken
  434.     update idletasks
  435.     after 100
  436.     $w configure -state $oldState -relief $oldRelief
  437.     uplevel #0 [list $w invoke]
  438.     }
  439. }
  440.  
  441. # tkCheckRadioInvoke --
  442. # The procedure below is invoked when the mouse button is pressed in
  443. # a checkbutton or radiobutton widget, or when the widget is invoked
  444. # through the keyboard.  It invokes the widget if it
  445. # isn't disabled.
  446. #
  447. # Arguments:
  448. # w -        The name of the widget.
  449. # cmd -        The subcommand to invoke (one of invoke, select, or deselect).
  450.  
  451. proc tkCheckRadioInvoke {w {cmd invoke}} {
  452.     if {[$w cget -state] != "disabled"} {
  453.     uplevel #0 [list $w $cmd]
  454.     }
  455. }
  456.  
  457.