interp.test

来自「tcl是工具命令语言」· TEST 代码 · 共 2,318 行 · 第 1/5 页

    interp create a
    interp create {a x3} -safe
    a eval x3 issafe
} 1
test interp-13.3 {testing foo issafe} {
    catch {interp delete a}
    interp create a
    interp create {a x3} -safe
    interp create {a x3 foo}
    a eval x3 eval foo issafe
} 1
test interp-13.4 {testing issafe arg checking} {
    catch {interp create a}
    list [catch {a issafe too many args} msg] $msg
} {1 {wrong # args: should be "a issafe"}}

# part 14: testing interp aliases
test interp-14.1 {testing interp aliases} {
    interp aliases
} ""
test interp-14.2 {testing interp aliases} {
    catch {interp delete a}
    interp create a
    a alias a1 puts
    a alias a2 puts
    a alias a3 puts
    lsort [interp aliases a]
} {a1 a2 a3}
test interp-14.3 {testing interp aliases} {
    catch {interp delete a}
    interp create a
    interp create {a x3}
    interp alias {a x3} froboz "" puts
    interp aliases {a x3}
} froboz
test interp-14.4 {testing interp alias - alias over master} {
    # SF Bug 641195
    catch {interp delete a}
    interp create a
    list [catch {interp alias "" a a eval} msg] $msg [info commands a]
} {1 {cannot define or rename alias "a": interpreter deleted} {}}

# part 15: testing file sharing
test interp-15.1 {testing file sharing} {
    catch {interp delete z}
    interp create z
    z eval close stdout
    list [catch {z eval puts hello} msg] $msg
} {1 {can not find channel named "stdout"}}
test interp-15.2 {testing file sharing} -body {
    catch {interp delete z}
    interp create z
    set f [open [makeFile {} file-15.2] w]
    interp share "" $f z
    z eval puts $f hello
    z eval close $f
    close $f
} -cleanup {
    removeFile file-15.2
} -result ""
test interp-15.3 {testing file sharing} {
    catch {interp delete xsafe}
    interp create xsafe -safe
    list [catch {xsafe eval puts hello} msg] $msg
} {1 {can not find channel named "stdout"}}
test interp-15.4 {testing file sharing} -body {
    catch {interp delete xsafe}
    interp create xsafe -safe
    set f [open [makeFile {} file-15.4] w]
    interp share "" $f xsafe
    xsafe eval puts $f hello
    xsafe eval close $f
    close $f
} -cleanup {
    removeFile file-15.4
} -result ""
test interp-15.5 {testing file sharing} {
    catch {interp delete xsafe}
    interp create xsafe -safe
    interp share "" stdout xsafe
    list [catch {xsafe eval gets stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test interp-15.6 {testing file sharing} -body {
    catch {interp delete xsafe}
    interp create xsafe -safe
    set f [open [makeFile {} file-15.6] w]
    interp share "" $f xsafe
    set x [list [catch [list xsafe eval gets $f] msg] $msg]
    xsafe eval close $f
    close $f
    string compare [string tolower $x] \
		[list 1 [format "channel \"%s\" wasn't opened for reading" $f]]
} -cleanup {
    removeFile file-15.6
} -result 0
test interp-15.7 {testing file transferring} -body {
    catch {interp delete xsafe}
    interp create xsafe -safe
    set f [open [makeFile {} file-15.7] w]
    interp transfer "" $f xsafe
    xsafe eval puts $f hello
    xsafe eval close $f
} -cleanup {
    removeFile file-15.7
} -result ""
test interp-15.8 {testing file transferring} -body {
    catch {interp delete xsafe}
    interp create xsafe -safe
    set f [open [makeFile {} file-15.8] w]
    interp transfer "" $f xsafe
    xsafe eval close $f
    set x [list [catch {close $f} msg] $msg]
    string compare [string tolower $x] \
		[list 1 [format "can not find channel named \"%s\"" $f]]
} -cleanup {
    removeFile file-15.8
} -result 0

#
# Torture tests for interpreter deletion order
#
proc kill {} {interp delete xxx}

test interp-15.9 {testing deletion order} {
    catch {interp delete xxx}
    interp create xxx
    xxx alias kill kill
    list [catch {xxx eval kill} msg] $msg
} {0 {}}
test interp-16.1 {testing deletion order} {
    catch {interp delete xxx}
    interp create xxx
    interp create {xxx yyy}
    interp alias {xxx yyy} kill "" kill
    list [catch {interp eval {xxx yyy} kill} msg] $msg
} {0 {}}
test interp-16.2 {testing deletion order} {
    catch {interp delete xxx}
    interp create xxx
    interp create {xxx yyy}
    interp alias {xxx yyy} kill "" kill
    list [catch {xxx eval yyy eval kill} msg] $msg
} {0 {}}
test interp-16.3 {testing deletion order} {
    catch {interp delete xxx}
    interp create xxx
    interp create ddd
    xxx alias kill kill
    interp alias ddd kill xxx kill
    set x [ddd eval kill]
    interp delete ddd
    set x
} ""
test interp-16.4 {testing deletion order} {
    catch {interp delete xxx}
    interp create xxx
    interp create {xxx yyy}
    interp alias {xxx yyy} kill "" kill
    interp create ddd
    interp alias ddd kill {xxx yyy} kill
    set x [ddd eval kill]
    interp delete ddd
    set x
} ""
test interp-16.5 {testing deletion order, bgerror} {
    catch {interp delete xxx}
    interp create xxx
    xxx eval {proc bgerror {args} {exit}}
    xxx alias exit kill xxx
    proc kill {i} {interp delete $i}
    xxx eval after 100 expr a + b
    after 200
    update
    interp exists xxx
} 0

#
# Alias loop prevention testing.
#

test interp-17.1 {alias loop prevention} {
    list [catch {interp alias {} a {} a} msg] $msg
} {1 {cannot define or rename alias "a": would create a loop}}
test interp-17.2 {alias loop prevention} {
    catch {interp delete x}
    interp create x
    x alias a loop
    list [catch {interp alias {} loop x a} msg] $msg
} {1 {cannot define or rename alias "loop": would create a loop}}
test interp-17.3 {alias loop prevention} {
    catch {interp delete x}
    interp create x
    interp alias x a x b
    list [catch {interp alias x b x a} msg] $msg
} {1 {cannot define or rename alias "b": would create a loop}}
test interp-17.4 {alias loop prevention} {
    catch {interp delete x}
    interp create x
    interp alias x b x a
    list [catch {x eval rename b a} msg] $msg
} {1 {cannot define or rename alias "b": would create a loop}}
test interp-17.5 {alias loop prevention} {
    catch {interp delete x}
    interp create x
    x alias z l1
    interp alias {} l2 x z
    list [catch {rename l2 l1} msg] $msg
} {1 {cannot define or rename alias "l2": would create a loop}}

#
# Test robustness of Tcl_DeleteInterp when applied to a slave interpreter.
# If there are bugs in the implementation these tests are likely to expose
# the bugs as a core dump.
#

if {[info commands testinterpdelete] == ""} {
    puts "This application hasn't been compiled with the \"testinterpdelete\""
    puts "command, so I can't test slave delete calls"
} else {
    test interp-18.1 {testing Tcl_DeleteInterp vs slaves} {
	list [catch {testinterpdelete} msg] $msg
    } {1 {wrong # args: should be "testinterpdelete path"}}
    test interp-18.2 {testing Tcl_DeleteInterp vs slaves} {
	catch {interp delete a}
	interp create a
	testinterpdelete a
    } ""
    test interp-18.3 {testing Tcl_DeleteInterp vs slaves} {
	catch {interp delete a}
	interp create a
	interp create {a b}
	testinterpdelete {a b}
    } ""
    test interp-18.4 {testing Tcl_DeleteInterp vs slaves} {
	catch {interp delete a}
	interp create a
	interp create {a b}
	testinterpdelete a
    } ""
    test interp-18.5 {testing Tcl_DeleteInterp vs slaves} {
	catch {interp delete a}
	interp create a
	interp create {a b}
	interp alias {a b} dodel {} dodel
	proc dodel {x} {testinterpdelete $x}
	list [catch {interp eval {a b} {dodel {a b}}} msg] $msg
    } {0 {}}
    test interp-18.6 {testing Tcl_DeleteInterp vs slaves} {
	catch {interp delete a}
	interp create a
	interp create {a b}
	interp alias {a b} dodel {} dodel
	proc dodel {x} {testinterpdelete $x}
	list [catch {interp eval {a b} {dodel a}} msg] $msg
    } {0 {}}
    test interp-18.7 {eval in deleted interp} {
	catch {interp delete a}
	interp create a
	a eval {
	    proc dodel {} {
		delme
		dosomething else
	    }
	    proc dosomething args {
		puts "I should not have been called!!"
	    }
	}
	a alias delme dela
	proc dela {} {interp delete a}
	list [catch {a eval dodel} msg] $msg
    } {1 {attempt to call eval in deleted interpreter}}
    test interp-18.8 {eval in deleted interp} {
	catch {interp delete a}
	interp create a
	a eval {
	    interp create b
	    b eval {
		proc dodel {} {
		    dela
		}
	    }
	    proc foo {} {
		b eval dela
		dosomething else
	    }
	    proc dosomething args {
		puts "I should not have been called!!"
	    }
	}
	interp alias {a b} dela {} dela
	proc dela {} {interp delete a}
	list [catch {a eval foo} msg] $msg
    } {1 {attempt to call eval in deleted interpreter}}
}

# Test alias deletion

test interp-19.1 {alias deletion} {
    catch {interp delete a}
    interp create a
    interp alias a foo a bar
    set s [interp alias a foo {}]
    interp delete a
    set s
} {}
test interp-19.2 {alias deletion} {
    catch {interp delete a}
    interp create a
    catch {interp alias a foo {}} msg
    interp delete a
    set msg
} {alias "foo" not found}
test interp-19.3 {alias deletion} {
    catch {interp delete a}
    interp create a
    interp alias a foo a bar
    interp eval a {rename foo zop}
    interp alias a foo a zop
    catch {interp eval a foo} msg
    interp delete a
    set msg
} {invalid command name "zop"}
test interp-19.4 {alias deletion} {
    catch {interp delete a}
    interp create a
    interp alias a foo a bar
    interp eval a {rename foo zop}
    catch {interp eval a foo} msg
    interp delete a
    set msg
} {invalid command name "foo"}
test interp-19.5 {alias deletion} {
    catch {interp delete a}
    interp create a
    interp eval a {proc bar {} {return 1}}
    interp alias a foo a bar
    interp eval a {rename foo zop}
    catch {interp eval a zop} msg
    interp delete a
    set msg
} 1
test interp-19.6 {alias deletion} {
    catch {interp delete a}
    interp create a
    interp alias a foo a bar
    interp eval a {rename foo zop}
    interp alias a foo a zop
    set s [interp aliases a]
    interp delete a
    set s
} foo
test interp-19.7 {alias deletion, renaming} {
    catch {interp delete a}
    interp create a
    interp alias a foo a bar
    interp eval a rename foo blotz
    interp alias a foo {}
    set s [interp aliases a]
    interp delete a
    set s
} {}
test interp-19.8 {alias deletion, renaming} {
    catch {interp delete a}
    interp create a
    interp alias a foo a bar
    interp eval a rename foo blotz
    set l ""
    lappend l [interp aliases a]
    interp alias a foo {}
    lappend l [interp aliases a]
    interp delete a
    set l
} {foo {}}
test interp-19.9 {alias deletion, renaming} {
    catch {interp delete a}
    interp create a
    interp alias a foo a bar
    interp eval a rename foo blotz
    interp eval a {proc foo {} {expr 34 * 34}}
    interp alias a foo {}
    set l [interp eval a foo]
    interp delete a
    set l
} 1156    

test interp-20.1 {interp hide, interp expose and interp invokehidden} {
    catch {interp delete a}
    interp create a
    a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
    a eval {proc foo {} {}}
    a hide foo
    catch {a eval foo something} msg
    interp delete a
    set msg
} {invalid command name "foo"}
test interp-20.2 {interp hide, interp expose and interp invokehidden} {
    catch {interp delete a}
    interp create a
    a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
    a hide list
    set l ""
    lappend l [catch {a eval {list 1 2 3}} msg]
    lappend l $msg
    a expose list
    lappend l [catch {a eval {list 1 2 3}} msg]
    lappend l $msg
    interp delete a
    set l
} {1 {invalid command name "list"} 0 {1 2 3}}
test interp-20.3 {interp hide, interp expose and interp invokehidden} {
    catch {interp delete a}
    interp create a
    a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
    a hide list
    set l ""
    lappend l [catch {a eval {list 1 2 3}} msg]
    lappend l $msg
    lappend l [catch {a invokehidden list 1 2 3} msg]
    lappend l $msg
    a expose list
    lappend l [catch {a eval {list 1 2 3}} msg]
    lappend l $msg
    interp delete a
    set l
} {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}}
test interp-20.4 {interp hide, interp expose and interp invokehidden -- passing {}} {
    catch {interp delete a}
    interp create a
    a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
    a hide list
    set l ""
    lappend l [catch {a eval {list 1 2 3}} msg]
    lappend l $msg
    lappend l [catch {a invokehidden list {"" 1 2 3}} msg]
    lappend l $msg
    a expose list
    lappend l [catch {a eval {list 1 2 3}} msg]
    lappend l $msg
    interp delete a
    set l
} {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}}
test interp-20.5 {interp hide, interp expose and interp invokehidden -- passing {}} {
    catch {interp delete a}
    interp create a
    a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
    a hide list
    set l ""
    lappend l [catch {a eval {list 1 2 3}} msg]
    lappend l $msg
    lappend l [catch {a invokehidden list {{} 1 2 3}} msg]
    lappend l $msg
    a expose list
    lappend l [catch {a eval {list 1 2 3}} msg]
    lappend l $msg
    interp delete a
    set l
} {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}}
test interp-20.6 {interp invokehidden -- eval args} {
    catch {interp delete a}
    interp create a
    a hide list
    set l ""
    set z 45
    lappend l [catch {a invokehidden list $z 1 2 3} msg]