1# Functionality covered: this file contains a collection of tests for the auto 2# loading and namespaces. 3# 4# Sourcing this file into Tcl runs the tests and generates output for errors. 5# No output means no errors were found. 6# 7# Copyright © 1997 Sun Microsystems, Inc. 8# Copyright © 1998-1999 Scriptics Corporation. 9# 10# See the file "license.terms" for information on usage and redistribution of 11# this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 13if {"::tcltest" ni [namespace children]} { 14 package require tcltest 2.5 15 namespace import -force ::tcltest::* 16} 17 18# Clear out any namespaces called test_ns_* 19catch {namespace delete {*}[namespace children :: test_ns_*]} 20 21test init-0.1 {no error on initialization phase (init.tcl)} -setup { 22 interp create child 23} -body { 24 child eval { 25 list [set v [info exists ::errorInfo]] \ 26 [if {$v} {set ::errorInfo}] \ 27 [set v [info exists ::errorCode]] \ 28 [if {$v} {set ::errorCode}] 29 } 30} -cleanup { 31 interp delete child 32} -result {0 {} 0 {}} 33 34# Six cases - white box testing 35 36test init-1.1 {auto_qualify - absolute cmd - namespace} { 37 auto_qualify ::foo::bar ::blue 38} ::foo::bar 39test init-1.2 {auto_qualify - absolute cmd - global} { 40 auto_qualify ::global ::sub 41} global 42test init-1.3 {auto_qualify - no colons cmd - global} { 43 auto_qualify nocolons :: 44} nocolons 45test init-1.4 {auto_qualify - no colons cmd - namespace} { 46 auto_qualify nocolons ::sub 47} {::sub::nocolons nocolons} 48test init-1.5 {auto_qualify - colons in cmd - global} { 49 auto_qualify foo::bar :: 50} ::foo::bar 51test init-1.6 {auto_qualify - colons in cmd - namespace} { 52 auto_qualify foo::bar ::sub 53} {::sub::foo::bar ::foo::bar} 54# Some additional tests 55test init-1.7 {auto_qualify - multiples colons 1} { 56 auto_qualify :::foo::::bar ::blue 57} ::foo::bar 58test init-1.8 {auto_qualify - multiple colons 2} { 59 auto_qualify :::foo ::bar 60} foo 61 62# We use a child interp and auto_reset and double the tests because there is 2 63# places where auto_loading occur (before loading the indexes files and after) 64 65set testInterp [interp create] 66tcltest::loadIntoChildInterpreter $testInterp {*}$argv 67interp eval $testInterp { 68 namespace import -force ::tcltest::* 69 customMatch pairwise {apply {{mode pair} { 70 if {[llength $pair] != 2} {error "need a pair of values to check"} 71 string $mode [lindex $pair 0] [lindex $pair 1] 72 }}} 73 74 auto_reset 75 catch {rename parray {}} 76 77test init-2.0 {load parray - stage 1} -body { 78 parray 79} -returnCodes error -cleanup { 80 rename parray {} ;# remove it, for the next test - that should not fail. 81} -result {wrong # args: should be "parray a ?pattern?"} 82test init-2.1 {load parray - stage 2} -body { 83 parray 84} -returnCodes error -result {wrong # args: should be "parray a ?pattern?"} 85auto_reset 86catch {rename ::safe::setLogCmd {}} 87#unset -nocomplain auto_index(::safe::setLogCmd) auto_oldpath 88test init-2.2 {load ::safe::setLogCmd - stage 1} { 89 ::safe::setLogCmd 90 rename ::safe::setLogCmd {} ;# should not fail 91} {} 92test init-2.3 {load ::safe::setLogCmd - stage 2} { 93 ::safe::setLogCmd 94 rename ::safe::setLogCmd {} ;# should not fail 95} {} 96auto_reset 97catch {rename ::safe::setLogCmd {}} 98test init-2.4 {load safe:::setLogCmd - stage 1} { 99 safe:::setLogCmd ;# intentionally 3 : 100 rename ::safe::setLogCmd {} ;# should not fail 101} {} 102test init-2.5 {load safe:::setLogCmd - stage 2} { 103 safe:::setLogCmd ;# intentionally 3 : 104 rename ::safe::setLogCmd {} ;# should not fail 105} {} 106auto_reset 107catch {rename ::safe::setLogCmd {}} 108test init-2.6 {load setLogCmd from safe:: - stage 1} { 109 namespace eval safe setLogCmd 110 rename ::safe::setLogCmd {} ;# should not fail 111} {} 112test init-2.7 {oad setLogCmd from safe:: - stage 2} { 113 namespace eval safe setLogCmd 114 rename ::safe::setLogCmd {} ;# should not fail 115} {} 116test init-2.8 {load tcl::HistAdd} -setup { 117 auto_reset 118 catch {rename ::tcl::HistAdd {}} 119} -body { 120 # 3 ':' on purpose 121 tcl:::HistAdd 122} -returnCodes error -cleanup { 123 rename ::tcl::HistAdd {} 124} -result {wrong # args: should be "tcl:::HistAdd event ?exec?"} 125 126test init-3.0 {random stuff in the auto_index, should still work} { 127 set auto_index(foo:::bar::blah) { 128 namespace eval foo {namespace eval bar {proc blah {} {return 1}}} 129 } 130 foo:::bar::blah 131} 1 132 133# Tests that compare the error stack trace generated when autoloading with 134# that generated when no autoloading is necessary. Ideally they should be the 135# same. 136 137set count 0 138foreach arg [subst -nocommands -novariables { 139 c 140 {argument 141 which spans 142 multiple lines} 143 {argument which is all on one line but which is of such great length that the Tcl C library will truncate it when appending it onto the global error stack} 144 {argument which spans multiple lines 145 and is long enough to be truncated and 146" <- includes a false lead in the prune point search 147 and must be longer still to force truncation} 148 {contrived example: rare circumstance 149 where the point at which to prune the 150 error stack cannot be uniquely determined. 151 foo bar foo 152"} 153 {contrived example: rare circumstance 154 where the point at which to prune the 155 error stack cannot be uniquely determined. 156 foo bar 157"} 158 {argument that contains non-ASCII character, €, and which is of such great length that it will be longer than 150 bytes so it will be truncated by the Tcl C library} 159 }] { ;# emacs needs -> " 160 161 test init-4.$count.0 {::errorInfo produced by [unknown]} -setup { 162 auto_reset 163 } -body { 164 catch {parray a b $arg} 165 set first $::errorInfo 166 catch {parray a b $arg} 167 list $first $::errorInfo 168 } -match pairwise -result equal 169 test init-4.$count.1 {::errorInfo produced by [unknown]} -setup { 170 auto_reset 171 } -body { 172 namespace eval junk [list array set $arg [list 1 2 3 4]] 173 trace variable ::junk::$arg r \ 174 "[list error [subst {Variable \"$arg\" is write-only}]] ;# " 175 catch {parray ::junk::$arg} 176 set first $::errorInfo 177 catch {parray ::junk::$arg} 178 list $first $::errorInfo 179 } -match pairwise -result equal 180 181 incr count 182} 183 184test init-4.$count {[Bug 46f801ed5a]} -setup { 185 auto_reset 186 array set auto_index {demo {proc demo {} {tailcall error foo}}} 187} -body { 188 demo 189} -cleanup { 190 array unset auto_index demo 191 rename demo {} 192} -returnCodes error -result foo 193 194test init-5.0 {return options passed through ::unknown} -setup { 195 catch {rename xxx {}} 196 set ::auto_index(::xxx) {proc ::xxx {} { 197 return -code error -level 2 xxx 198 }} 199} -body { 200 set code [catch {::xxx} foo bar] 201 set code2 [catch {::xxx} foo2 bar2] 202 list $code $foo $bar $code2 $foo2 $bar2 203} -cleanup { 204 unset ::auto_index(::xxx) 205} -match glob -result {2 xxx {-errorcode NONE -code 1 -level 1} 2 xxx {-code 1 -level 1 -errorcode NONE}} 206 207cleanupTests 208} ;# End of [interp eval $testInterp] 209 210# cleanup 211interp delete $testInterp 212::tcltest::cleanupTests 213return 214 215# Local Variables: 216# mode: tcl 217# fill-column: 78 218# End: 219