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