# This file is a Tcl script to test out the "focus" command and the # other procedures in the file tkFocus.c. It is organized in the # standard fashion for Tcl tests. # # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test proc focusSetup {} { destroy .t toplevel .t wm geom .t +0+0 foreach i {b1 b2 b3 b4} { button .t.$i -text .t.$i -relief raised -bd 2 pack .t.$i } tkwait visibility .t.b4 } proc focusSetupAlt {} { global env destroy .alt toplevel .alt -screen $env(TK_ALT_DISPLAY) foreach i {a b c d} { button .alt.$i -text .alt.$i -relief raised -bd 2 pack .alt.$i } tkwait visibility .alt.d } # The following procedure ensures that there is no input focus # in this application. It does it by arranging for another # application to grab the focus. The "after" and "update" stuff # is needed to wait long enough for pending actions to get through # the X server and possibly also the window manager. proc focusClear {} { global x; after 200 {set x 1} tkwait variable x dobg {focus -force .; update} update } # Button used in some tests in the whole test file button .b -text .b -relief raised -bd 2 pack .b # Make sure the window manager knows who has focus catch {fixfocus} # cleanupbg will be after 4.3 test setupbg update bind all { append focusInfo "in %W %d\n" } bind all { append focusInfo "out %W %d\n" } bind all { append focusInfo "press %W %K" } focusSetup if {[testConstraint altDisplay]} { focusSetupAlt } test focus-1.1 {Tk_FocusCmd procedure} -constraints unix -body { focusClear focus } -result {} test focus-1.2 {Tk_FocusCmd procedure} -constraints { unix altDisplay } -body { focus .alt.b focus } -result {} test focus-1.3 {Tk_FocusCmd procedure} -constraints unix -body { focusClear focus .t.b3 focus } -result {} test focus-1.4 {Tk_FocusCmd procedure} -constraints unix -body { focus "" } -returnCodes ok -result {} test focus-1.5 {Tk_FocusCmd procedure} -constraints unix -body { focusClear focus -force .t focus .t.b3 focus } -result {.t.b3} test focus-1.6 {Tk_FocusCmd procedure} -constraints unix -body { focus .gorp } -returnCodes error -result {bad window path name ".gorp"} test focus-1.7 {Tk_FocusCmd procedure} -constraints unix -body { focus .gorp a } -returnCodes error -result {bad option ".gorp": must be -displayof, -force, or -lastfor} test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} -constraints { unix } -setup { destroy .t2 } -body { focusClear toplevel .t2 wm geom .t2 +10+10 frame .t2.f -width 200 -height 100 -bd 2 -relief raised frame .t2.f2 -width 200 -height 100 -bd 2 -relief raised pack .t2.f .t2.f2 bind .t2.f {focus .t2.f} bind .t2.f2 {focus .t2} focus -force .t2.f2 tkwait visibility .t2.f2 update set x [focus] destroy .t2.f2 lappend x [focus] destroy .t2.f lappend x [focus] destroy .t2 return $x } -cleanup { destroy .t2 } -result {.t2.f2 .t2 .t2} test focus-1.9 {Tk_FocusCmd procedure, -displayof option} -constraints { unix } -body { focus -displayof } -returnCodes error -result {wrong # args: should be "focus -displayof window"} test focus-1.10 {Tk_FocusCmd procedure, -displayof option} -constraints { unix } -body { focus -displayof a b } -returnCodes error -result {wrong # args: should be "focus -displayof window"} test focus-1.11 {Tk_FocusCmd procedure, -displayof option} -constraints { unix } -body { focus -displayof .lousy } -returnCodes error -result {bad window path name ".lousy"} test focus-1.12 {Tk_FocusCmd procedure, -displayof option} -constraints { unix } -body { focusClear focus .t focus -displayof .t.b3 } -result {} test focus-1.13 {Tk_FocusCmd procedure, -displayof option} -constraints { unix } -body { focusClear focus -force .t focus -displayof .t.b3 } -result {.t} test focus-1.14 {Tk_FocusCmd procedure, -displayof option} -constraints { unix altDisplay } -body { focusClear focus -force .alt.c focus -displayof .alt } -result {.alt.c} test focus-1.15 {Tk_FocusCmd procedure, -force option} -constraints unix -body { focus -force } -returnCodes error -result {wrong # args: should be "focus -force window"} test focus-1.16 {Tk_FocusCmd procedure, -force option} -constraints unix -body { focus -force a b } -returnCodes error -result {wrong # args: should be "focus -force window"} test focus-1.17 {Tk_FocusCmd procedure, -force option} -constraints unix -body { focus -force foo } -returnCodes error -result {bad window path name "foo"} test focus-1.18 {Tk_FocusCmd procedure, -force option} -constraints unix -body { focus -force "" } -returnCodes ok -result {} test focus-1.19 {Tk_FocusCmd procedure, -force option} -constraints unix -body { focusClear focus .t.b1 set x [list [focus]] focus -force .t.b1 lappend x [focus] } -result {{} .t.b1} test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} -constraints { unix } -body { focus -lastfor } -returnCodes error -result {wrong # args: should be "focus -lastfor window"} test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} -constraints { unix } -body { focus -lastfor 1 2 } -returnCodes error -result {wrong # args: should be "focus -lastfor window"} test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} -constraints { unix } -body { focus -lastfor who_knows? } -returnCodes error -result {bad window path name "who_knows?"} test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} -constraints { unix } -body { focusClear focusSetup focus .b focus .t.b1 list [focus -lastfor .] [focus -lastfor .t.b3] } -result {.b .t.b1} test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} -constraints { unix } -body { focusClear focusSetup update focus -lastfor .t.b2 } -result {.t} test focus-1.25 {Tk_FocusCmd procedure} -constraints unix -body { focus -unknown } -returnCodes error -result {bad option "-unknown": must be -displayof, -force, or -lastfor} focusSetup test focus-2.1 {TkFocusFilterEvent procedure} -constraints { unix nonPortable testwrapper } -body { focusClear focus -force .b focusSetup update set focusInfo {} event gen [testwrapper .t] -detail NotifyAncestor \ -sendevent 0x54217567 return $focusInfo } -result {} test focus-2.2 {TkFocusFilterEvent procedure} -constraints { unix nonPortable testwrapper } -body { focusClear focus -force .b focusSetup update set focusInfo {} event gen .t -detail NotifyAncestor -sendevent 0x547321ac list $focusInfo [focus] } -result {{in .t NotifyAncestor } .b} test focus-2.3 {TkFocusFilterEvent procedure} -constraints { unix nonPortable testwrapper } -body { focusClear focus -force .b focusSetup update set focusInfo {} event gen [testwrapper .t] -detail NotifyAncestor update list $focusInfo [focus -lastfor .t] } -result {{out .b NotifyNonlinear out . NotifyNonlinearVirtual in .t NotifyNonlinear } .t} test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} -constraints { unix nonPortable testwrapper } -body { focusClear set result {} focus .t.b1 # Important to end with NotifyAncestor, which is an # event that is processed normally. This has a side # effect on text 2.5 foreach detail {NotifyAncestor NotifyNonlinear NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot NotifyVirtual NotifyAncestor} { focus -force . update event gen [testwrapper .t] -detail $detail set focusInfo {} update lappend result $focusInfo } return $result } -result {{out . NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear } {out . NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear } {} {out . NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear } {} {} {out . NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear }} test focus-2.5 {TkFocusFilterEvent procedure, creating FocusInfo struct} -constraints { unix nonPortable testwrapper } -body { focusSetup focus .t.b1 update event gen [testwrapper .t] -detail NotifyAncestor list $focusInfo [focus] } -result {{out . NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear } .t.b1} test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} -constraints { unix testwrapper } -body { focus .t.b1 focus . update event gen [testwrapper .t] -detail NotifyAncestor set focusInfo {} set x [focus] event gen . list $x $focusInfo } -result {.t.b1 {press .t.b1 x}} test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} -constraints { unix testwrapper } -body { set result {} foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot NotifyVirtual} { focus -force .t.b1 event gen [testwrapper .t] -detail $detail update lappend result [focus] } return $result } -result {{} .t.b1 {} {} .t.b1 .t.b1 {}} test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} -constraints { unix testwrapper } -body { focus -force .t.b1 event gen .t.b1 -detail NotifyAncestor focus } -result {.t.b1} test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} -constraints { unix testwrapper } -body { focus .t.b1 event gen [testwrapper .] -detail NotifyAncestor focus } -result {} test focus-2.10 {TkFocusFilterEvent procedure, Enter events} -constraints { unix testwrapper } -body { set result {} focus .t.b1 focusClear foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear NotifyNonlinearVirtual NotifyVirtual} { event gen [testwrapper .t] -detail $detail -focus 1 update lappend result [focus] event gen [testwrapper .t] -detail NotifyAncestor update } return $result } -result {.t.b1 {} .t.b1 .t.b1 .t.b1} test focus-2.11 {TkFocusFilterEvent procedure, Enter events} -constraints { unix testwrapper } -body { focusClear set focusInfo {} event gen [testwrapper .t] -detail NotifyAncestor update return $focusInfo } -result {} test focus-2.12 {TkFocusFilterEvent procedure, Enter events} -constraints { unix testwrapper } -body { focus -force .b update set focusInfo {} event gen [testwrapper .t] -detail NotifyAncestor -focus 1 update return $focusInfo } -result {} test focus-2.13 {TkFocusFilterEvent procedure, Enter events} -constraints { unix testwrapper } -body { focus .t.b1 focusClear event gen [testwrapper .t] -detail NotifyAncestor -focus 1 set focusInfo {} update return $focusInfo } -result {in .t NotifyVirtual in .t.b1 NotifyAncestor } test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} -constraints { unix testwrapper } -setup { destroy .t2 set focusInfo {} } -body { focusClear toplevel .t2 wm withdraw .t2 update event gen [testwrapper .t2] -detail NotifyAncestor -focus 1 update } -cleanup { destroy .t2 } -result {} test focus-2.15 {TkFocusFilterEvent procedure, Leave events} -constraints { unix testwrapper } -body { set result {} focus .t.b1 foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear NotifyNonlinearVirtual NotifyVirtual} { focusClear event gen [testwrapper .t] -detail NotifyAncestor -focus 1 update event gen [testwrapper .t] -detail $detail update lappend result [focus] } return $result } -result {{} .t.b1 {} {} {}} test focus-2.16 {TkFocusFilterEvent procedure, Leave events} -constraints { unix testwrapper } -body { focusClear focus .t.b1 event gen [testwrapper .t] -detail NotifyAncestor -focus 1 update set focusInfo {} event gen [testwrapper .t] -detail NotifyAncestor update return $focusInfo } -result {out .t.b1 NotifyAncestor out .t NotifyVirtual } test focus-2.17 {TkFocusFilterEvent procedure, Leave events} -constraints { unix testwrapper } -body { focusClear focus .t.b1 event gen [testwrapper .t] -detail NotifyAncestor -focus 1 update set focusInfo {} event gen .t.b1 -detail NotifyAncestor event gen [testwrapper .] -detail NotifyAncestor update list $focusInfo [focus] } -result {{out .t.b1 NotifyAncestor out .t NotifyVirtual } {}} test focus-3.1 {SetFocus procedure, create record on focus} -constraints { unix testwrapper } -body { toplevel .t2 -width 250 -height 100 wm geometry .t2 +0+0 update focus -force .t2 update focus } -cleanup { destroy .t2 } -result {.t2} # This test produces no result, but it will generate a protocol # error if Tk forgets to make the window exist before focussing # on it. test focus-3.2 {SetFocus procedure, making window exist} -constraints { unix testwrapper } -body { update button .b2 -text "Another button" focus .b2 update } -cleanup { destroy .b2 update } -result {} # The following test doesn't produce a check-able result, but if # there are bugs it may generate an X protocol error. test focus-3.3 {SetFocus procedure, delaying claim of X focus} -constraints { unix testwrapper } -body { focusSetup focus -force .t.b2 update } -result {} test focus-3.4 {SetFocus procedure, delaying claim of X focus} -constraints { unix testwrapper } -body { focusSetup wm withdraw .t focus -force .t.b2 toplevel .t2 -width 250 -height 100 wm geometry .t2 +10+10 focus -force .t2 wm withdraw .t2 update wm deiconify .t2 wm deiconify .t } -cleanup { destroy .t2 } -result {} test focus-3.5 {SetFocus procedure, generating events} -constraints { unix testwrapper } -body { focusSetup focusClear set focusInfo {} focus -force .t.b2 update return $focusInfo } -result {in .t NotifyVirtual in .t.b2 NotifyAncestor } test focus-3.6 {SetFocus procedure, generating events} -constraints { unix testwrapper } -body { focusSetup focus -force .b update set focusInfo {} focus .t.b2 update return $focusInfo } -result {out .b NotifyNonlinear out . NotifyNonlinearVirtual in .t NotifyNonlinearVirtual in .t.b2 NotifyNonlinear } test focus-3.7 {SetFocus procedure, generating events} -constraints { unix nonPortable testwrapper } -body { # Non-portable because some platforms generate extra events. focusSetup focusClear set focusInfo {} focus .t.b2 update return $focusInfo } -result {} test focus-4.1 {TkFocusDeadWindow procedure} -constraints { unix testwrapper } -body { focusSetup update focus -force .b update destroy .t focus } -result {.b} test focus-4.2 {TkFocusDeadWindow procedure} -constraints { unix testwrapper } -body { focusSetup update focus -force .t.b2 focus .b update destroy .t.b2 update focus } -result {.b} # Non-portable due to wm-specific redirection of input focus when # windows are deleted: test focus-4.3 {TkFocusDeadWindow procedure} -constraints { unix nonPortable testwrapper } -body { focusSetup update focus .t update destroy .t update focus } -result {} test focus-4.4 {TkFocusDeadWindow procedure} -constraints { unix testwrapper } -body { focusSetup focus -force .t.b2 update destroy .t.b2 focus } -result {.t} cleanupbg # I don't know how to test most of the remaining procedures of this file # explicitly; they've already been exercised by the preceding tests. # Test 5.1 fails (before and after update) test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} -constraints { unix testwrapper secureserver } -body { setupbg focusSetup focus -force .t update set result [focus] send [dobg {tk appname}] {focus -force .; update} lappend result [focus] focus .t.b2 update lappend result [focus] } -cleanup { cleanupbg } -result {.t {} {}} destroy .t bind all {} bind all {} bind all {} fixfocus test focus-6.1 {miscellaneous - embedded application in same process} -constraints { unix testwrapper } -setup { eval interp delete [interp slaves] } -body { toplevel .t wm geometry .t +0+0 frame .t.f1 -container 1 frame .t.f2 pack .t.f1 .t.f2 entry .t.f2.e1 -bg red pack .t.f2.e1 bind all {lappend x "focus in %W %d"} bind all {lappend x "focus out %W %d"} interp create child child eval "set argv {-use [winfo id .t.f1]}" load {} Tk child child eval { entry .e1 -bg lightBlue pack .e1 bind all {lappend x "focus in %W %d"} bind all {lappend x "focus out %W %d"} set x {} } # Claim the focus and wait long enough for it to really arrive. focus -force .t.f2.e1 after 300 {set timer 1} vwait timer set x {} lappend x [focus] [child eval focus] # See if a "focus" command will move the focus to the embedded # application. child eval {focus .e1} after 300 {set timer 1} vwait timer lappend x | child eval {lappend x |} # Bring the focus back to the main application. focus .t.f2.e1 after 300 {set timer 1} vwait timer set result [list $x [child eval {set x}]] return $result } -cleanup { interp delete child destroy .t bind all {} bind all {} } -result {{.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}}} test focus-6.2 {miscellaneous - embedded application in different process} -constraints { unix testwrapper } -body { setupbg toplevel .t wm geometry .t +0+0 frame .t.f1 -container 1 frame .t.f2 pack .t.f1 .t.f2 entry .t.f2.e1 -bg red pack .t.f2.e1 bind all {lappend x "focus in %W %d"} bind all {lappend x "focus out %W %d"} setupbg -use [winfo id .t.f1] dobg { entry .e1 -bg lightBlue pack .e1 bind all {lappend x "focus in %W %d"} bind all {lappend x "focus out %W %d"} set x {} } # Claim the focus and wait long enough for it to really arrive. focus -force .t.f2.e1 after 300 {set timer 1} vwait timer set x {} lappend x [focus] [dobg focus] # See if a "focus" command will move the focus to the embedded # application. dobg {focus .e1} after 300 {set timer 1} vwait timer lappend x | dobg {lappend x |} # Bring the focus back to the main application. focus .t.f2.e1 after 300 {set timer 1} vwait timer set result [list $x [dobg {set x}]] return $result } -cleanup { destroy .t cleanupbg bind all {} bind all {} } -result {{.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}}} deleteWindows # cleanup cleanupTests return