1# This file is a Tcl script to test the code in tkEvent.c. It is 2# organized in the standard fashion for Tcl tests. 3# 4# Copyright (c) 1994 The Regents of the University of California. 5# Copyright (c) 1994-1995 Sun Microsystems, Inc. 6# Copyright (c) 1998-1999 by Scriptics Corporation. 7# All rights reserved. 8# 9# RCS: @(#) $Id: event.test,v 1.13 2003/02/18 06:22:44 mdejong Exp $ 10 11package require tcltest 2.1 12namespace import -force tcltest::configure 13namespace import -force tcltest::testsDirectory 14configure -testdir [file join [pwd] [file dirname [info script]]] 15configure -loadfile [file join [testsDirectory] constraints.tcl] 16tcltest::loadTestedCommands 17 18# XXX This test file is woefully incomplete. Right now it only tests 19# a few of the procedures in tkEvent.c. Please add more tests whenever 20# possible. 21 22# Setup table used to query key events. 23 24proc _init_keypress_lookup { } { 25 global keypress_lookup 26 27 scan A %c start 28 scan Z %c finish 29 30 for {set i $start} {$i <= $finish} {incr i} { 31 set l [format %c $i] 32 set keypress_lookup($l) $l 33 } 34 35 scan a %c start 36 scan z %c finish 37 38 for {set i $start} {$i <= $finish} {incr i} { 39 set l [format %c $i] 40 set keypress_lookup($l) $l 41 } 42 43 scan 0 %c start 44 scan 9 %c finish 45 46 for {set i $start} {$i <= $finish} {incr i} { 47 set l [format %c $i] 48 set keypress_lookup($l) $l 49 } 50 51 array set keypress_lookup [list \ 52 " " space \ 53 ! exclam \ 54 \" quotedbl \ 55 \# numbersign \ 56 \$ dollar \ 57 % percent \ 58 & ampersand \ 59 ( parenleft \ 60 ) parenright \ 61 * asterisk \ 62 + plus \ 63 , comma \ 64 - minus \ 65 . period \ 66 / slash \ 67 : colon \ 68 \; semicolon \ 69 < less \ 70 = equal \ 71 > greater \ 72 ? question \ 73 @ at \ 74 \[ bracketleft \ 75 \\ backslash \ 76 \] bracketright \ 77 ^ asciicircum \ 78 _ underscore \ 79 \{ braceleft \ 80 | bar \ 81 \} braceright \ 82 ~ asciitilde \ 83 ' apostrophe \ 84 "\n" Return] 85} 86 87 88# Lookup an event in the keypress table. 89# For example: 90# Q -> Q 91# . -> period 92# / -> slash 93# Delete -> Delete 94# Escape -> Escape 95 96proc _keypress_lookup { char } { 97 global keypress_lookup 98 99 if {! [info exists keypress_lookup]} { 100 _init_keypress_lookup 101 } 102 103 if {$char == ""} { 104 error "empty char" 105 } 106 107 if {[info exists keypress_lookup($char)]} { 108 return $keypress_lookup($char) 109 } else { 110 return $char 111 } 112} 113 114 115# Lookup and generate a pair of KeyPress and KeyRelease events 116 117proc _keypress { win key } { 118 set keysym [_keypress_lookup $key] 119 120 # Force focus to the window before delivering 121 # each event so that a window manager using 122 # a focus follows mouse will not steal away 123 # the focus if the mouse is moved around. 124 125 if {[focus] != $win} { 126 focus -force $win 127 } 128 event generate $win <KeyPress-$keysym> 129 _pause 50 130 if {[focus] != $win} { 131 focus -force $win 132 } 133 event generate $win <KeyRelease-$keysym> 134 _pause 50 135} 136 137# Call _keypress for each character in the given string 138 139proc _keypress_string { win string } { 140 foreach letter [split $string ""] { 141 _keypress $win $letter 142 } 143} 144 145# Delay script execution for a given amount of time 146 147proc _pause { {msecs 1000} } { 148 global _pause 149 150 if {! [info exists _pause(number)]} { 151 set _pause(number) 0 152 } 153 154 set num [incr _pause(number)] 155 set _pause($num) 0 156 157 after $msecs "set _pause($num) 1" 158 vwait _pause($num) 159 unset _pause($num) 160} 161 162# Helper proc to convert index to x y position 163 164proc _text_ind_to_x_y { text ind } { 165 set bbox [$text bbox $ind] 166 if {[llength $bbox] != 4} { 167 error "got bbox \{$bbox\} from $text, index $ind" 168 } 169 foreach {x1 y1 width height} $bbox break 170 set middle_y [expr {$y1 + ($height / 2)}] 171 return [list $x1 $middle_y] 172} 173 174# Return selection only if owned by the given widget 175 176proc _get_selection { widget } { 177 if {[string compare $widget [selection own]] != 0} { 178 return "" 179 } 180 if {[catch {selection get} sel]} { 181 return "" 182 } 183 return $sel 184} 185 186# Begining of the actual tests 187 188test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} { 189 button .b -text Test 190 pack .b 191 bindtags .b .b 192 update 193 bind .b <Destroy> { 194 lappend x destroy 195 event generate .b <1> 196 event generate .b <ButtonRelease-1> 197 } 198 bind .b <1> { 199 lappend x button 200 } 201 set x {} 202 destroy .b 203 set x 204} {destroy} 205 206test event-1.2 {event generate <Alt-z>} { 207 catch {destroy .e} 208 catch {unset ::event12result} 209 set ::event12result 0 210 pack [entry .e] 211 update 212 bind .e <Alt-z> {set ::event12result "1"} 213 focus -force .e ; event generate .e <Alt-z> 214 destroy .e 215 set ::event12result 216} 1 217 218 219 220test event-keypress-1.1 { type into entry widget and hit Return } { 221 destroy .t 222 set t [toplevel .t] 223 set e [entry $t.e] 224 pack $e 225 set return_binding 0 226 bind $e <Return> {set return_binding 1} 227 tkwait visibility $e 228 _keypress_string $e HELLO\n 229 list [$e get] $return_binding 230} {HELLO 1} 231 232 233test event-keypress-1.2 { type into entry widget and then delete some text } { 234 destroy .t 235 set t [toplevel .t] 236 set e [entry $t.e] 237 pack $e 238 tkwait visibility $e 239 _keypress_string $e MELLO 240 _keypress $e BackSpace 241 _keypress $e BackSpace 242 $e get 243} MEL 244 245test event-keypress-1.3 { type into entry widget, triple click, 246 hit Delete key, and then type some more } { 247 destroy .t 248 set t [toplevel .t] 249 set e [entry $t.e] 250 pack $e 251 tkwait visibility $e 252 _keypress_string $e JUMP 253 254 set result [$e get] 255 256 event generate $e <Enter> 257 for {set i 0} {$i < 3} {incr i} { 258 _pause 100 259 event generate $e <ButtonPress-1> 260 _pause 100 261 event generate $e <ButtonRelease-1> 262 } 263 264 _keypress $e Delete 265 _keypress_string $e UP 266 lappend result [$e get] 267} {JUMP UP} 268 269 270test event-keypress-1.4 { type into text widget and hit Return } { 271 destroy .t 272 set t [toplevel .t] 273 set e [text $t.e] 274 pack $e 275 set return_binding 0 276 bind $e <Return> {set return_binding 1} 277 tkwait visibility $e 278 _keypress_string $e HELLO\n 279 list [$e get 1.0 end] $return_binding 280} [list "HELLO\n\n" 1] 281 282test event-keypress-1.5 { type into text widget and then delete some text } { 283 destroy .t 284 set t [toplevel .t] 285 set e [text $t.e] 286 pack $e 287 tkwait visibility $e 288 _keypress_string $e MELLO 289 _keypress $e BackSpace 290 _keypress $e BackSpace 291 $e get 1.0 1.end 292} MEL 293 294test event-keypress-1.6 { type into text widget, triple click, 295 hit Delete key, and then type some more } { 296 destroy .t 297 set t [toplevel .t] 298 set e [text $t.e] 299 pack $e 300 tkwait visibility $e 301 _keypress_string $e JUMP 302 303 set result [$e get 1.0 1.end] 304 305 event generate $e <Enter> 306 for {set i 0} {$i < 3} {incr i} { 307 _pause 100 308 event generate $e <ButtonPress-1> 309 _pause 100 310 event generate $e <ButtonRelease-1> 311 } 312 313 _keypress $e Delete 314 _keypress_string $e UP 315 lappend result [$e get 1.0 1.end] 316} {JUMP UP} 317 318 319 320test event-click-drag-1.1 { click and drag in a text widget, this 321 tests tkTextSelectTo in text.tcl } { 322 destroy .t 323 set t [toplevel .t] 324 set e [text $t.e] 325 pack $e 326 tkwait visibility $e 327 _keypress_string $e "A Tcl/Tk selection test!" 328 set anchor 1.6 329 set selend 1.18 330 331 set result [list] 332 lappend result [$e get 1.0 1.end] 333 334 # Get the x,y coords of the second T in "Tcl/Tk" 335 foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break 336 337 # Click down to set the insert cursor position 338 event generate $e <Enter> 339 event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y 340 341 # Save the position of the insert cursor 342 lappend result [$e index insert] 343 344 # Now drag until selend is highlighted, then click up 345 346 set current $anchor 347 while {[$e compare $current <= $selend]} { 348 foreach {current_x current_y} [_text_ind_to_x_y $e $current] break 349 event generate $e <B1-Motion> -x $current_x -y $current_y 350 set current [$e index [list $current + 1 char]] 351 _pause 50 352 } 353 354 event generate $e <ButtonRelease-1> -x $current_x -y $current_y 355 _pause 200 356 357 # Save the position of the insert cursor 358 lappend result [$e index insert] 359 360 # Save the highlighted text 361 lappend result [_get_selection $e] 362 363 # Now click and click and drag to the left, over "Tcl/Tk selection" 364 365 event generate $e <ButtonPress-1> -x $current_x -y $current_y 366 367 while {[$e compare $current >= [list $anchor - 4 char]]} { 368 foreach {current_x current_y} [_text_ind_to_x_y $e $current] break 369 event generate $e <B1-Motion> -x $current_x -y $current_y 370 set current [$e index [list $current - 1 char]] 371 _pause 50 372 } 373 374 event generate $e <ButtonRelease-1> -x $current_x -y $current_y 375 _pause 200 376 377 # Save the position of the insert cursor 378 lappend result [$e index insert] 379 380 # Save the highlighted text 381 lappend result [_get_selection $e] 382 383} {{A Tcl/Tk selection test!} 1.6 1.18 {Tk selection} 1.2 {Tcl/Tk selection}} 384 385 386 387 388test event-click-drag-1.2 { click and drag in an entry widget, this 389 tests tkEntryMouseSelect in entry.tcl } { 390 destroy .t 391 set t [toplevel .t] 392 set e [entry $t.e] 393 pack $e 394 tkwait visibility $e 395 _keypress_string $e "A Tcl/Tk selection!" 396 set anchor 6 397 set selend 18 398 399 set result [list] 400 lappend result [$e get] 401 402 # Get the x,y coords of the second T in "Tcl/Tk" 403 foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break 404 405 # Click down to set the insert cursor position 406 event generate $e <Enter> 407 event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y 408 409 # Save the position of the insert cursor 410 lappend result [$e index insert] 411 412 # Now drag until selend is highlighted, then click up 413 414 set current $anchor 415 while {$current <= $selend} { 416 foreach {current_x current_y} [_text_ind_to_x_y $e $current] break 417 event generate $e <B1-Motion> -x $current_x -y $current_y 418 incr current 419 _pause 50 420 } 421 422 event generate $e <ButtonRelease-1> -x $current_x -y $current_y 423 _pause 200 424 425 # Save the position of the insert cursor 426 lappend result [$e index insert] 427 428 # Save the highlighted text 429 lappend result [_get_selection $e] 430 431 # Now click and click and drag to the left, over "Tcl/Tk selection" 432 433 event generate $e <ButtonPress-1> -x $current_x -y $current_y 434 435 while {$current >= ($anchor - 4)} { 436 foreach {current_x current_y} [_text_ind_to_x_y $e $current] break 437 event generate $e <B1-Motion> -x $current_x -y $current_y 438 incr current -1 439 _pause 50 440 } 441 442 event generate $e <ButtonRelease-1> -x $current_x -y $current_y 443 _pause 200 444 445 # Save the position of the insert cursor 446 lappend result [$e index insert] 447 448 # Save the highlighted text 449 lappend result [_get_selection $e] 450 451} {{A Tcl/Tk selection!} 6 18 {Tk selection} 2 {Tcl/Tk selection}} 452 453 454 455test event-double-click-drag-1.1 { click down, click up, click down again, 456 then drag in a text widget } { 457 destroy .t 458 set t [toplevel .t] 459 set e [text $t.e] 460 pack $e 461 tkwait visibility $e 462 _keypress_string $e "Word select test" 463 set anchor 1.8 464 465 # Get the x,y coords of the second e in "select" 466 foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break 467 468 # Click down, release, then click down again 469 event generate $e <Enter> 470 event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y 471 _pause 50 472 event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y 473 _pause 50 474 event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y 475 _pause 50 476 477 # Save the highlighted text 478 set result [list] 479 lappend result [_get_selection $e] 480 481 # Insert cursor should be at end of "select" 482 lappend result [$e index insert] 483 484 # Move mouse one character to the left 485 set current [$e index [list $anchor - 1 char]] 486 foreach {current_x current_y} [_text_ind_to_x_y $e $current] break 487 488 event generate $e <B1-Motion> -x $current_x -y $current_y 489 _pause 50 490 491 # Insert cursor should be before the l in "select" 492 lappend result [$e index insert] 493 494 # Selection should still be the word "select" 495 lappend result [_get_selection $e] 496 497 # Move mouse to the space before the word "select" 498 set current [$e index [list $current - 3 char]] 499 500 foreach {current_x current_y} [_text_ind_to_x_y $e $current] break 501 event generate $e <B1-Motion> -x $current_x -y $current_y 502 _pause 200 503 504 lappend result [$e index insert] 505 lappend result [_get_selection $e] 506 507 # Move mouse to the r in "Word" 508 set current 1.2 509 foreach {current_x current_y} [_text_ind_to_x_y $e $current] break 510 511 event generate $e <B1-Motion> -x $current_x -y $current_y 512 _pause 50 513 514 # Selection should now be "Word select" 515 lappend result [_get_selection $e] 516 517 # Insert cursor should be before the r in "Word" 518 lappend result [$e index insert] 519 520 set result 521} {select 1.11 1.7 select 1.4 { select} {Word select} 1.2} 522 523 524 525test event-double-click-drag-1.2 { click down, click up, click down again, 526 then drag in an entry widget } { 527 destroy .t 528 set t [toplevel .t] 529 set e [entry $t.e] 530 pack $e 531 tkwait visibility $e 532 _keypress_string $e "Word select test" 533 534 set anchor 8 535 536 # Get the x,y coords of the second e in "select" 537 foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break 538 539 # Click down, release, then click down again 540 event generate $e <Enter> 541 event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y 542 _pause 50 543 event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y 544 _pause 50 545 event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y 546 _pause 50 547 548 set result [list] 549 lappend result [_get_selection $e] 550 551 # Insert cursor should be at the end of "select" 552 lappend result [$e index insert] 553 554 # Move mouse one character to the left 555 set current [expr {$anchor - 1}] 556 foreach {current_x current_y} [_text_ind_to_x_y $e $current] break 557 558 event generate $e <B1-Motion> -x $current_x -y $current_y 559 _pause 50 560 561 # Insert cursor should be before the l in "select" 562 lappend result [$e index insert] 563 564 # Selection should still be the word "select" 565 lappend result [_get_selection $e] 566 567 # Move mouse to the space before the word "select" 568 set current [expr {$current - 3}] 569 foreach {current_x current_y} [_text_ind_to_x_y $e $current] break 570 571 event generate $e <B1-Motion> -x $current_x -y $current_y 572 _pause 50 573 574 lappend result [$e index insert] 575 lappend result [_get_selection $e] 576 577 # Move mouse to the r in "Word" 578 set current [expr {$current - 2}] 579 foreach {current_x current_y} [_text_ind_to_x_y $e $current] break 580 581 event generate $e <B1-Motion> -x $current_x -y $current_y 582 _pause 50 583 584 # Selection should now be "Word select" 585 lappend result [_get_selection $e] 586 587 # Insert cursor should be before the r in "Word" 588 lappend result [$e index insert] 589 590 set result 591} {select 11 7 select 4 { select} {Word select} 2} 592 593 594test event-triple-click-drag-1.1 { Triple click and drag across lines in 595 a text widget, this should extend the selection to the new line } { 596 destroy .t 597 set t [toplevel .t] 598 set e [text $t.e] 599 pack $e 600 tkwait visibility $e 601 _keypress_string $e "LINE ONE\nLINE TWO\nLINE THREE" 602 603 set anchor 3.2 604 605 # Triple click one third line leaving mouse down 606 607 foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break 608 609 event generate $e <Enter> 610 611 event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y 612 _pause 50 613 event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y 614 _pause 50 615 616 event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y 617 _pause 50 618 event generate $e <ButtonRelease-1> -x $anchor_x -y $anchor_y 619 _pause 50 620 621 event generate $e <ButtonPress-1> -x $anchor_x -y $anchor_y 622 _pause 50 623 624 set result [list] 625 lappend result [_get_selection $e] 626 627 # Drag up to second line 628 629 set current [$e index [list $anchor - 1 line]] 630 foreach {current_x current_y} [_text_ind_to_x_y $e $current] break 631 632 event generate $e <B1-Motion> -x $current_x -y $current_y 633 _pause 50 634 635 lappend result [_get_selection $e] 636 637 # Drag up to first line 638 639 set current [$e index [list $current - 1 line]] 640 foreach {current_x current_y} [_text_ind_to_x_y $e $current] break 641 642 event generate $e <B1-Motion> -x $current_x -y $current_y 643 _pause 50 644 645 lappend result [_get_selection $e] 646 647 set result 648 649} [list "LINE THREE\n" "LINE TWO\nLINE THREE\n" \ 650 "LINE ONE\nLINE TWO\nLINE THREE\n"] 651 652test event-button-state-1.1 { button press in a window that is then 653 destroyed, when the mouse is moved into another window it 654 should not generate a <B1-motion> event since the mouse 655 was not pressed down in that window. } { 656 destroy .t 657 set t [toplevel .t] 658 659 event generate $t <ButtonPress-1> 660 destroy $t 661 set t [toplevel .t] 662 set motion nomotion 663 bind $t <B1-Motion> {set motion inmotion} 664 event generate $t <Motion> 665 set motion 666} nomotion 667 668# cleanup 669 670destroy .t 671 672unset -nocomplain keypress_lookup 673rename _init_keypress_lookup {} 674rename _keypress_lookup {} 675rename _keypress {} 676rename _pause {} 677rename _text_ind_to_x_y {} 678rename _get_selection {} 679 680::tcltest::cleanupTests 681return 682 683