Import Tk 8.6.6 (as of svn r86089)
This commit is contained in:
Zachary Ware
739
tests/focus.test
Normal file
739
tests/focus.test
Normal file
@@ -0,0 +1,739 @@
|
||||
# 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 <FocusIn> {
|
||||
append focusInfo "in %W %d\n"
|
||||
}
|
||||
bind all <FocusOut> {
|
||||
append focusInfo "out %W %d\n"
|
||||
}
|
||||
bind all <KeyPress> {
|
||||
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 <Destroy> {focus .t2.f}
|
||||
bind .t2.f2 <Destroy> {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] <FocusIn> -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 <FocusIn> -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] <FocusIn> -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] <FocusIn> -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] <FocusIn> -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] <FocusIn> -detail NotifyAncestor
|
||||
set focusInfo {}
|
||||
set x [focus]
|
||||
event gen . <KeyPress-x>
|
||||
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] <FocusOut> -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 <FocusOut> -detail NotifyAncestor
|
||||
focus
|
||||
} -result {.t.b1}
|
||||
test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} -constraints {
|
||||
unix testwrapper
|
||||
} -body {
|
||||
focus .t.b1
|
||||
event gen [testwrapper .] <FocusOut> -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] <Enter> -detail $detail -focus 1
|
||||
update
|
||||
lappend result [focus]
|
||||
event gen [testwrapper .t] <Leave> -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] <Enter> -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] <Enter> -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] <Enter> -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] <Enter> -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] <Enter> -detail NotifyAncestor -focus 1
|
||||
update
|
||||
event gen [testwrapper .t] <Leave> -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] <Enter> -detail NotifyAncestor -focus 1
|
||||
update
|
||||
set focusInfo {}
|
||||
event gen [testwrapper .t] <Leave> -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] <Enter> -detail NotifyAncestor -focus 1
|
||||
update
|
||||
set focusInfo {}
|
||||
event gen .t.b1 <Leave> -detail NotifyAncestor
|
||||
event gen [testwrapper .] <Leave> -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 <FocusIn> {}
|
||||
bind all <FocusOut> {}
|
||||
bind all <KeyPress> {}
|
||||
|
||||
|
||||
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 <FocusIn> {lappend x "focus in %W %d"}
|
||||
bind all <FocusOut> {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 <FocusIn> {lappend x "focus in %W %d"}
|
||||
bind all <FocusOut> {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 <FocusIn> {}
|
||||
bind all <FocusOut> {}
|
||||
} -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 <FocusIn> {lappend x "focus in %W %d"}
|
||||
bind all <FocusOut> {lappend x "focus out %W %d"}
|
||||
setupbg -use [winfo id .t.f1]
|
||||
dobg {
|
||||
entry .e1 -bg lightBlue
|
||||
pack .e1
|
||||
bind all <FocusIn> {lappend x "focus in %W %d"}
|
||||
bind all <FocusOut> {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 <FocusIn> {}
|
||||
bind all <FocusOut> {}
|
||||
} -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
|
||||
Reference in New Issue
Block a user