diff options
Diffstat (limited to 'tests/basic.test')
| -rw-r--r-- | tests/basic.test | 533 |
1 files changed, 403 insertions, 130 deletions
diff --git a/tests/basic.test b/tests/basic.test index e769a00..91e4d6c 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -16,24 +16,19 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 -namespace import -force ::tcltest::* +namespace import ::tcltest::* +testConstraint testevalex [llength [info commands testevalex]] testConstraint testcmdtoken [llength [info commands testcmdtoken]] -testConstraint testcmdtrace [llength [info commands testcmdtrace]] testConstraint testcreatecommand [llength [info commands testcreatecommand]] -testConstraint testevalex [llength [info commands testevalex]] testConstraint exec [llength [info commands exec]] -# This variable needs to be changed when the major or minor version number for -# Tcl changes. -set tclvers 8.4 - catch {namespace delete test_ns_basic} catch {interp delete test_interp} catch {rename p ""} catch {rename q ""} catch {rename cmd ""} -catch {unset x} +unset -nocomplain x test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} { catch {interp delete test_interp} @@ -157,7 +152,7 @@ test basic-12.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespac [namespace delete test_ns_basic] } {:: {} 1 {invalid command name "cmd"} {} :: {}} -test basic-13.1 {Tcl_ExposeCommand, a command stays in the global namespace and can not go to another namespace} { +test basic-13.1 {Tcl_ExposeCommand, a command stays in the global namespace and cannot go to another namespace} { catch {namespace delete test_ns_basic} catch {rename cmd ""} proc cmd {} { ;# note that this is global @@ -184,7 +179,7 @@ test basic-13.1 {Tcl_ExposeCommand, a command stays in the global namespace and [test_ns_basic::exposeCmdWorkAround] \ [test_ns_basic::newCmd] \ [namespace delete test_ns_basic] -} {:: {} 1 {can not expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}} +} {:: {} 1 {cannot expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}} test basic-13.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} { catch {rename p ""} catch {rename cmd ""} @@ -204,13 +199,13 @@ test basic-13.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being expo } {42 {} {} Hello {} {} 42} test basic-14.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {testcreatecommand} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {*}[namespace children :: test_ns_*]} list [testcreatecommand create] \ [test_ns_basic::createdcommand] \ [testcreatecommand delete] } {{} {CreatedCommandProc in ::test_ns_basic} {}} test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} {testcreatecommand} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename value:at: ""} list [testcreatecommand create2] \ [value:at:] \ @@ -218,7 +213,7 @@ test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle } {{} {CreatedCommandProc2 in ::} {}} test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {*}[namespace children :: test_ns_*]} namespace eval test_ns_basic {} proc test_ns_basic::cmd {} { ;# proc requires that ns already exist return [namespace current] @@ -234,7 +229,7 @@ test basic-17.1 {TclInvokeObjCommand} {emptyTest} { } {} test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename cmd ""} namespace eval test_ns_basic { proc p {} { @@ -246,11 +241,11 @@ test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace quali [test_ns_basic::q] } {{p in ::test_ns_basic} {} {p in ::test_ns_basic}} test basic-18.2 {TclRenameCommand, existing cmd must be found} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {*}[namespace children :: test_ns_*]} list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg } {1 {can't rename "test_ns_basic::p": command doesn't exist}} test basic-18.3 {TclRenameCommand, delete cmd if new name is empty} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {*}[namespace children :: test_ns_*]} namespace eval test_ns_basic { proc p {} { return "p in [namespace current]" @@ -261,7 +256,7 @@ test basic-18.3 {TclRenameCommand, delete cmd if new name is empty} { [info commands test_ns_basic::*] } {::test_ns_basic::p {} {}} test basic-18.4 {TclRenameCommand, bad new name} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {*}[namespace children :: test_ns_*]} namespace eval test_ns_basic { proc p {} { return "p in [namespace current]" @@ -269,16 +264,26 @@ test basic-18.4 {TclRenameCommand, bad new name} { } rename test_ns_basic::p :::george::martha } {} -test basic-18.5 {TclRenameCommand, new name must not already exist} { +test basic-18.5 {TclRenameCommand, new name must not already exist} -setup { + if {![llength [info commands :::george::martha]]} { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_basic { + proc p {} { + return "p in [namespace current]" + } + } + rename test_ns_basic::p :::george::martha + } +} -body { namespace eval test_ns_basic { proc q {} { return 42 } } list [catch {rename test_ns_basic::q :::george::martha} msg] $msg -} {1 {can't rename to ":::george::martha": command already exists}} +} -result {1 {can't rename to ":::george::martha": command already exists}} test basic-18.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename q ""} proc p {} { @@ -301,10 +306,10 @@ test basic-19.1 {Tcl_SetCommandInfo} {emptyTest} { } {} test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {testcmdtoken} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename q ""} - catch {unset x} + unset -nocomplain x set x [namespace eval test_ns_basic::test_ns_basic2 { # the following creates a cmd in the global namespace testcmdtoken create p @@ -320,12 +325,17 @@ test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespac [rename test_ns_basic::test_ns_basic2::p q] \ [testcmdtoken name $x] } {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}} +test basic-20.3 {Tcl_GetCommandInfo, #-quoting} testcmdtoken { + catch {rename \# ""} + set x [testcmdtoken create \#] + testcmdtoken name $x +} {{#} ::#} test basic-21.1 {Tcl_GetCommandName} {emptyTest} { } {} test basic-22.1 {Tcl_GetCommandFullName} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {*}[namespace children :: test_ns_*]} namespace eval test_ns_basic1 { namespace export cmd* proc cmd1 {} {} @@ -352,7 +362,7 @@ 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} + unset -nocomplain x interp create test_interp interp eval test_interp { proc useSet {} { @@ -371,7 +381,7 @@ test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd [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 {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} proc p {} { return "global p" @@ -389,7 +399,7 @@ test basic-24.2 {Tcl_DeleteCommandFromToken, deleting commands changes command e [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 {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} namespace eval test_ns_basic { namespace export p @@ -411,31 +421,38 @@ test basic-24.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to test basic-25.1 {TclCleanupCommand} {emptyTest} { } {} -test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} { +test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} -setup { + proc myHandler {msg options} { + set ::x [dict get $options -errorinfo] + } + set handler [interp bgerror {}] + interp bgerror {} [namespace which myHandler] + set fName [makeFile {} test1] +} -body { # 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" + chan event $f writable "chan event $f writable {}; error foo" set x {} vwait x close $f - removeFile test1 - rename bgerror {} set x -} "foo\n while executing\n\"error foo\"" +} -cleanup { + removeFile test1 + interp bgerror {} $handler + rename myHandler {} +} -result "foo\n while executing\n\"error foo\"" -test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} { +test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body { # # Follow the pure-list branch in a manner that # a - the pure-list internal rep is destroyed by shimmering # b - the command returns an error # As the error code in Tcl_EvalObjv accesses the list elements, this will - # cause a segfault if [Bug 1119369] has not been fixed. + # cause a segfault if [Bug 1119369] has not been fixed. + # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault. # set SRC [list foo 1] ;# pure-list command @@ -445,7 +462,33 @@ test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} { error "BAD CALL" } catch {eval $SRC} -} 1 +} -result 1 -cleanup { + rename foo {} + rename $::SRC {} + unset ::SRC +} + +test basic-26.3 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body { + # + # Follow the pure-list branch in a manner that + # a - the pure-list internal rep is destroyed by shimmering + # b - the command accesses its command line + # This will cause a segfault if [Bug 1119369] has not been fixed. + # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault. + # + + set SRC [list foo 1] ;# pure-list command + proc foo str { + # Shimmer pure-list to cmdName, cleanup and error + proc $::SRC {} {}; $::SRC + info level 0 + } + catch {eval $SRC} +} -result 0 -cleanup { + rename foo {} + rename $::SRC {} + unset ::SRC +} test basic-27.1 {Tcl_ExprLong} {emptyTest} { } {} @@ -465,17 +508,8 @@ 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_*]} +test basic-36.1 {Tcl_EvalObjv, lookup of "unknown" command} { + catch {namespace delete {*}[namespace children :: test_ns_*]} catch {interp delete test_interp} interp create test_interp interp eval test_interp { @@ -499,75 +533,7 @@ 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-39.10 {Tcl_CreateTrace, correct level interpretation} {testcmdtrace} { - proc foo {} {uplevel 1 bar} - proc bar {} {uplevel 1 grok} - proc grok {} {uplevel 1 spock} - proc spock {} {uplevel 1 fascinating} - proc fascinating {} {} - testcmdtrace leveltest {foo} -} {foo {foo} {uplevel 1 bar} {uplevel 1 bar} bar {bar} {uplevel 1 grok} {uplevel 1 grok}} - -test basic-39.11 {Tcl_CreateTrace, multiple traces} {testcmdtrace} { - testcmdtrace doubletest {format xx} -} {{format xx} {format xx}} - -test basic-40.1 {Tcl_DeleteTrace} {emptyTest} { - # the above tests have tested Tcl_DeleteTrace -} {} +# Tests basic-39.* and basic-40.* refactored into trace.test test basic-41.1 {Tcl_AddErrorInfo} {emptyTest} { } {} @@ -588,10 +554,10 @@ 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} + chan configure $f -buffering line + puts $f {chan configure stdout -buffering line} puts $f continue - puts $f {puts $errorInfo} + puts $f {puts $::errorInfo} puts $f {puts DONE} set newMsg {} set msg {} @@ -676,34 +642,341 @@ test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -body { subst {a[set b [format cd]} } -returnCodes error -result {missing close-bracket} +# Some lists for expansion tests to work with +set l1 [list a {b b} c d] +set l2 [list e f {g g} h] +proc l3 {} { + list i j k {l l} +} + +# Do all tests once byte compiled and once with direct string evaluation +for {set noComp 0} {$noComp <= 1} {incr noComp} { + +if $noComp { + interp alias {} run {} testevalex + set constraints testevalex +} else { + interp alias {} run {} if 1 + set constraints {} +} + +test basic-47.2.$noComp {Tcl_EvalEx: error during word expansion} -body { + run {{*}\{} +} -constraints $constraints -returnCodes error -result {unmatched open brace in list} + +test basic-47.3.$noComp {Tcl_EvalEx, error during substitution} -body { + run {{*}[error foo]} +} -constraints $constraints -returnCodes error -result foo + +test basic-47.4.$noComp {Tcl_EvalEx: no expansion} $constraints { + run {list {*} {*} {*}} +} {* * *} + +test basic-47.5.$noComp {Tcl_EvalEx: expansion} $constraints { + run {list {*}{} {*} {*}x {*}"y z"} +} {* x y z} + +test basic-47.6.$noComp {Tcl_EvalEx: expansion to zero args} $constraints { + run {list {*}{}} +} {} + +test basic-47.7.$noComp {Tcl_EvalEx: expansion to one arg} $constraints { + run {list {*}x} +} x + +test basic-47.8.$noComp {Tcl_EvalEx: expansion to many args} $constraints { + run {list {*}"y z"} +} {y z} + +test basic-47.9.$noComp {Tcl_EvalEx: expansion and subst order} $constraints { + set x 0 + run {list [incr x] {*}[incr x] [incr x] \ + {*}[list [incr x] [incr x]] [incr x]} +} {1 2 3 4 5 6} + +test basic-47.10.$noComp {Tcl_EvalEx: expand and memory management} $constraints { + run {concat {*}{} a b c d e f g h i j k l m n o p q r} +} {a b c d e f g h i j k l m n o p q r} + +test basic-47.11.$noComp {Tcl_EvalEx: expand and memory management} $constraints { + run {concat {*}1 a b c d e f g h i j k l m n o p q r} +} {1 a b c d e f g h i j k l m n o p q r} + +test basic-47.12.$noComp {Tcl_EvalEx: expand and memory management} $constraints { + run {concat {*}{1 2} a b c d e f g h i j k l m n o p q r} +} {1 2 a b c d e f g h i j k l m n o p q r} + +test basic-47.13.$noComp {Tcl_EvalEx: expand and memory management} $constraints { + run {concat {*}{} {*}{1 2} a b c d e f g h i j k l m n o p q} +} {1 2 a b c d e f g h i j k l m n o p q} + +test basic-47.14.$noComp {Tcl_EvalEx: expand and memory management} $constraints { + run {concat {*}{} a b c d e f g h i j k l m n o p q r s} +} {a b c d e f g h i j k l m n o p q r s} + +test basic-47.15.$noComp {Tcl_EvalEx: expand and memory management} $constraints { + run {concat {*}1 a b c d e f g h i j k l m n o p q r s} +} {1 a b c d e f g h i j k l m n o p q r s} + +test basic-47.16.$noComp {Tcl_EvalEx: expand and memory management} $constraints { + run {concat {*}{1 2} a b c d e f g h i j k l m n o p q r s} +} {1 2 a b c d e f g h i j k l m n o p q r s} + +test basic-47.17.$noComp {Tcl_EvalEx: expand and memory management} $constraints { + run {concat {*}{} {*}{1 2} a b c d e f g h i j k l m n o p q r} +} {1 2 a b c d e f g h i j k l m n o p q r} + +test basic-48.1.$noComp {expansion: parsing} $constraints { + run { # A comment + + # Another comment + list 1 2\ + 3 {*}$::l1 + + # Comment again + } +} {1 2 3 a {b b} c d} + +test basic-48.2.$noComp {no expansion} $constraints { + run {list $::l1 $::l2 [l3]} +} {{a {b b} c d} {e f {g g} h} {i j k {l l}}} + +test basic-48.3.$noComp {expansion} $constraints { + run {list {*}$::l1 $::l2 {*}[l3]} +} {a {b b} c d {e f {g g} h} i j k {l l}} + +test basic-48.4.$noComp {expansion: really long cmd} $constraints { + set cmd [list list] + for {set t 0} {$t < 500} {incr t} { + lappend cmd {{*}$::l1} + } + llength [run [join $cmd]] +} 2000 + +test basic-48.5.$noComp {expansion: error detection} -setup { + set l "a {a b}x y" +} -constraints $constraints -body { + run {list $::l1 {*}$l} +} -cleanup { + unset l +} -returnCodes 1 -result {list element in braces followed by "x" instead of space} + +test basic-48.6.$noComp {expansion: odd usage} $constraints { + run {list {*}$::l1$::l2} +} {a {b b} c de f {g g} h} + +test basic-48.7.$noComp {expansion: odd usage} -constraints $constraints -body { + run {list {*}[l3]$::l1} +} -returnCodes 1 -result {list element in braces followed by "a" instead of space} + +test basic-48.8.$noComp {expansion: odd usage} $constraints { + run {list {*}hej$::l1} +} {heja {b b} c d} + +test basic-48.9.$noComp {expansion: Not all {*} should trigger} $constraints { + run {list {*}$::l1 \{*\}$::l2 "{*}$::l1" {{*} i j k}} +} {a {b b} c d {{*}e f {g g} h} {{*}a {b b} c d} {{*} i j k}} + +test basic-48.10.$noComp {expansion: expansion of command word} -setup { + set cmd [list string range jultomte] +} -constraints $constraints -body { + run {{*}$cmd 2 6} +} -cleanup { + unset cmd +} -result ltomt + +test basic-48.11.$noComp {expansion: expansion into nothing} -setup { + set cmd {} + set bar {} +} -constraints $constraints -body { + run {{*}$cmd {*}$bar} +} -cleanup { + unset cmd bar +} -result {} + +test basic-48.12.$noComp {expansion: odd usage} $constraints { + run {list {*}$::l1 {*}"hej hopp" {*}$::l2} +} {a {b b} c d hej hopp e f {g g} h} + +test basic-48.13.$noComp {expansion: odd usage} $constraints { + run {list {*}$::l1 {*}{hej hopp} {*}$::l2} +} {a {b b} c d hej hopp e f {g g} h} + +test basic-48.14.$noComp {expansion: hash command} -setup { + catch {rename \# ""} + set cmd "#" + } -constraints $constraints -body { + run { {*}$cmd apa bepa } + } -cleanup { + unset cmd +} -returnCodes 1 -result {invalid command name "#"} + +test basic-48.15.$noComp {expansion: complex words} -setup { + set a(x) [list a {b c} d e] + set b x + set c [list {f\ g h\ i j k} x y] + set d {0\ 1 2 3} + } -constraints $constraints -body { + run { lappend d {*}$a($b) {*}[lindex $c 0] } + } -cleanup { + unset a b c d +} -result {{0 1} 2 3 a {b c} d e {f g} {h i} j k} + +testConstraint memory [llength [info commands memory]] +test basic-48.16.$noComp {expansion: testing for leaks} -setup { + proc getbytes {} { + set lines [split [memory info] "\n"] + lindex [lindex $lines 3] 3 + } + # This test is made to stress the allocation, reallocation and + # object reference management in Tcl_EvalEx. + proc stress {} { + set a x + # Create free objects that should disappear + set l [list 1$a 2$a 3$a 4$a 5$a 6$a 7$a] + # A short number of words and a short result (8) + set l [run {list {*}$l $a$a}] + # A short number of words and a longer result (27) + set l [run {list {*}$l $a$a {*}$l $a$a {*}$l $a$a}] + # A short number of words and a longer result, with an error + # This is to stress the cleanup in the error case + if {![catch {run {_moo_ {*}$l $a$a {*}$l $a$a {*}$l}}]} { + error "An error was expected in the previous statement" + } + # Many words + set l [run {list {*}$l $a$a {*}$l $a$a \ + {*}$l $a$a {*}$l $a$a \ + {*}$l $a$a {*}$l $a$a \ + {*}$l $a$a {*}$l $a$a \ + {*}$l $a$a {*}$l $a$a \ + {*}$l $a$a {*}$l $a$a \ + {*}$l $a$a {*}$l $a$a \ + {*}$l $a$a {*}$l $a$a \ + {*}$l $a$a {*}$l $a$a \ + {*}$l $a$a}] + + if {[llength $l] != 19*28} { + error "Bad Length: [llength $l] should be [expr {19*28}]" + } + } + } -constraints [linsert $constraints 0 memory] -body { + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + stress + set tmp $end + set end [getbytes] + } + set leak [expr {$end - $tmp}] + } -cleanup { + unset end i tmp + rename getbytes {} + rename stress {} +} -result 0 + +test basic-48.17.$noComp {expansion: object safety} -setup { + set old_precision $::tcl_precision + set ::tcl_precision 4 + } -constraints $constraints -body { + set third [expr {1.0/3.0}] + set l [list $third $third] + set x [run {list $third {*}$l $third}] + set res [list] + foreach t $x { + lappend res [expr {$t * 3.0}] + } + set res + } -cleanup { + set ::tcl_precision $old_precision + unset old_precision res t l x third +} -result {1.0 1.0 1.0 1.0} + +test basic-48.18.$noComp {expansion: list semantics} -constraints $constraints -body { + set badcmd { + list a b + set apa 10 + } + set apa 0 + list [llength [run { {*}$badcmd }]] $apa + } -cleanup { + unset apa badcmd +} -result {5 0} + +test basic-48.19.$noComp {expansion: error checking order} -body { + set badlist "a {}x y" + set a 0 + set b 0 + catch {run {list [incr a] {*}$badlist [incr b]}} + list $a $b + } -constraints $constraints -cleanup { + unset badlist a b +} -result {1 0} + +test basic-48.20.$noComp {expansion: odd case with word boundaries} $constraints { + run {list {*}$::l1 {*}"hej hopp" {*}$::l2} +} {a {b b} c d hej hopp e f {g g} h} + +test basic-48.21.$noComp {expansion: odd case with word boundaries} $constraints { + run {list {*}$::l1 {*}{hej hopp} {*}$::l2} +} {a {b b} c d hej hopp e f {g g} h} + +test basic-48.22.$noComp {expansion: odd case with word boundaries} -body { + run {list {*}$::l1 {*}"hej hopp {*}$::l2} +} -constraints $constraints -returnCodes error -result {missing "} + +test basic-48.23.$noComp {expansion: handle return codes} -constraints $constraints -body { + set res {} + for {set t 0} {$t < 10} {incr t} { + run { {*}break } + } + lappend res $t + + for {set t 0} {$t < 10} {incr t} { + run { {*}continue } + set t 20 + } + lappend res $t + + lappend res [catch { run { {*}{error Hejsan} } } err] + lappend res $err + } -cleanup { + unset res t +} -result {0 10 1 Hejsan} + +} ;# End of noComp loop + test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex { set ::x global namespace eval ns { - variable x namespace - testevalex {set x changed} global - set ::result [list $::x $x] - } + variable x namespace + testevalex {set x changed} global + set ::result [list $::x $x] + } namespace delete ns set ::result } {changed namespace} test basic-49.2 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex { set ::x global namespace eval ns { - variable x namespace - testevalex {set ::context $x} global + variable x namespace + testevalex {set ::context $x} global } namespace delete ns set ::context } {global} -# cleanup -catch {eval namespace delete [namespace children :: test_ns_*]} +# Clean up after expand tests +unset noComp l1 l2 constraints +rename l3 {} +rename run {} + + #cleanup +catch {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 +unset -nocomplain x +cleanupTests return |