Subversion Repositories or1k

# This file is a Tcl script to test out the "send" command and the

# other procedures in the file tkSend.c.  It is organized in the

# standard fashion for Tcl tests.

#

# Copyright (c) 1994 Sun Microsystems, Inc.

# 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.

#

# RCS: @(#) $Id: send.test,v 1.1.1.1 2002-01-16 10:25:59 markom Exp $

if {$tcl_platform(platform) == "macintosh"} {

    puts "send is not available on the Mac - skipping tests"

    return

}

if {$tcl_platform(platform) == "window"} {

    puts "send is not available under Windows - skipping tests"

    return

}

if {[auto_execok xhost] == ""} {

    puts "xhost application isn't available - skipping tests"

    return

}

if {[info procs test] != "test"} {

    source defs

}

if {[info commands testsend] == "testsend"} {

    set gotTestCmds 1

} else {

    set gotTestCmds 0

}

foreach i [winfo children .] {

    destroy $i

}

wm geometry . {}

raise .

# If send is disabled because of inadequate security, don't run any

# of these tests at all.

setupbg

set app [dobg {tk appname}]

if {[catch {send $app set a 0} msg] == 1} {

    if [string match "X server insecure *" $msg] {

        puts -nonewline "Your X server is insecure, so \"send\" can't be used;"

        puts " skipping \"send\" tests."

        cleanupbg

        return

    }

}

cleanupbg

# Compute a script that will load Tk into a child interpreter.

foreach pkg [info loaded] {

    if {[lindex $pkg 1] == "Tk"} {

        set loadTk "load $pkg"

        break

    }

}

# Procedure to create a new application with a given name and class.

proc newApp {screen name class} {

    global loadTk

    interp create $name

    $name eval [list set argv [list -display $screen -name $name -class $class]]

    eval $loadTk $name

}

set name [tk appname]

if $gotTestCmds {

    set registry [testsend prop root InterpRegistry]

    set commId [lindex [testsend prop root InterpRegistry] 0]

}

tk appname tktest

catch {send t_s_1 destroy .}

catch {send t_s_2 destroy .}

if $gotTestCmds {

    test send-1.1 {RegOpen procedure, bogus property} {

        testsend bogus

        set result [winfo interps]

        tk appname tktest

        list $result [winfo interps]

    } {{} tktest}

    test send-1.2 {RegOpen procedure, bogus property} {

        testsend prop root InterpRegistry {}

        set result [winfo interps]

        tk appname tktest

        list $result [winfo interps]

    } {{} tktest}

    test send-1.3 {RegOpen procedure, bogus property} {

        testsend prop root InterpRegistry abcdefg

        tk appname tktest

        set x [testsend prop root InterpRegistry]

        string range $x [string first " " $x] end

    } " tktest\nabcdefg\n"

    frame .f -width 1 -height 1

    set id [string range [winfo id .f] 2 end]

    test send-2.1 {RegFindName procedure} {

        testsend prop root InterpRegistry {}

        list [catch {send foo bar} msg] $msg

    } {1 {no application named "foo"}}

    test send-2.2 {RegFindName procedure} {

        testsend prop root InterpRegistry " abc\n def\nghi\n\n$id foo\n"

        tk appname foo

    } {foo #2}

    test send-2.3 {RegFindName procedure} {

        testsend prop root InterpRegistry "gyz foo\n"

        tk appname foo

    } {foo}

    test send-2.4 {RegFindName procedure} {

        testsend prop root InterpRegistry "${id}z foo\n"

        tk appname foo

    } {foo}

    test send-3.1 {RegDeleteName procedure} {

        tk appname tktest

        testsend prop root InterpRegistry "012345 gorp\n12345 foo\n12345 tktest"

        tk appname x

        set x [testsend prop root InterpRegistry]

        string range $x [string first " " $x] end

    } " x\n012345 gorp\n12345 foo\n"

    test send-3.2 {RegDeleteName procedure} {

        tk appname tktest

        testsend prop root InterpRegistry "012345 gorp\n12345 tktest\n23456 tktest"

        tk appname x

        set x [testsend prop root InterpRegistry]

        string range $x [string first " " $x] end

    } " x\n012345 gorp\n23456 tktest\n"

    test send-3.3 {RegDeleteName procedure} {

        tk appname tktest

        testsend prop root InterpRegistry "012345 tktest\n12345 bar\n23456 tktest"

        tk appname x

        set x [testsend prop root InterpRegistry]

        string range $x [string first " " $x] end

    } " x\n12345 bar\n23456 tktest\n"

    test send-3.4 {RegDeleteName procedure} {

        tk appname tktest

        testsend prop root InterpRegistry "foo"

        tk appname x

        set x [testsend prop root InterpRegistry]

        string range $x [string first " " $x] end

    } " x\nfoo\n"

    test send-3.5 {RegDeleteName procedure} {

        tk appname tktest

        testsend prop root InterpRegistry ""

        tk appname x

        set x [testsend prop root InterpRegistry]

        string range $x [string first " " $x] end

    } " x\n"

    test send-4.1 {RegAddName procedure} {

        testsend prop root InterpRegistry ""

        tk appname bar

        testsend prop root InterpRegistry

    } "$commId bar\n"

    test send-4.2 {RegAddName procedure} {

        testsend prop root InterpRegistry "abc def"

        tk appname bar

        tk appname foo

        testsend prop root InterpRegistry

    } "$commId foo\nabc def\n"

    # Previous checks should already cover the Regclose procedure.

    test send-5.1 {ValidateName procedure} {

        testsend prop root InterpRegistry "123 abc\n"

        winfo interps

    } {}

    test send-5.2 {ValidateName procedure} {

        testsend prop root InterpRegistry "$id Hi there"

        winfo interps

    } {{Hi there}}

    test send-5.3 {ValidateName procedure} {

        testsend prop root InterpRegistry "$id Bogus"

        list [catch {send Bogus set a 44} msg] $msg

    } {1 {target application died or uses a Tk version before 4.0}}

    test send-5.4 {ValidateName procedure} {

        tk appname test

        testsend prop root InterpRegistry "$commId Bogus\n$commId test\n"

        winfo interps

    } {test}

}

winfo interps

tk appname tktest

update

setupbg

set x [split [exec xhost] \n]

foreach i [lrange $x 1 end]  {

    exec xhost - $i

}

test send-6.1 {ServerSecure procedure} {nonPortable} {

    set a 44

    list [dobg [list send [tk appname] set a 55]] $a

} {55 55}

test send-6.2 {ServerSecure procedure} {nonPortable} {

    set a 22

    exec xhost [exec hostname]

    list [catch {dobg [list send [tk appname] set a 33]} msg] $a $msg

} {0 22 {X server insecure (must use xauth-style authorization); command ignored}}

test send-6.3 {ServerSecure procedure} {nonPortable} {

    set a abc

    exec xhost - [exec hostname]

    list [dobg [list send [tk appname] set a new]] $a

} {new new}

cleanupbg

if $gotTestCmds {

    test send-7.1 {Tk_SetAppName procedure} {

        testsend prop root InterpRegistry ""

        tk appname newName

        list [tk appname oldName] [testsend prop root InterpRegistry]

    } "oldName {$commId oldName\n}"

    test send-7.2 {Tk_SetAppName procedure, name not in use} {

        testsend prop root InterpRegistry ""

        list [tk appname gorp] [testsend prop root InterpRegistry]

    } "gorp {$commId gorp\n}"

    test send-7.3 {Tk_SetAppName procedure, name in use by us} {

        tk appname name1

        testsend prop root InterpRegistry "$commId name2\n"

        list [tk appname name2] [testsend prop root InterpRegistry]

    } "name2 {$commId name2\n}"

    test send-7.4 {Tk_SetAppName procedure, name in use} {

        tk appname name1

        testsend prop root InterpRegistry "$id foo\n$id foo #2\n$id foo #3\n"

        list [tk appname foo] [testsend prop root InterpRegistry]

    } "{foo #4} {$commId foo #4\n$id foo\n$id foo #2\n$id foo #3\n}"

}

test send-8.1 {Tk_SendCmd procedure, options} {

    setupbg

    set app [dobg {tk appname}]

    set a 66

    send -async $app [list send [tk appname] set a 77]

    set result $a

    after 200 set x 40

    tkwait variable x

    cleanupbg

    lappend result $a

} {66 77}

if [info exists env(TK_ALT_DISPLAY)] {

    test send-8.2 {Tk_SendCmd procedure, options} {

        setupbg -display $env(TK_ALT_DISPLAY)

        tk appname xyzgorp

        set a homeDisplay

        set result [dobg "

            toplevel .t -screen [winfo screen .]

            wm geometry .t +0+0

            set a altDisplay

            tk appname xyzgorp

            list \[send xyzgorp set a\] \[send -displayof .t xyzgorp set a\]

        "]

        cleanupbg

        set result

    } {altDisplay homeDisplay}

}

test send-8.3 {Tk_SendCmd procedure, options} {

    list [catch {send -- -async foo bar baz} msg] $msg

} {1 {no application named "-async"}}

test send-8.4 {Tk_SendCmd procedure, options} {

    list [catch {send -gorp foo bar baz} msg] $msg

} {1 {bad option "-gorp": must be -async, -displayof, or --}}

test send-8.5 {Tk_SendCmd procedure, options} {

    list [catch {send -async foo} msg] $msg

} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}}

test send-8.6 {Tk_SendCmd procedure, options} {

    list [catch {send foo} msg] $msg

} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}}

test send-8.7 {Tk_SendCmd procedure, local execution} {

    set a initial

    send [tk appname] {set a new}

    set a

} {new}

test send-8.8 {Tk_SendCmd procedure, local execution} {

    set a initial

    send [tk appname] set a new

    set a

} {new}

test send-8.9 {Tk_SendCmd procedure, local execution} {

    set a initial

    string tolower [list [catch {send [tk appname] open bad_file} msg] \

            $msg $errorInfo $errorCode]

} {1 {couldn't open "bad_file": no such file or directory} {couldn't open "bad_file": no such file or directory

    while executing

"open bad_file"

    invoked from within

"send [tk appname] open bad_file"} {posix enoent {no such file or directory}}}

test send-8.10 {Tk_SendCmd procedure, no such interpreter} {

    list [catch {send bogus_name bogus_command} msg] $msg

} {1 {no application named "bogus_name"}}

if $gotTestCmds {

    newApp "" t_s_1 Test

    t_s_1 eval wm withdraw .

    test send-8.11 {Tk_SendCmd procedure, local execution, different interp} {

        set a us

        send t_s_1 set a them

        list $a [send t_s_1 set a]

    } {us them}

    test send-8.12 {Tk_SendCmd procedure, local execution, different interp} {

        set a us

        send t_s_1 {set a them}

        list $a [send t_s_1 {set a}]

    } {us them}

    test send-8.13 {Tk_SendCmd procedure, local execution, different interp} {

        set a us

        send t_s_1 {set a them}

        list $a [send t_s_1 {set a}]

    } {us them}

    test send-8.14 {Tk_SendCmd procedure, local interp killed by send} {

        newApp "" t_s_2 Test

        list [catch {send t_s_2 {destroy .; concat result}} msg] $msg

    } {0 result}

    interp delete t_s_2

    test send-8.15 {Tk_SendCmd procedure, local interp, error info} {

        catch {error foo}

        list [catch {send t_s_1 {if 1 {open bogus_file_name}}} msg] $msg $errorInfo $errorCode

    } {1 {couldn't open "bogus_file_name": no such file or directory} {couldn't open "bogus_file_name": no such file or directory

    while executing

"open bogus_file_name"

    invoked from within

"send t_s_1 {if 1 {open bogus_file_name}}"} {POSIX ENOENT {no such file or directory}}}

    test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {

        testsend prop root InterpRegistry "10234 bogus\n"

        set result [list [catch {send bogus bogus command} msg] $msg]

        winfo interps

        tk appname tktest

        set result

    } {1 {no application named "bogus"}}

    interp delete t_s_1

}

test send-8.17 {Tk_SendCmd procedure, deferring events} {nonPortable} {

    # Non-portable because some window managers ignore "raise"

    # requests so can't guarantee that new app's window won't

    # obscure .f, thereby masking the Expose event.

    setupbg

    set app [dobg {tk appname}]

    raise .             ; # Don't want new app obscuring .f

    catch {destroy .f}

    frame .f

    place .f -x 0 -y 0

    bind .f  {set a exposed}

    set a {no event yet}

    set result ""

    lappend result [send $app send [list [tk appname]] set a]

    lappend result $a

    update

    cleanupbg

    lappend result $a

} {{no event yet} {no event yet} exposed}

test send-8.18 {Tk_SendCmd procedure, error in remote app} {

    setupbg

    set app [dobg {tk appname}]

    set result [string tolower [list [catch {send $app open bad_name} msg] \

            $msg $errorInfo $errorCode]]

    cleanupbg

    set result

} {1 {couldn't open "bad_name": no such file or directory} {couldn't open "bad_name": no such file or directory

    while executing

"open bad_name"

    invoked from within

"send $app open bad_name"} {posix enoent {no such file or directory}}}

test send-8.19 {Tk_SendCmd, using modal timeouts} {

    setupbg

    set app [dobg {tk appname}]

    set x no

    set result ""

    after 0 {set x yes}

    lappend result [send $app {concat x y z}]

    lappend result $x

    update

    cleanupbg

    lappend result $x

} {{x y z} no yes}

tk appname tktest

catch {destroy .f}

frame .f

set id [string range [winfo id .f] 2 end]

if $gotTestCmds {

    test send-9.1 {Tk_GetInterpNames procedure} {

        testsend prop root InterpRegistry \

                "$commId tktest\nfoo bar\n$commId tktest\n$id frame .f\n\n\n"

        list [winfo interps] [testsend prop root InterpRegistry]

    } "{tktest tktest {frame .f}} {$commId tktest\n$commId tktest\n$id frame .f

}"

    test send-9.2 {Tk_GetInterpNames procedure} {

        testsend prop root InterpRegistry \

                "$commId tktest\nfoobar\n$commId gorp\n"

        list [winfo interps] [testsend prop root InterpRegistry]

    } "tktest {$commId tktest\n}"

    test send-9.3 {Tk_GetInterpNames procedure} {

        testsend prop root InterpRegistry {}

        list [winfo interps] [testsend prop root InterpRegistry]

    } {{} {}}

    testsend prop root InterpRegistry "$commId tktest\n$id dummy\n"

    test send-10.1 {SendEventProc procedure, bogus comm property} {

        testsend prop comm Comm {abc def}

        testsend prop comm Comm {}

        update

    } {}

    test send-10.2 {SendEventProc procedure, simultaneous messages} {

        testsend prop comm Comm \

                "c\n-n tktest\n-s set a 44\nc\n-n tktest\n-s set b 45\n"

        set a null

        set b xyzzy

        update

        list $a $b

    } {44 45}

    test send-10.3 {SendEventProc procedure, simultaneous messages} {

        testsend prop comm Comm \

                "c\n-n tktest\n-s set a newA\nr\n-s [testsend serial]\n-r 12345\nc\n-n tktest\n-s set b newB\n"

        set a null

        set b xyzzy

        set x [send dummy bogus]

        list $x $a $b

    } {12345 newA newB}

    test send-10.4 {SendEventProc procedure, leading nulls, bogus commands} {

        testsend prop comm Comm \

                "\n\nx\n-bogus\n\nc\n-n tktest\n-s set a 44\n"

        set a null

        update

        set a

    } {44}

    test send-10.5 {SendEventProc procedure, extraneous command options} {

        testsend prop comm Comm \

                "c\n-n tktest\n-x miscellanous\n-y who knows?\n-s set a new\n"

        set a null

        update

        set a

    } {new}

    test send-10.6 {SendEventProc procedure, unknown interpreter} {

        testsend prop [winfo id .f] Comm {}

        testsend prop comm Comm \

                "c\n-n unknown\n-r $id 44\n-s set a new\n"

        set a null

        update

        list [testsend prop [winfo id .f] Comm] $a

    } "{\nr\n-s 44\n-r receiver never heard of interpreter \"unknown\"\n-c 1\n} null"

    test send-10.7 {SendEventProc procedure, error in script} {

        testsend prop [winfo id .f] Comm {}

        testsend prop comm Comm \

                "c\n-n tktest\n-r $id 62\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n"

        update

        testsend prop [winfo id .f] Comm

    } {

r

-s 62

-r test error

-i Initial errorInfo

    ("foreach" body line 1)

    invoked from within

"foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}"

-e test code

-c 1

}

    test send-10.8 {SendEventProc procedure, exceptional return} {

        testsend prop [winfo id .f] Comm {}

        testsend prop comm Comm \

                "c\n-n tktest\n-r $id 62\n-s break\n"

        update

        testsend prop [winfo id .f] Comm

    } {

r

-s 62

-r

-c 3

}

    test send-10.9 {SendEventProc procedure, empty return} {

        testsend prop [winfo id .f] Comm {}

        testsend prop comm Comm \

                "c\n-n tktest\n-r $id 62\n-s concat\n"

        update

        testsend prop [winfo id .f] Comm

    } {

r

-s 62

-r

}

    test send-10.10 {SendEventProc procedure, asynchronous calls} {

        testsend prop [winfo id .f] Comm {}

        testsend prop comm Comm \

                "c\n-n tktest\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n"

        update

        testsend prop [winfo id .f] Comm

    } {}

    test send-10.11 {SendEventProc procedure, exceptional return} {

        testsend prop [winfo id .f] Comm {}

        testsend prop comm Comm \

                "c\n-n tktest\n-s break\n"

        update

        testsend prop [winfo id .f] Comm

    } {}

    test send-10.12 {SendEventProc procedure, empty return} {

        testsend prop [winfo id .f] Comm {}

        testsend prop comm Comm \

                "c\n-n tktest\n-s concat\n"

        update

        testsend prop [winfo id .f] Comm

    } {}

    test send-10.13 {SendEventProc procedure, return processing} {

        testsend prop comm Comm \

                "r\n-c 1\n-e test1\n-i test2\n-r test3\n-s [testsend serial]\n"

        list [catch {send dummy foo} msg] $msg $errorInfo $errorCode

    } {1 test3 {test2

    invoked from within

"send dummy foo"} test1}

    test send-10.14 {SendEventProc procedure, extraneous return options} {

        testsend prop comm Comm \

                "r\n-x test1\n-y test2\n-r result\n-s [testsend serial]\n"

        list [catch {send dummy foo} msg] $msg

    } {0 result}

    test send-10.15 {SendEventProc procedure, serial number} {

        testsend prop comm Comm \

                "r\n-r response\n"

        list [catch {send dummy foo} msg] $msg

    } {1 {target application died or uses a Tk version before 4.0}}

    test send-10.16 {SendEventProc procedure, serial number} {

        testsend prop comm Comm \

                "r\n-r response\n\n-s 0"

        list [catch {send dummy foo} msg] $msg

    } {1 {target application died or uses a Tk version before 4.0}}

    test send-10.17 {SendEventProc procedure, errorCode and errorInfo} {

        testsend prop comm Comm \

                "r\n-i test1\n-e test2\n-c 4\n-s [testsend serial]\n"

        set errorCode oldErrorCode

        set errorInfo oldErrorInfo

        list [catch {send dummy foo} msg] $msg $errorInfo $errorCode

    } {4 {} oldErrorInfo oldErrorCode}

    test send-10.18 {SendEventProc procedure, send kills application} {

        setupbg

        dobg {tk appname t_s_3}

        set x [list [catch {send t_s_3 destroy .} msg] $msg]

        cleanupbg

        set x

    } {0 {}}

    test send-10.19 {SendEventProc procedure, send exits} {

        setupbg

        dobg {tk appname t_s_3}

        set x [list [catch {send t_s_3 exit} msg] $msg]

        close $fd

        set x

    } {1 {target application died}}

    test send-11.1 {AppendPropCarefully and AppendErrorProc procedures} {

        testsend prop root InterpRegistry "0x21447 dummy\n"

        list [catch {send dummy foo} msg] $msg

    } {1 {no application named "dummy"}}

    test send-11.2 {AppendPropCarefully and AppendErrorProc procedures} {

        testsend prop comm Comm "c\n-r0x123 44\n-n tktest\n-s concat a b c\n"

        update

    } {}

}

winfo interps

tk appname tktest

catch {destroy .f}

frame .f

set id [string range [winfo id .f] 2 end]

if $gotTestCmds {

    test send-12.1 {TimeoutProc procedure} {

        testsend prop root InterpRegistry "$id dummy\n"

        list [catch {send dummy foo} msg] $msg

    } {1 {target application died or uses a Tk version before 4.0}}

    testsend prop root InterpRegistry ""

}

test send-12.2 {TimeoutProc procedure} {

    winfo interps

    tk appname tktest

    update

    setupbg

    puts $fd {after 10 {after 5000; exit}; puts [tk appname]; puts **DONE**; flush stdout}

    set bgDone 0

    set bgData {}

    flush $fd

    tkwait variable bgDone

    set app $bgData

    after 200

    set result [list [catch {send $app foo} msg] $msg]

    close $fd

    set result

} {1 {target application died}}

winfo interps

tk appname tktest

test send-13.1 {DeleteProc procedure} {

    setupbg

    set app [dobg {rename send {}; tk appname}]

    set result [list [catch {send $app foo} msg] $msg [winfo interps]]

    cleanupbg

    set result

} {1 {no application named "tktest #2"} tktest}

test send-13.2 {DeleteProc procedure} {

    winfo interps

    tk appname tktest

    rename send {}

    set result {}

    lappend result [winfo interps] [info commands send]

    tk appname foo

    lappend result [winfo interps] [info commands send]

} {{} {} foo send}

if [info exists env(TK_ALT_DISPLAY)] {

    test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} {

        setupbg -display $env(TK_ALT_DISPLAY)

        set result [dobg "

            toplevel .t -screen [winfo screen .]

            wm geometry .t +0+0

            tk appname xyzgorp1

            set x child

        "]

        toplevel .t -screen $env(TK_ALT_DISPLAY)

        wm geometry .t +0+0

        tk appname xyzgorp2

        update

        set y parent

        set result [send -displayof .t xyzgorp1 {list $x [send -displayof .t xyzgorp2 set y]}]

        destroy .t

        cleanupbg

        set result

    } {child parent}

}

if $gotTestCmds {

    testsend prop root InterpRegister $registry

    tk appname tktest

    test send-15.1 {UpdateCommWindow procedure} {

        set x [list [testsend prop comm TK_APPLICATION]]

        newApp "" t_s_1 Test

        send t_s_1 wm withdraw .

        newApp "" t_s_2 Test

        send t_s_2 wm withdraw .

        lappend x [testsend prop comm TK_APPLICATION]

        interp delete t_s_1

        lappend x [testsend prop comm TK_APPLICATION]

        interp delete t_s_2

        lappend x [testsend prop comm TK_APPLICATION]

    } {tktest {t_s_2 t_s_1 tktest} {t_s_2 tktest} tktest}

}

tk appname $name

if $gotTestCmds {

    testsend prop root InterpRegistry $registry

}

if $gotTestCmds {

    testdeleteapps

}

rename newApp {}