path: root/tests/focus.test

# 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 © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 by Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test

testConstraint failsOnUbuntu [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match linux $::env(TRAVIS_OS_NAME)]}]
testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }]

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 <Key> {
    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 failsOnUbuntu failsOnXQuarz
} -body {
    focus .t.b1
    focus .
    update
    event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor
    set focusInfo {}
    set x [focus]
    event gen . <x>
    list $x $focusInfo
} -result {.t.b1 {press .t.b1 x}}
test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} -constraints {
    unix  testwrapper failsOnUbuntu failsOnXQuarz
} -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 failsOnUbuntu failsOnXQuarz
} -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 failsOnUbuntu failsOnXQuarz
} -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 <Key> {}


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}}}

test focus-7.1 {TkSetFocusWin procedure, unmapped windows} -setup {
    # TkSetFocusWin handles the case of not yet mapped windows
    # by not setting the focus on them right at the time it is
    # requested, but by scheduling an event handler that will
    # set the focus later once it gets mapped. The purpose of
    # this test is to check that event scheduling and deletion
    # work as expected (bug [08e2f8e6f0]).
    toplevel .top
    spinbox .top.s1
    spinbox .top.s2
    spinbox .top.s3
    grid .top.s1 .top.s2 .top.s3
} -body {
    focus -force .top.s2
    focus -force .top.s3
    update
    focus
} -cleanup {
    destroy .top
} -result {.top.s3}


deleteWindows

# cleanup
cleanupTests
return