interp.test

linux系统下的音频通信

    set l
} {1 {1 2 3} 1 {3 4 5}}
test interp-24.7 {result resetting on error} {
    catch {interp delete a}
    interp create a
    interp eval a {
	proc foo args {error $args}
    }
    set l {}
    lappend l [catch {interp eval a foo 1 2 3} msg]
    lappend l $msg
    lappend l [catch {interp eval a foo 3 4 5} msg]
    lappend l $msg
    interp delete a
    set l
} {1 {1 2 3} 1 {3 4 5}}
test interp-24.8 {result resetting on error} {
    catch {interp delete a}
    interp create a -safe
    interp eval a {
	proc foo args {error $args}
    }
    set l {}
    lappend l [catch {interp eval a foo 1 2 3} msg]
    lappend l $msg
    lappend l [catch {interp eval a foo 3 4 5} msg]
    lappend l $msg
    interp delete a
    set l
} {1 {1 2 3} 1 {3 4 5}}
test interp-24.9 {result resetting on error} {
    catch {interp delete a}
    interp create a
    interp create {a b}
    interp eval {a b} {
	proc foo args {error $args}
    }
    interp eval a {
	proc foo args {
	    eval interp eval b foo $args
	}
    }
    set l {}
    lappend l [catch {interp eval a foo 1 2 3} msg]
    lappend l $msg
    lappend l [catch {interp eval a foo 3 4 5} msg]
    lappend l $msg
    interp delete a
    set l
} {1 {1 2 3} 1 {3 4 5}}
test interp-24.10 {result resetting on error} {
    catch {interp delete a}
    interp create a -safe
    interp create {a b}
    interp eval {a b} {
	proc foo args {error $args}
    }
    interp eval a {
	proc foo args {
	    eval interp eval b foo $args
	}
    }
    set l {}
    lappend l [catch {interp eval a foo 1 2 3} msg]
    lappend l $msg
    lappend l [catch {interp eval a foo 3 4 5} msg]
    lappend l $msg
    interp delete a
    set l
} {1 {1 2 3} 1 {3 4 5}}
test interp-24.11 {result resetting on error} {
    catch {interp delete a}
    interp create a
    interp create {a b}
    interp eval {a b} {
	proc foo args {error $args}
    }
    interp eval a {
	proc foo args {
	    set l {}
	    lappend l [catch {eval interp eval b foo $args} msg]
	    lappend l $msg
	    lappend l [catch {eval interp eval b foo $args} msg]
	    lappend l $msg
	    set l
	}
    }
    set l [interp eval a foo 1 2 3]
    interp delete a
    set l
} {1 {1 2 3} 1 {1 2 3}}
test interp-24.12 {result resetting on error} {
    catch {interp delete a}
    interp create a -safe
    interp create {a b}
    interp eval {a b} {
	proc foo args {error $args}
    }
    interp eval a {
	proc foo args {
	    set l {}
	    lappend l [catch {eval interp eval b foo $args} msg]
	    lappend l $msg
	    lappend l [catch {eval interp eval b foo $args} msg]
	    lappend l $msg
	    set l
	}
    }
    set l [interp eval a foo 1 2 3]
    interp delete a
    set l
} {1 {1 2 3} 1 {1 2 3}}

unset hidden_cmds

test interp-25.1 {testing aliasing of string commands} {
    catch {interp delete a}
    interp create a
    a alias exec foo		;# Relies on exec being a string command!
    interp delete a
} ""


# Interps result transmission
test interp-26.1 {result code transmission 1} {knownBug} {
    # This test currently fails ! (only ok/error are passed, not the other
    # codes). Fixing the code is thus needed...  -- dl
    # (the only other acceptable result list would be
    #  {-1 0 1 0 3 4 5} because of the way return -code return(=2) works)
    # test that all the possibles error codes from Tcl get passed
    catch {interp delete a}
    interp create a
    interp eval a {proc ret {code} {return -code $code $code}}
    set res {}
    # use a for so if a return -code break 'escapes' we would notice
    for {set code -1} {$code<=5} {incr code} {
	lappend res [catch {interp eval a ret $code} msg]
    }
    interp delete a
    set res
} {-1 0 1 2 3 4 5}

test interp-26.2 {result code transmission 2} {knownBug} {
    # This test currently fails ! (error is cleared)
    # Code fixing is needed...  -- dl
    # (the only other acceptable result list would be
    #  {-1 0 1 0 3 4 5} because of the way return -code return(=2) works)
    # test that all the possibles error codes from Tcl get passed
    set interp [interp create];
    proc MyTestAlias {interp args} {
	global aliasTrace;
	lappend aliasTrace $args;
	eval interp invokehidden [list $interp] $args
    }
    foreach c {return} {
	interp hide $interp  $c;
        interp alias $interp $c {} MyTestAlias $interp $c;
    }
    interp eval $interp {proc ret {code} {return -code $code $code}}
    set res {}
    set aliasTrace {}
    for {set code -1} {$code<=5} {incr code} {
	lappend res [catch {interp eval $interp ret $code} msg]
    }
    interp delete $interp;
    list $res
} {-1 0 1 2 3 4 5}

test interp-26.3 {errorInfo transmission : regular interps} {
    set interp [interp create];
    proc MyError {secret} {
	return -code error "msg"
    }
    proc MyTestAlias {interp args} {
	MyError "some secret"
    }
    interp alias $interp test {} MyTestAlias $interp;
    set res [interp eval $interp {catch test;set errorInfo}]
    interp delete $interp;
    set res
} {msg
    while executing
"MyError "some secret""
    (procedure "test" line 2)
    invoked from within
"catch test"}

test interp-26.4 {errorInfo transmission : safe interps} {knownBug} {
    # this test fails because the errorInfo is fully transmitted
    # whether the interp is safe or not. this is maybe a feature
    # and not a bug.
    set interp [interp create -safe];
    proc MyError {secret} {
	return -code error "msg"
    }
    proc MyTestAlias {interp args} {
	MyError "some secret"
    }
    interp alias $interp test {} MyTestAlias $interp;
    set res [interp eval $interp {catch test;set errorInfo}]
    interp delete $interp;
    set res
} {msg
    while executing
"catch test"}

# Interps & Namespaces
test interp-27.1 {interp aliases & namespaces} {
    set i [interp create];
    set aliasTrace {};
    proc tstAlias {args} { 
	global aliasTrace;
	lappend aliasTrace [list [namespace current] $args];
    }
    $i alias foo::bar tstAlias foo::bar;
    $i eval foo::bar test
    interp delete $i
    set aliasTrace;
} {{:: {foo::bar test}}}

test interp-27.2 {interp aliases & namespaces} {
    set i [interp create];
    set aliasTrace {};
    proc tstAlias {args} { 
	global aliasTrace;
	lappend aliasTrace [list [namespace current] $args];
    }
    $i alias foo::bar tstAlias foo::bar;
    $i eval namespace eval foo {bar test}
    interp delete $i
    set aliasTrace;
} {{:: {foo::bar test}}}

test interp-27.3 {interp aliases & namespaces} {
    set i [interp create];
    set aliasTrace {};
    proc tstAlias {args} { 
	global aliasTrace;
	lappend aliasTrace [list [namespace current] $args];
    }
    interp eval $i {namespace eval foo {proc bar {} {error "bar called"}}}
    interp alias $i foo::bar {} tstAlias foo::bar;
    interp eval $i {namespace eval foo {bar test}}
    interp delete $i
    set aliasTrace;
} {{:: {foo::bar test}}}

test interp-27.4 {interp aliases & namespaces} {
    set i [interp create];
    namespace eval foo2 {
	variable aliasTrace {};
	proc bar {args} { 
	    variable aliasTrace;
	    lappend aliasTrace [list [namespace current] $args];
	}
    }
    $i alias foo::bar foo2::bar foo::bar;
    $i eval namespace eval foo {bar test}
    set r $foo2::aliasTrace;
    namespace delete foo2;
    set r
} {{::foo2 {foo::bar test}}}

# the following tests are commented out while we don't support
# hiding in namespaces

# test interp-27.5 {interp hidden & namespaces} {
#    set i [interp create];
#    interp eval $i {
#	namespace eval foo {
#	    proc bar {args} {
#		return "bar called ([namespace current]) ($args)"
#	    }
#	}
#    }
#    set res [list [interp eval $i {namespace eval foo {bar test1}}]]
#    interp hide $i foo::bar;
#    lappend res [list [catch {interp eval $i {namespace eval foo {bar test2}}} msg] $msg]
#    interp delete $i;
#    set res;
#} {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}}

# test interp-27.6 {interp hidden & aliases & namespaces} {
#     set i [interp create];
#     set v root-master;
#     namespace eval foo {
# 	variable v foo-master;
# 	proc bar {interp args} {
# 	    variable v;
# 	    list "master bar called ($v) ([namespace current]) ($args)"\
# 		    [interp invokehidden $interp foo::bar $args];
# 	}
#     }
#     interp eval $i {
# 	namespace eval foo {
# 	    namespace export *
# 	    variable v foo-slave;
# 	    proc bar {args} {
# 		variable v;
# 		return "slave bar called ($v) ([namespace current]) ($args)"
# 	    }
# 	}
#     }
#     set res [list [interp eval $i {namespace eval foo {bar test1}}]]
#     $i hide foo::bar;
#     $i alias foo::bar foo::bar $i;
#     set res [concat $res [interp eval $i {
# 	set v root-slave;
# 	namespace eval test {
# 	    variable v foo-test;
# 	    namespace import ::foo::*;
# 	    bar test2
#         }
#     }]]
#     namespace delete foo;
#     interp delete $i;
#     set res
# } {{slave bar called (foo-slave) (::foo) (test1)} {master bar called (foo-master) (::foo) (test2)} {slave bar called (foo-slave) (::foo) (test2)}}


# test interp-27.7 {interp hidden & aliases & imports & namespaces} {
#     set i [interp create];
#     set v root-master;
#     namespace eval mfoo {
# 	variable v foo-master;
# 	proc bar {interp args} {
# 	    variable v;
# 	    list "master bar called ($v) ([namespace current]) ($args)"\
# 		    [interp invokehidden $interp test::bar $args];
# 	}
#     }
#     interp eval $i {
# 	namespace eval foo {
# 	    namespace export *
# 	    variable v foo-slave;
# 	    proc bar {args} {
# 		variable v;
# 		return "slave bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)"
# 	    }
# 	}
# 	set v root-slave;
# 	namespace eval test {
# 	    variable v foo-test;
# 	    namespace import ::foo::*;
#         }
#     }
#     set res [list [interp eval $i {namespace eval test {bar test1}}]]
#     $i hide test::bar;
#     $i alias test::bar mfoo::bar $i;
#     set res [concat $res [interp eval $i {test::bar test2}]];
#     namespace delete mfoo;
#     interp delete $i;
#     set res
# } {{slave bar called (foo-slave) (bar test1) (::test) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}}

#test interp-27.8 {hiding, namespaces and integrity} {
#    namespace eval foo {
#	variable v 3;
#	proc bar {} {variable v; set v}
#	# next command would currently generate an unknown command "bar" error.
#	interp hide {} bar;
#    }
#    namespace delete foo;
#    list [catch {interp invokehidden {} foo} msg] $msg;
#} {1 {invalid hidden command name "foo"}}


test interp-28.1 {getting fooled by slave's namespace ?} {
    set i [interp create -safe];
    proc master {interp args} {interp hide $interp list}
    $i alias master master $i;
    set r [interp eval $i {
	namespace eval foo {
	    proc list {args} {
		return "dummy foo::list";
	    }
	    master;
	}
	info commands list
    }]
    interp delete $i;
    set r
} {}

# Tests of recursionlimit
# We need testsetrecursionlimit so we need Tcltest package
if {[catch {package require Tcltest} msg]} {
    puts "This application hasn't been compiled with Tcltest"
    puts "skipping remining interp tests that relies on it."
} else {
    # 
test interp-29.1 {recursion limit} {
    set i [interp create]
    load {} Tcltest $i
    set r [interp eval $i {
	testsetrecursionlimit 50
	proc p {} {incr ::i; p}
	set i 0
	catch p
	set i
    }]
   interp delete $i
   set r
} 49

test interp-29.2 {recursion limit inheritance} {
    set i [interp create]
    load {} Tcltest $i
    set ii [interp eval $i {
	testsetrecursionlimit 50
	interp create
    }]
    set r [interp eval [list $i $ii] {
	proc p {} {incr ::i; p}
	set i 0
	catch p
	set i
    }]
   interp delete $i
   set r
} 49

#    # Deep recursion (into interps when the regular one fails):
#    # still crashes...
#    proc p {} {
#	if {[catch p ret]} {
#	    catch {
#		set i [interp create]
#		interp eval $i [list proc p {} [info body p]]
#		interp eval $i p
#	    }
#	    interp delete $i
#	    return ok
#	}
#	return $ret
#    }
#    p

# more tests needed...

# Interp & stack
#test interp-29.1 {interp and stack (info level)} {
#} {}

}


foreach i [interp slaves] {
  interp delete $i
}