1# This file is a Tcl script to test out the "focus" command and the 2# other procedures in the file tkFocus.c. It is organized in the 3# standard fashion for Tcl tests. 4# 5# Copyright (c) 1994-1996 Sun Microsystems, Inc. 6# Copyright (c) 1998-1999 by Scriptics Corporation. 7# All rights reserved. 8# 9# RCS: @(#) $Id$ 10 11package require tcltest 2.1 12eval tcltest::configure $argv 13tcltest::loadTestedCommands 14 15button .b -text .b -relief raised -bd 2 16pack .b 17 18proc focusSetup {} { 19 catch {destroy .t} 20 toplevel .t 21 wm geom .t +0+0 22 foreach i {b1 b2 b3 b4} { 23 button .t.$i -text .t.$i -relief raised -bd 2 24 pack .t.$i 25 } 26 tkwait visibility .t.b4 27} 28proc focusSetupAlt {} { 29 global env 30 catch {destroy .alt} 31 toplevel .alt -screen $env(TK_ALT_DISPLAY) 32 foreach i {a b c d} { 33 button .alt.$i -text .alt.$i -relief raised -bd 2 34 pack .alt.$i 35 } 36 tkwait visibility .alt.d 37} 38 39# Make sure the window manager knows who has focus 40catch {fixfocus} 41 42# The following procedure ensures that there is no input focus 43# in this application. It does it by arranging for another 44# application to grab the focus. The "after" and "update" stuff 45# is needed to wait long enough for pending actions to get through 46# the X server and possibly also the window manager. 47 48setupbg 49proc focusClear {} { 50 global x; 51 after 200 {set x 1} 52 tkwait variable x 53 dobg {focus -force .; update} 54 update 55} 56 57focusSetup 58if {[testConstraint altDisplay]} { 59 focusSetupAlt 60} 61update 62 63bind all <FocusIn> { 64 append focusInfo "in %W %d\n" 65} 66bind all <FocusOut> { 67 append focusInfo "out %W %d\n" 68} 69bind all <KeyPress> { 70 append focusInfo "press %W %K" 71} 72 73test focus-1.1 {Tk_FocusCmd procedure} unix { 74 focusClear 75 focus 76} {} 77test focus-1.2 {Tk_FocusCmd procedure} {unix altDisplay} { 78 focus .alt.b 79 focus 80} {} 81test focus-1.3 {Tk_FocusCmd procedure} unix { 82 focusClear 83 focus .t.b3 84 focus 85} {} 86test focus-1.4 {Tk_FocusCmd procedure} unix { 87 list [catch {focus ""} msg] $msg 88} {0 {}} 89test focus-1.5 {Tk_FocusCmd procedure} unix { 90 focusClear 91 focus -force .t 92 focus .t.b3 93 focus 94} {.t.b3} 95test focus-1.6 {Tk_FocusCmd procedure} unix { 96 list [catch {focus .gorp} msg] $msg 97} {1 {bad window path name ".gorp"}} 98test focus-1.7 {Tk_FocusCmd procedure} unix { 99 list [catch {focus .gorp a} msg] $msg 100} {1 {bad option ".gorp": must be -displayof, -force, or -lastfor}} 101test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} unix { 102 toplevel .t2 103 wm geom .t2 +10+10 104 frame .t2.f -width 200 -height 100 -bd 2 -relief raised 105 frame .t2.f2 -width 200 -height 100 -bd 2 -relief raised 106 pack .t2.f .t2.f2 107 bind .t2.f <Destroy> {focus .t2.f} 108 bind .t2.f2 <Destroy> {focus .t2} 109 focus -force .t2.f2 110 tkwait visibility .t2.f2 111 update 112 set x [focus] 113 destroy .t2.f2 114 lappend x [focus] 115 destroy .t2.f 116 lappend x [focus] 117 destroy .t2 118 set x 119} {.t2.f2 .t2 .t2} 120test focus-1.9 {Tk_FocusCmd procedure, -displayof option} unix { 121 list [catch {focus -displayof} msg] $msg 122} {1 {wrong # args: should be "focus -displayof window"}} 123test focus-1.10 {Tk_FocusCmd procedure, -displayof option} unix { 124 list [catch {focus -displayof a b} msg] $msg 125} {1 {wrong # args: should be "focus -displayof window"}} 126test focus-1.11 {Tk_FocusCmd procedure, -displayof option} unix { 127 list [catch {focus -displayof .lousy} msg] $msg 128} {1 {bad window path name ".lousy"}} 129test focus-1.12 {Tk_FocusCmd procedure, -displayof option} unix { 130 focusClear 131 focus .t 132 focus -displayof .t.b3 133} {} 134test focus-1.13 {Tk_FocusCmd procedure, -displayof option} unix { 135 focusClear 136 focus -force .t 137 focus -displayof .t.b3 138} {.t} 139test focus-1.14 {Tk_FocusCmd procedure, -displayof option} {unix altDisplay} { 140 focus -force .alt.c 141 focus -displayof .alt 142} {.alt.c} 143test focus-1.15 {Tk_FocusCmd procedure, -force option} unix { 144 list [catch {focus -force} msg] $msg 145} {1 {wrong # args: should be "focus -force window"}} 146test focus-1.16 {Tk_FocusCmd procedure, -force option} unix { 147 list [catch {focus -force a b} msg] $msg 148} {1 {wrong # args: should be "focus -force window"}} 149test focus-1.17 {Tk_FocusCmd procedure, -force option} unix { 150 list [catch {focus -force foo} msg] $msg 151} {1 {bad window path name "foo"}} 152test focus-1.18 {Tk_FocusCmd procedure, -force option} unix { 153 list [catch {focus -force ""} msg] $msg 154} {0 {}} 155test focus-1.19 {Tk_FocusCmd procedure, -force option} unix { 156 focusClear 157 focus .t.b1 158 set x [list [focus]] 159 focus -force .t.b1 160 lappend x [focus] 161} {{} .t.b1} 162test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} unix { 163 list [catch {focus -lastfor} msg] $msg 164} {1 {wrong # args: should be "focus -lastfor window"}} 165test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} unix { 166 list [catch {focus -lastfor 1 2} msg] $msg 167} {1 {wrong # args: should be "focus -lastfor window"}} 168test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} unix { 169 list [catch {focus -lastfor who_knows?} msg] $msg 170} {1 {bad window path name "who_knows?"}} 171test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} unix { 172 focus .b 173 focus .t.b1 174 list [focus -lastfor .] [focus -lastfor .t.b3] 175} {.b .t.b1} 176test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} unix { 177 destroy .t 178 focusSetup 179 update 180 focus -lastfor .t.b2 181} {.t} 182test focus-1.25 {Tk_FocusCmd procedure} unix { 183 list [catch {focus -unknown} msg] $msg 184} {1 {bad option "-unknown": must be -displayof, -force, or -lastfor}} 185 186test focus-2.1 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} { 187 focus -force .b 188 destroy .t 189 focusSetup 190 update 191 set focusInfo {} 192 event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor \ 193 -sendevent 0x54217567 194 list $focusInfo 195} {{}} 196test focus-2.2 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} { 197 focus -force .b 198 destroy .t 199 focusSetup 200 update 201 set focusInfo {} 202 event gen .t <FocusIn> -detail NotifyAncestor -sendevent 0x547321ac 203 list $focusInfo [focus] 204} {{in .t NotifyAncestor 205} .b} 206test focus-2.3 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} { 207 focus -force .b 208 destroy .t 209 focusSetup 210 update 211 set focusInfo {} 212 event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor 213 update 214 list $focusInfo [focus -lastfor .t] 215} {{out .b NotifyNonlinear 216out . NotifyNonlinearVirtual 217in .t NotifyNonlinear 218} .t} 219test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} \ 220 {unix nonPortable testwrapper} { 221 set result {} 222 focus .t.b1 223 # Important to end with NotifyAncestor, which is an 224 # event that is processed normally. This has a side 225 # effect on text 2.5 226 foreach detail {NotifyAncestor NotifyNonlinear 227 NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot 228 NotifyVirtual NotifyAncestor} { 229 focus -force . 230 update 231 event gen [testwrapper .t] <FocusIn> -detail $detail 232 set focusInfo {} 233 update 234 lappend result $focusInfo 235 } 236 set result 237} {{out . NotifyNonlinear 238in .t NotifyNonlinearVirtual 239in .t.b1 NotifyNonlinear 240} {out . NotifyNonlinear 241in .t NotifyNonlinearVirtual 242in .t.b1 NotifyNonlinear 243} {} {out . NotifyNonlinear 244in .t NotifyNonlinearVirtual 245in .t.b1 NotifyNonlinear 246} {} {} {out . NotifyNonlinear 247in .t NotifyNonlinearVirtual 248in .t.b1 NotifyNonlinear 249}} 250test focus-2.5 {TkFocusFilterEvent procedure, creating FocusInfo struct} \ 251 {unix nonPortable testwrapper} { 252 focusSetup 253 focus .t.b1 254 update 255 event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor 256 list $focusInfo [focus] 257} {{out . NotifyNonlinear 258in .t NotifyNonlinearVirtual 259in .t.b1 NotifyNonlinear 260} .t.b1} 261test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} \ 262 {unix testwrapper} { 263 focus .t.b1 264 focus . 265 update 266 event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor 267 set focusInfo {} 268 set x [focus] 269 event gen . <KeyPress-x> 270 list $x $focusInfo 271} {.t.b1 {press .t.b1 x}} 272test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} \ 273 {unix testwrapper} { 274 set result {} 275 foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear 276 NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot 277 NotifyVirtual} { 278 focus -force .t.b1 279 event gen [testwrapper .t] <FocusOut> -detail $detail 280 update 281 lappend result [focus] 282 } 283 set result 284} {{} .t.b1 {} {} .t.b1 .t.b1 {}} 285test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} \ 286 {unix testwrapper} { 287 focus -force .t.b1 288 event gen .t.b1 <FocusOut> -detail NotifyAncestor 289 focus 290} {.t.b1} 291test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} \ 292 {unix testwrapper} { 293 focus .t.b1 294 event gen [testwrapper .] <FocusOut> -detail NotifyAncestor 295 focus 296} {} 297test focus-2.10 {TkFocusFilterEvent procedure, Enter events} \ 298 {unix testwrapper} { 299 set result {} 300 focus .t.b1 301 focusClear 302 foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear 303 NotifyNonlinearVirtual NotifyVirtual} { 304 event gen [testwrapper .t] <Enter> -detail $detail -focus 1 305 update 306 lappend result [focus] 307 event gen [testwrapper .t] <Leave> -detail NotifyAncestor 308 update 309 } 310 set result 311} {.t.b1 {} .t.b1 .t.b1 .t.b1} 312test focus-2.11 {TkFocusFilterEvent procedure, Enter events} \ 313 {unix testwrapper} { 314 focusClear 315 set focusInfo {} 316 event gen [testwrapper .t] <Enter> -detail NotifyAncestor 317 update 318 set focusInfo 319} {} 320test focus-2.12 {TkFocusFilterEvent procedure, Enter events} \ 321 {unix testwrapper} { 322 focus -force .b 323 update 324 set focusInfo {} 325 event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 326 update 327 set focusInfo 328} {} 329test focus-2.13 {TkFocusFilterEvent procedure, Enter events} \ 330 {unix testwrapper} { 331 focus .t.b1 332 focusClear 333 event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 334 set focusInfo {} 335 update 336 set focusInfo 337} {in .t NotifyVirtual 338in .t.b1 NotifyAncestor 339} 340test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} {unix testwrapper} { 341 focusClear 342 catch {destroy .t2} 343 toplevel .t2 344 wm withdraw .t2 345 update 346 set focusInfo {} 347 event gen [testwrapper .t2] <Enter> -detail NotifyAncestor -focus 1 348 update 349 destroy .t2 350} {} 351test focus-2.15 {TkFocusFilterEvent procedure, Leave events} \ 352 {unix testwrapper} { 353 set result {} 354 focus .t.b1 355 foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear 356 NotifyNonlinearVirtual NotifyVirtual} { 357 focusClear 358 event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 359 update 360 event gen [testwrapper .t] <Leave> -detail $detail 361 update 362 lappend result [focus] 363 } 364 set result 365} {{} .t.b1 {} {} {}} 366test focus-2.16 {TkFocusFilterEvent procedure, Leave events} \ 367 {unix testwrapper} { 368 set result {} 369 focus .t.b1 370 event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 371 update 372 set focusInfo {} 373 event gen [testwrapper .t] <Leave> -detail NotifyAncestor 374 update 375 set focusInfo 376} {out .t.b1 NotifyAncestor 377out .t NotifyVirtual 378} 379test focus-2.17 {TkFocusFilterEvent procedure, Leave events} \ 380 {unix testwrapper} { 381 set result {} 382 focus .t.b1 383 event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 384 update 385 set focusInfo {} 386 event gen .t.b1 <Leave> -detail NotifyAncestor 387 event gen [testwrapper .] <Leave> -detail NotifyAncestor 388 update 389 list $focusInfo [focus] 390} {{out .t.b1 NotifyAncestor 391out .t NotifyVirtual 392} {}} 393 394test focus-3.1 {SetFocus procedure, create record on focus} \ 395 {unix testwrapper} { 396 toplevel .t2 -width 250 -height 100 397 wm geometry .t2 +0+0 398 update 399 focus -force .t2 400 update 401 focus 402} {.t2} 403catch {destroy .t2} 404# This test produces no result, but it will generate a protocol 405# error if Tk forgets to make the window exist before focussing 406# on it. 407test focus-3.2 {SetFocus procedure, making window exist} {unix testwrapper} { 408 update 409 button .b2 -text "Another button" 410 focus .b2 411 update 412} {} 413catch {destroy .b2} 414update 415# The following test doesn't produce a check-able result, but if 416# there are bugs it may generate an X protocol error. 417test focus-3.3 {SetFocus procedure, delaying claim of X focus} \ 418 {unix testwrapper} { 419 focusSetup 420 focus -force .t.b2 421 update 422} {} 423test focus-3.4 {SetFocus procedure, delaying claim of X focus} \ 424 {unix testwrapper} { 425 focusSetup 426 wm withdraw .t 427 focus -force .t.b2 428 toplevel .t2 -width 250 -height 100 429 wm geometry .t2 +10+10 430 focus -force .t2 431 wm withdraw .t2 432 update 433 wm deiconify .t2 434 wm deiconify .t 435} {} 436catch {destroy .t2} 437test focus-3.5 {SetFocus procedure, generating events} {unix testwrapper} { 438 focusSetup 439 focusClear 440 set focusInfo {} 441 focus -force .t.b2 442 update 443 set focusInfo 444} {in .t NotifyVirtual 445in .t.b2 NotifyAncestor 446} 447test focus-3.6 {SetFocus procedure, generating events} {unix testwrapper} { 448 focusSetup 449 focus -force .b 450 update 451 set focusInfo {} 452 focus .t.b2 453 update 454 set focusInfo 455} {out .b NotifyNonlinear 456out . NotifyNonlinearVirtual 457in .t NotifyNonlinearVirtual 458in .t.b2 NotifyNonlinear 459} 460test focus-3.7 {SetFocus procedure, generating events} \ 461 {unix nonPortable testwrapper} { 462 # Non-portable because some platforms generate extra events. 463 464 focusSetup 465 focusClear 466 set focusInfo {} 467 focus .t.b2 468 update 469 set focusInfo 470} {} 471 472test focus-4.1 {TkFocusDeadWindow procedure} {unix testwrapper} { 473 focusSetup 474 update 475 focus -force .b 476 update 477 destroy .t 478 focus 479} {.b} 480test focus-4.2 {TkFocusDeadWindow procedure} {unix testwrapper} { 481 focusSetup 482 update 483 focus -force .t.b2 484 focus .b 485 update 486 destroy .t.b2 487 update 488 focus 489} {.b} 490 491# Non-portable due to wm-specific redirection of input focus when 492# windows are deleted: 493 494test focus-4.3 {TkFocusDeadWindow procedure} {unix nonPortable testwrapper} { 495 focusSetup 496 update 497 focus .t 498 update 499 destroy .t 500 update 501 focus 502} {} 503test focus-4.4 {TkFocusDeadWindow procedure} {unix testwrapper} { 504 focusSetup 505 focus -force .t.b2 506 update 507 destroy .t.b2 508 focus 509} {.t} 510 511# I don't know how to test most of the remaining procedures of this file 512# explicitly; they've already been exercised by the preceding tests. 513 514setupbg 515test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} \ 516 {unix testwrapper secureserver} { 517 focusSetup 518 focus -force .t 519 update 520 set result [focus] 521 send [dobg {tk appname}] {focus -force .; update} 522 lappend result [focus] 523 focus .t.b2 524 update 525 lappend result [focus] 526} {.t {} {}} 527 528catch {destroy .t} 529bind all <FocusIn> {} 530bind all <FocusOut> {} 531bind all <KeyPress> {} 532cleanupbg 533fixfocus 534 535test focus-6.1 {miscellaneous - embedded application in same process} \ 536 {unix testwrapper} { 537 eval interp delete [interp slaves] 538 catch {destroy .t} 539 toplevel .t 540 wm geometry .t +0+0 541 frame .t.f1 -container 1 542 frame .t.f2 543 pack .t.f1 .t.f2 544 entry .t.f2.e1 -bg red 545 pack .t.f2.e1 546 bind all <FocusIn> {lappend x "focus in %W %d"} 547 bind all <FocusOut> {lappend x "focus out %W %d"} 548 interp create child 549 child eval "set argv {-use [winfo id .t.f1]}" 550 load {} Tk child 551 child eval { 552 entry .e1 -bg lightBlue 553 pack .e1 554 bind all <FocusIn> {lappend x "focus in %W %d"} 555 bind all <FocusOut> {lappend x "focus out %W %d"} 556 set x {} 557 } 558 559 # Claim the focus and wait long enough for it to really arrive. 560 561 focus -force .t.f2.e1 562 after 300 {set timer 1} 563 vwait timer 564 set x {} 565 lappend x [focus] [child eval focus] 566 567 # See if a "focus" command will move the focus to the embedded 568 # application. 569 570 child eval {focus .e1} 571 after 300 {set timer 1} 572 vwait timer 573 lappend x | 574 child eval {lappend x |} 575 576 # Bring the focus back to the main application. 577 578 focus .t.f2.e1 579 after 300 {set timer 1} 580 vwait timer 581 set result [list $x [child eval {set x}]] 582 interp delete child 583 set result 584} {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} 585test focus-6.2 {miscellaneous - embedded application in different process} \ 586 {unix testwrapper} { 587 eval interp delete [interp slaves] 588 catch {destroy .t} 589 setupbg 590 toplevel .t 591 wm geometry .t +0+0 592 frame .t.f1 -container 1 593 frame .t.f2 594 pack .t.f1 .t.f2 595 entry .t.f2.e1 -bg red 596 pack .t.f2.e1 597 bind all <FocusIn> {lappend x "focus in %W %d"} 598 bind all <FocusOut> {lappend x "focus out %W %d"} 599 setupbg -use [winfo id .t.f1] 600 dobg { 601 entry .e1 -bg lightBlue 602 pack .e1 603 bind all <FocusIn> {lappend x "focus in %W %d"} 604 bind all <FocusOut> {lappend x "focus out %W %d"} 605 set x {} 606 } 607 608 # Claim the focus and wait long enough for it to really arrive. 609 610 focus -force .t.f2.e1 611 after 300 {set timer 1} 612 vwait timer 613 set x {} 614 lappend x [focus] [dobg focus] 615 616 # See if a "focus" command will move the focus to the embedded 617 # application. 618 619 dobg {focus .e1} 620 after 300 {set timer 1} 621 vwait timer 622 lappend x | 623 dobg {lappend x |} 624 625 # Bring the focus back to the main application. 626 627 focus .t.f2.e1 628 after 300 {set timer 1} 629 vwait timer 630 set result [list $x [dobg {set x}]] 631 cleanupbg 632 set result 633} {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} 634 635deleteWindows 636bind all <FocusIn> {} 637bind all <FocusOut> {} 638 639# cleanup 640cleanupTests 641return 642