util/src/TclTk/tcl8.6.12/tests/init.test

   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 (c) 1997 Sun Microsystems, Inc.
   8 # Copyright (c) 1998-1999 by 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
  13 if {"::tcltest" ni [namespace children]} {
  14     package require tcltest 2.3.4
  15     namespace import -force ::tcltest::*
  16 }
  17
  18 # Clear out any namespaces called test_ns_*
  19 catch {namespace delete {*}[namespace children :: test_ns_*]}
  20 \f
  21 test 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
  36 test init-1.1 {auto_qualify - absolute cmd - namespace} {
  37     auto_qualify ::foo::bar ::blue
  38 } ::foo::bar
  39 test init-1.2 {auto_qualify - absolute cmd - global} {
  40     auto_qualify ::global ::sub
  41 } global
  42 test init-1.3 {auto_qualify - no colons cmd - global} {
  43     auto_qualify nocolons ::
  44 } nocolons
  45 test init-1.4 {auto_qualify - no colons cmd - namespace} {
  46     auto_qualify nocolons ::sub
  47 } {::sub::nocolons nocolons}
  48 test init-1.5 {auto_qualify - colons in cmd - global} {
  49     auto_qualify foo::bar ::
  50 } ::foo::bar
  51 test 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
  55 test init-1.7 {auto_qualify - multiples colons 1} {
  56     auto_qualify :::foo::::bar ::blue
  57 } ::foo::bar
  58 test init-1.8 {auto_qualify - multiple colons 2} {
  59     auto_qualify :::foo ::bar
  60 } foo
  61 \f
  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
  65 set testInterp [interp create]
  66 tcltest::loadIntoChildInterpreter $testInterp {*}$argv
  67 interp 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 \f
  77 test 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?"}
  82 test init-2.1 {load parray - stage 2} -body {
  83     parray
  84 } -returnCodes error -result {wrong # args: should be "parray a ?pattern?"}
  85 auto_reset
  86 catch {rename ::safe::setLogCmd {}}
  87 #unset -nocomplain auto_index(::safe::setLogCmd) auto_oldpath
  88 test init-2.2 {load ::safe::setLogCmd - stage 1} {
  89     ::safe::setLogCmd
  90     rename ::safe::setLogCmd {}  ;# should not fail
  91 } {}
  92 test init-2.3 {load ::safe::setLogCmd - stage 2} {
  93     ::safe::setLogCmd
  94     rename ::safe::setLogCmd {}  ;# should not fail
  95 } {}
  96 auto_reset
  97 catch {rename ::safe::setLogCmd {}}
  98 test init-2.4 {load safe:::setLogCmd - stage 1} {
  99     safe:::setLogCmd  ;# intentionally 3 :
 100     rename ::safe::setLogCmd {}  ;# should not fail
 101 } {}
 102 test init-2.5 {load safe:::setLogCmd - stage 2} {
 103     safe:::setLogCmd  ;# intentionally 3 :
 104     rename ::safe::setLogCmd {}  ;# should not fail
 105 } {}
 106 auto_reset
 107 catch {rename ::safe::setLogCmd {}}
 108 test init-2.6 {load setLogCmd from safe:: - stage 1} {
 109     namespace eval safe setLogCmd
 110     rename ::safe::setLogCmd {}  ;# should not fail
 111 } {}
 112 test init-2.7 {oad setLogCmd from safe::  - stage 2} {
 113     namespace eval safe setLogCmd
 114     rename ::safe::setLogCmd {}  ;# should not fail
 115 } {}
 116 test 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
 126 test 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
 137 set count 0
 138 foreach 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, \u20ac, 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
 184 test 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
 194 test 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 \f
 207 cleanupTests
 208 }       ;#  End of [interp eval $testInterp]
 209
 210 # cleanup
 211 interp delete $testInterp
 212 ::tcltest::cleanupTests
 213 return
 214
 215 # Local Variables:
 216 # mode: tcl
 217 # fill-column: 78
 218 # End: