basic.test

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

    catch {eval namespace delete [namespace children :: test_ns_*]}
    namespace eval test_ns_basic1 {
        namespace export cmd*
        proc cmd1 {} {}
        proc cmd2 {} {}
    }
    namespace eval test_ns_basic2 {
        namespace export *
        namespace import ::test_ns_basic1::*
        proc p {} {}
    }
    namespace eval test_ns_basic3 {
        namespace import ::test_ns_basic2::*
        proc q {} {}
        list [namespace which -command foreach] \
             [namespace which -command q] \
             [namespace which -command p] \
             [namespace which -command cmd1] \
             [namespace which -command ::test_ns_basic2::cmd2]
    }
} {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2}

test basic-23.1 {Tcl_DeleteCommand} {emptyTest} {
} {}

test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} {
    catch {interp delete test_interp}
    catch {unset x}
    interp create test_interp
    interp eval test_interp {
        proc useSet {} {
            return [set a 123]
        }
    }
    set x [interp eval test_interp {useSet}]
    interp eval test_interp {
        rename set ""
        proc set {args} {
            return "set called with $args"
        }
    }
    list $x \
         [interp eval test_interp {useSet}] \
         [interp delete test_interp]
} {123 {set called with a 123} {}}
test basic-24.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    catch {rename p ""}
    proc p {} {
        return "global p"
    }
    namespace eval test_ns_basic {
        proc p {} {
            return "namespace p"
        }
        proc callP {} {
            p
        }
    }
    list [test_ns_basic::callP] \
         [rename test_ns_basic::p ""] \
         [test_ns_basic::callP]
} {{namespace p} {} {global p}}
test basic-24.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    catch {rename p ""}
    namespace eval test_ns_basic {
        namespace export p
        proc p {} {return 42}
    }
    namespace eval test_ns_basic2 {
        namespace import ::test_ns_basic::*
        proc callP {} {
            p
        }
    }
    list [test_ns_basic2::callP] \
         [info commands test_ns_basic2::*] \
         [rename test_ns_basic::p ""] \
         [catch {test_ns_basic2::callP} msg] $msg \
         [info commands test_ns_basic2::*]
} {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP}

test basic-25.1 {TclCleanupCommand} {emptyTest} {
} {}

test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} {
    # If object isn't preserved, errorInfo would be set to
    # "foo\n    while executing\n\"garbage bytes\"" because the object's
    # string would have been freed, leaving garbage bytes for the error
    # message.

    proc bgerror {args} {set ::x $::errorInfo}
    set fName [makeFile {} test1]
    set f [open $fName w]
    fileevent $f writable "fileevent $f writable {}; error foo"
    set x {}
    vwait x
    close $f
    removeFile test1
    rename bgerror {}
    set x
} "foo\n    while executing\n\"error foo\""

test basic-27.1 {Tcl_ExprLong} {emptyTest} {
} {}

test basic-28.1 {Tcl_ExprDouble} {emptyTest} {
} {}

test basic-29.1 {Tcl_ExprBoolean} {emptyTest} {
} {}

test basic-30.1 {Tcl_ExprLongObj} {emptyTest} {
} {}

test basic-31.1 {Tcl_ExprDoubleObj} {emptyTest} {
} {}

test basic-32.1 {Tcl_ExprBooleanObj} {emptyTest} {
} {}

test basic-33.1 {TclInvoke} {emptyTest} {
} {}

test basic-34.1 {TclGlobalInvoke} {emptyTest} {
} {}

test basic-35.1 {TclObjInvokeGlobal} {emptyTest} {
} {}

test basic-36.1 {TclObjInvoke, lookup of "unknown" command} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    catch {interp delete test_interp}
    interp create test_interp
    interp eval test_interp {
        proc unknown {args} {
            return "global unknown"
        }
        namespace eval test_ns_basic {
            proc unknown {args} {
                return "namespace unknown"
            }
        }
    }
    list [interp alias test_interp newAlias test_interp doesntExist] \
         [catch {interp eval test_interp {newAlias}} msg] $msg \
         [interp delete test_interp]
} {newAlias 0 {global unknown} {}}

test basic-37.1 {Tcl_ExprString: see expr.test} {emptyTest} {
} {}

test basic-38.1 {Tcl_ExprObj} {emptyTest} {
} {}

test basic-39.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
    testcmdtrace tracetest {set stuff [expr 14 + 16]}
} {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}}
test basic-39.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
    testcmdtrace tracetest {set stuff [info tclversion]}
} [list {info tclversion} {info tclversion} {set stuff [info tclversion]} "set stuff $tclvers"]
test basic-39.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
    testcmdtrace deletetest {set stuff [info tclversion]}
} $tclvers
test basic-39.4 {Tcl_CreateTrace, check that tracing doesn't cause memory faults} {testcmdtrace} {
    # Note that the proc call is the same as the variable name, and that
    # the call can be direct or indirect by way of another procedure
    proc tracer {args} {}
    proc tracedLoop {level} {
	incr level
	tracer
	foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}
    }
    testcmdtrace tracetest {tracedLoop 0}
} {{tracedLoop 0} {tracedLoop 0} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {1 2} {tracedLoop $level}} {tracedLoop $level} {tracedLoop 1} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {} {tracedLoop $level}} {tracedLoop $level} {tracedLoop 1} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {} {tracedLoop $level}}}
catch {rename tracer {}}
catch {rename tracedLoop {}}

test basic-39.5 {Tcl_CreateObjTrace, status return TCL_ERROR} {testcmdtrace} {
    proc Error { args } { error "Shouldn't get here" }
    set x 1;
    list [catch {testcmdtrace resulttest {Error $x}} result] [set result]
} {1 {Error $x}}

test basic-39.6 {Tcl_CreateObjTrace, status return TCL_RETURN} {testcmdtrace} {
    proc Return { args } { error "Shouldn't get here" }
    set x 1;
    list [catch {testcmdtrace resulttest {Return $x}} result] [set result]
} {2 {}}

test basic-39.7 {Tcl_CreateObjTrace, status return TCL_BREAK} {testcmdtrace} {
    proc Break { args } { error "Shouldn't get here" }
    set x 1;
    list [catch {testcmdtrace resulttest {Break $x}} result] [set result]
} {3 {}}

test basic-39.8 {Tcl_CreateObjTrace, status return TCL_CONTINUE} {testcmdtrace} {
    proc Continue { args } { error "Shouldn't get here" }
    set x 1;
    list [catch {testcmdtrace resulttest {Continue $x}} result] [set result]
} {4 {}}

test basic-39.9 {Tcl_CreateObjTrace, status return unknown} {testcmdtrace} {
    proc OtherStatus { args } { error "Shouldn't get here" }
    set x 1;
    list [catch {testcmdtrace resulttest {OtherStatus $x}} result] [set result]
} {6 {}}

test basic-40.1 {Tcl_DeleteTrace} {emptyTest} {
    # the above tests have tested Tcl_DeleteTrace
} {}

test basic-41.1 {Tcl_AddErrorInfo} {emptyTest} {
} {}

test basic-42.1 {Tcl_AddObjErrorInfo} {emptyTest} {
} {}

test basic-43.1 {Tcl_VarEval} {emptyTest} {
} {}

test basic-44.1 {Tcl_GlobalEval} {emptyTest} {
} {}

test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} {
} {}

test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} {
    catch {close $f}
    set res [catch {
	set f [open |[list [interpreter]] w+]
	fconfigure $f -buffering line
	puts $f {fconfigure stdout -buffering line}
	puts $f continue
	puts $f {puts $errorInfo}
	puts $f {puts DONE}
	set newMsg {}
	set msg {}
	while {$newMsg != "DONE"} {
	    set newMsg [gets $f]
	    append msg "${newMsg}\n"
	}
	close $f
    } error]
    list $res $msg
} {1 {invoked "continue" outside of a loop
    while executing
"continue
"
DONE
}}

test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} {exec} {
    set fName [makeFile {
	puts hello
	break
    } BREAKtest]
    set res [list [catch {exec [interpreter] $fName} msg] $msg]
    removeFile BREAKtest
    regsub {file ".*BREAKtest"} $res {file "BREAKtest"} res
    set res
} {1 {hello
invoked "break" outside of a loop
    while executing
"break"
    (file "BREAKtest" line 3)}}    

test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} {exec} {
    set fName [makeFile {
	interp alias {} patch {} info patchlevel
	patch
	break
    } BREAKtest]
    set res [list [catch {exec [interpreter] $fName} msg] $msg]
    removeFile BREAKtest
    regsub {file ".*BREAKtest"} $res {file "BREAKtest"} res
    set res
} {1 {invoked "break" outside of a loop
    while executing
"break"
    (file "BREAKtest" line 4)}}    

test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} {exec} {
    set fName [makeFile {
	foo [set a 1] [break]
    } BREAKtest]
    set res [list [catch {exec [interpreter] $fName} msg] $msg]
    removeFile BREAKtest
    regsub {file ".*BREAKtest"} $res {file "BREAKtest"} res
    set res
} {1 {invoked "break" outside of a loop
    while executing
"break"
    invoked from within
"foo [set a 1] [break]"
    (file "BREAKtest" line 2)}}

test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} {exec} {
    set fName [makeFile {
	return -code return
    } BREAKtest]
    set res [list [catch {exec [interpreter] $fName} msg] $msg]
    removeFile BREAKtest
    regsub {file ".*BREAKtest"} $res {file "BREAKtest"} res
    set res
} {1 {command returned bad code: 2
    while executing
"return -code return"
    (file "BREAKtest" line 2)}}

test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -body {
    subst {a[set b [format cd]}
} -returnCodes error -result {missing close-bracket}


# cleanup
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {namespace delete george}
catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
catch {rename value:at: ""}
catch {unset x}
::tcltest::cleanupTests
return