lib/tk8.4/button.tcl

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