Initial revision

1 files changed, 630 insertions, 0 deletions

diff --git a/tests/focus.test b/tests/focus.test
new file mode 100644
index 0000000..4aa4da3
--- /dev/null
+++ b/tests/focus.test
@@ -0,0 +1,630 @@
+# 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.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# SCCS: @(#) focus.test 1.24 97/08/11 09:39:34
+
+if {$tcl_platform(platform) != "unix"} {
+    return
+}
+
+if {[info procs test] != "test"} {
+    source defs
+}
+
+eval destroy [winfo children .]
+wm geometry . {}
+raise .
+
+button .b -text .b -relief raised -bd 2
+pack .b
+
+proc focusSetup {} {
+    catch {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
+    catch {destroy .alt}
+    toplevel .alt -screen $env(TK_ALT_DISPLAY)
+    wm withdraw .alt
+    foreach i {a b c d} {
+	button .alt.$i -text .alt.$i -relief raised -bd 2
+	pack .alt.$i
+    }
+    tkwait visibility .alt.d
+}
+
+# Make sure the window manager knows who has focus
+fixfocus
+
+# 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.
+
+setupbg
+proc focusClear {} {
+    global x;
+    after 200 {set x 1}
+    tkwait variable x
+    dobg {focus -force .; update}
+    update
+}
+
+focusSetup
+set altDisplay [info exists env(TK_ALT_DISPLAY)]
+if $altDisplay {
+    focusSetupAlt
+}
+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"
+}
+
+test focus-1.1 {Tk_FocusCmd procedure} {
+    focusClear
+    focus
+} {}
+if $altDisplay {
+    test focus-1.2 {Tk_FocusCmd procedure} {
+	focus .alt.b
+	focus
+    } {}
+}
+test focus-1.3 {Tk_FocusCmd procedure} {
+    focusClear
+    focus .t.b3
+    focus
+} {}
+test focus-1.4 {Tk_FocusCmd procedure} {
+    list [catch {focus ""} msg] $msg
+} {0 {}}
+test focus-1.5 {Tk_FocusCmd procedure} {
+    focusClear
+    focus -force .t
+    focus .t.b3
+    focus
+} {.t.b3}
+test focus-1.6 {Tk_FocusCmd procedure} {
+    list [catch {focus .gorp} msg] $msg
+} {1 {bad window path name ".gorp"}}
+test focus-1.7 {Tk_FocusCmd procedure} {
+    list [catch {focus .gorp a} msg] $msg
+} {1 {bad option ".gorp": must be -displayof, -force, or -lastfor}}
+test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} {
+    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
+    set x
+} {.t2.f2 .t2 .t2}
+test focus-1.9 {Tk_FocusCmd procedure, -displayof option} {
+    list [catch {focus -displayof} msg] $msg
+} {1 {wrong # args: should be "focus -displayof window"}}
+test focus-1.10 {Tk_FocusCmd procedure, -displayof option} {
+    list [catch {focus -displayof a b} msg] $msg
+} {1 {wrong # args: should be "focus -displayof window"}}
+test focus-1.11 {Tk_FocusCmd procedure, -displayof option} {
+    list [catch {focus -displayof .lousy} msg] $msg
+} {1 {bad window path name ".lousy"}}
+test focus-1.12 {Tk_FocusCmd procedure, -displayof option} {
+    focusClear
+    focus .t
+    focus -displayof .t.b3
+} {}
+test focus-1.13 {Tk_FocusCmd procedure, -displayof option} {
+    focusClear
+    focus -force .t
+    focus -displayof .t.b3
+} {.t}
+if $altDisplay {
+    test focus-1.14 {Tk_FocusCmd procedure, -displayof option} {
+	focus -force .alt.c
+	focus -displayof .alt
+    } {.alt.c}
+}
+test focus-1.15 {Tk_FocusCmd procedure, -force option} {
+    list [catch {focus -force} msg] $msg
+} {1 {wrong # args: should be "focus -force window"}}
+test focus-1.16 {Tk_FocusCmd procedure, -force option} {
+    list [catch {focus -force a b} msg] $msg
+} {1 {wrong # args: should be "focus -force window"}}
+test focus-1.17 {Tk_FocusCmd procedure, -force option} {
+    list [catch {focus -force foo} msg] $msg
+} {1 {bad window path name "foo"}}
+test focus-1.18 {Tk_FocusCmd procedure, -force option} {
+    list [catch {focus -force ""} msg] $msg
+} {0 {}}
+test focus-1.19 {Tk_FocusCmd procedure, -force option} {
+    focusClear
+    focus .t.b1
+    set x  [list [focus]]
+    focus -force .t.b1
+    lappend x [focus]
+} {{} .t.b1}
+test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} {
+    list [catch {focus -lastfor} msg] $msg
+} {1 {wrong # args: should be "focus -lastfor window"}}
+test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} {
+    list [catch {focus -lastfor 1 2} msg] $msg
+} {1 {wrong # args: should be "focus -lastfor window"}}
+test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} {
+    list [catch {focus -lastfor who_knows?} msg] $msg
+} {1 {bad window path name "who_knows?"}}
+test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} {
+    focus .b
+    focus .t.b1
+    list [focus -lastfor .] [focus -lastfor .t.b3]
+} {.b .t.b1}
+test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} {
+    destroy .t
+    focusSetup
+    update
+    focus -lastfor .t.b2
+} {.t}
+test focus-1.25 {Tk_FocusCmd procedure} {
+    list [catch {focus -unknown} msg] $msg
+} {1 {bad option "-unknown": must be -displayof, -force, or -lastfor}}
+
+test focus-2.1 {TkFocusFilterEvent procedure} {nonPortable} {
+    focus -force .b
+    destroy .t
+    focusSetup
+    update
+    set focusInfo {}
+    event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor -sendevent 0x54217567
+    list $focusInfo
+} {{}}
+test focus-2.2 {TkFocusFilterEvent procedure} {nonPortable} {
+    focus -force .b
+    destroy .t
+    focusSetup
+    update
+    set focusInfo {}
+    event gen .t <FocusIn> -detail NotifyAncestor -sendevent 0x547321ac
+    list $focusInfo [focus]
+} {{in .t NotifyAncestor
+} .b}
+test focus-2.3 {TkFocusFilterEvent procedure} {nonPortable} {
+    focus -force .b
+    destroy .t
+    focusSetup
+    update
+    set focusInfo {}
+    event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor
+    update
+    list $focusInfo [focus -lastfor .t]
+} {{out .b NotifyNonlinear
+out . NotifyNonlinearVirtual
+in .t NotifyNonlinear
+} .t}
+test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} {nonPortable} {
+    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
+    }
+    set 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} {nonPortable} {
+    focusSetup
+    focus .t.b1
+    update
+    event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor
+    list $focusInfo [focus]
+} {{out . NotifyNonlinear
+in .t NotifyNonlinearVirtual
+in .t.b1 NotifyNonlinear
+} .t.b1}
+test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} {
+    focus .t.b1
+    focus .
+    update
+    event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor
+    set focusInfo {}
+    set x [focus]
+    event gen . <KeyPress-x>
+    list $x $focusInfo
+} {.t.b1 {press .t.b1 x}}
+test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} {
+    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]
+    }
+    set result
+} {{} .t.b1 {} {} .t.b1 .t.b1 {}}
+test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} {
+    focus -force .t.b1
+    event gen .t.b1 <FocusOut> -detail NotifyAncestor
+    focus
+} {.t.b1}
+test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} {
+    focus .t.b1
+    event gen [testwrapper .] <FocusOut> -detail NotifyAncestor
+    focus
+} {}
+test focus-2.10 {TkFocusFilterEvent procedure, Enter events} {
+    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
+    }
+    set result
+} {.t.b1 {} .t.b1 .t.b1 .t.b1}
+test focus-2.11 {TkFocusFilterEvent procedure, Enter events} {
+    focusClear
+    set focusInfo {}
+    event gen [testwrapper .t] <Enter> -detail NotifyAncestor
+    update
+    set focusInfo
+} {}
+test focus-2.12 {TkFocusFilterEvent procedure, Enter events} {
+    focus -force .b
+    update
+    set focusInfo {}
+    event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
+    update
+    set focusInfo
+} {}
+test focus-2.13 {TkFocusFilterEvent procedure, Enter events} {
+    focus .t.b1
+    focusClear
+    event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
+    set focusInfo {}
+    update
+    set focusInfo
+} {in .t NotifyVirtual
+in .t.b1 NotifyAncestor
+}
+test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} {
+    focusClear
+    catch {destroy .t2}
+    toplevel .t2
+    wm withdraw .t2
+    update
+    set focusInfo {}
+    event gen [testwrapper .t2] <Enter> -detail NotifyAncestor -focus 1
+    update
+    destroy .t2
+} {}
+test focus-2.15 {TkFocusFilterEvent procedure, Leave events} {
+    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]
+    }
+    set result
+} {{} .t.b1 {} {} {}}
+test focus-2.16 {TkFocusFilterEvent procedure, Leave events} {
+    set result {}
+    focus .t.b1
+    event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1
+    update
+    set focusInfo {}
+    event gen [testwrapper .t] <Leave> -detail NotifyAncestor
+    update
+    set focusInfo
+} {out .t.b1 NotifyAncestor
+out .t NotifyVirtual
+}
+test focus-2.17 {TkFocusFilterEvent procedure, Leave events} {
+    set result {}
+    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]
+} {{out .t.b1 NotifyAncestor
+out .t NotifyVirtual
+} {}}
+
+test focus-3.1 {SetFocus procedure, create record on focus} {
+    toplevel .t2 -width 250 -height 100
+    wm geometry .t2 +0+0
+    update
+    focus -force .t2
+    update
+    focus
+} {.t2}
+catch {destroy .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} {
+    update
+    button .b2 -text "Another button"
+    focus .b2
+    update
+} {}
+catch {destroy .b2}
+update
+# 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} {
+    focusSetup
+    focus -force .t.b2
+    update
+} {}
+test focus-3.4 {SetFocus procedure, delaying claim of X focus} {
+    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
+} {}
+catch {destroy .t2}
+test focus-3.5 {SetFocus procedure, generating events} {
+    focusSetup
+    focusClear
+    set focusInfo {}
+    focus -force .t.b2
+    update
+    set focusInfo
+} {in .t NotifyVirtual
+in .t.b2 NotifyAncestor
+}
+test focus-3.6 {SetFocus procedure, generating events} {
+    focusSetup
+    focus -force .b
+    update
+    set focusInfo {}
+    focus .t.b2
+    update
+    set focusInfo
+} {out .b NotifyNonlinear
+out . NotifyNonlinearVirtual
+in .t NotifyNonlinearVirtual
+in .t.b2 NotifyNonlinear
+}
+test focus-3.7 {SetFocus procedure, generating events} {nonPortable} {
+    # Non-portable because some platforms generate extra events.
+
+    focusSetup
+    focusClear
+    set focusInfo {}
+    focus .t.b2
+    update
+    set focusInfo
+} {}
+
+test focus-4.1 {TkFocusDeadWindow procedure} {
+    focusSetup
+    update
+    focus -force .b
+    update
+    destroy .t
+    focus
+} {.b}
+test focus-4.2 {TkFocusDeadWindow procedure} {
+    focusSetup
+    update
+    focus -force .t.b2
+    focus .b
+    update
+    destroy .t.b2
+    update
+    focus
+} {.b}
+
+# Non-portable due to wm-specific redirection of input focus when
+# windows are deleted:
+
+test focus-4.3 {TkFocusDeadWindow procedure} {nonPortable} {
+    focusSetup
+    update
+    focus .t
+    update
+    destroy .t
+    update
+    focus
+} {}
+test focus-4.4 {TkFocusDeadWindow procedure} {
+    focusSetup
+    focus -force .t.b2
+    update
+    destroy .t.b2
+    focus
+} {.t}
+
+# 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 focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} {
+    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]
+} {.t .t {}}
+
+catch {destroy .t}
+bind all <FocusIn> {}
+bind all <FocusOut> {}
+bind all <KeyPress> {}
+cleanupbg
+fixfocus
+
+test focus-6.1 {miscellaneous - embedded application in same process} {unixOnly} {
+    eval interp delete [interp slaves]
+    catch {destroy .t}
+    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}]]
+    interp delete child
+    set 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} {unixOnly} {
+    eval interp delete [interp slaves]
+    catch {destroy .t}
+    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}]]
+    cleanupbg
+    set 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}}}
+
+eval destroy [winfo children .]
+bind all <FocusIn> {}
+bind all <FocusOut> {}