+++ /dev/null
-# Functionality covered: this file contains a collection of tests for the auto
-# loading and namespaces.
-#
-# Sourcing this file into Tcl runs the tests and generates output for errors.
-# No output means no errors were found.
-#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-
-if {"::tcltest" ni [namespace children]} {
- package require tcltest 2.3.4
- namespace import -force ::tcltest::*
-}
-
-# Clear out any namespaces called test_ns_*
-catch {namespace delete {*}[namespace children :: test_ns_*]}
-\f
-# Six cases - white box testing
-
-test init-1.1 {auto_qualify - absolute cmd - namespace} {
- auto_qualify ::foo::bar ::blue
-} ::foo::bar
-test init-1.2 {auto_qualify - absolute cmd - global} {
- auto_qualify ::global ::sub
-} global
-test init-1.3 {auto_qualify - no colons cmd - global} {
- auto_qualify nocolons ::
-} nocolons
-test init-1.4 {auto_qualify - no colons cmd - namespace} {
- auto_qualify nocolons ::sub
-} {::sub::nocolons nocolons}
-test init-1.5 {auto_qualify - colons in cmd - global} {
- auto_qualify foo::bar ::
-} ::foo::bar
-test init-1.6 {auto_qualify - colons in cmd - namespace} {
- auto_qualify foo::bar ::sub
-} {::sub::foo::bar ::foo::bar}
-# Some additional tests
-test init-1.7 {auto_qualify - multiples colons 1} {
- auto_qualify :::foo::::bar ::blue
-} ::foo::bar
-test init-1.8 {auto_qualify - multiple colons 2} {
- auto_qualify :::foo ::bar
-} foo
-\f
-# We use a sub-interp and auto_reset and double the tests because there is 2
-# places where auto_loading occur (before loading the indexes files and after)
-
-set testInterp [interp create]
-tcltest::loadIntoSlaveInterpreter $testInterp {*}$argv
-interp eval $testInterp {
- namespace import -force ::tcltest::*
- customMatch pairwise {apply {{mode pair} {
- if {[llength $pair] != 2} {error "need a pair of values to check"}
- string $mode [lindex $pair 0] [lindex $pair 1]
- }}}
-
- auto_reset
- catch {rename parray {}}
-\f
-test init-2.0 {load parray - stage 1} -body {
- parray
-} -returnCodes error -cleanup {
- rename parray {} ;# remove it, for the next test - that should not fail.
-} -result {wrong # args: should be "parray a ?pattern?"}
-test init-2.1 {load parray - stage 2} -body {
- parray
-} -returnCodes error -result {wrong # args: should be "parray a ?pattern?"}
-auto_reset
-catch {rename ::safe::setLogCmd {}}
-#unset -nocomplain auto_index(::safe::setLogCmd) auto_oldpath
-test init-2.2 {load ::safe::setLogCmd - stage 1} {
- ::safe::setLogCmd
- rename ::safe::setLogCmd {} ;# should not fail
-} {}
-test init-2.3 {load ::safe::setLogCmd - stage 2} {
- ::safe::setLogCmd
- rename ::safe::setLogCmd {} ;# should not fail
-} {}
-auto_reset
-catch {rename ::safe::setLogCmd {}}
-test init-2.4 {load safe:::setLogCmd - stage 1} {
- safe:::setLogCmd ;# intentionally 3 :
- rename ::safe::setLogCmd {} ;# should not fail
-} {}
-test init-2.5 {load safe:::setLogCmd - stage 2} {
- safe:::setLogCmd ;# intentionally 3 :
- rename ::safe::setLogCmd {} ;# should not fail
-} {}
-auto_reset
-catch {rename ::safe::setLogCmd {}}
-test init-2.6 {load setLogCmd from safe:: - stage 1} {
- namespace eval safe setLogCmd
- rename ::safe::setLogCmd {} ;# should not fail
-} {}
-test init-2.7 {oad setLogCmd from safe:: - stage 2} {
- namespace eval safe setLogCmd
- rename ::safe::setLogCmd {} ;# should not fail
-} {}
-test init-2.8 {load tcl::HistAdd} -setup {
- auto_reset
- catch {rename ::tcl::HistAdd {}}
-} -body {
- # 3 ':' on purpose
- tcl:::HistAdd
-} -returnCodes error -cleanup {
- rename ::tcl::HistAdd {}
-} -result {wrong # args: should be "tcl:::HistAdd event ?exec?"}
-
-test init-3.0 {random stuff in the auto_index, should still work} {
- set auto_index(foo:::bar::blah) {
- namespace eval foo {namespace eval bar {proc blah {} {return 1}}}
- }
- foo:::bar::blah
-} 1
-
-# Tests that compare the error stack trace generated when autoloading with
-# that generated when no autoloading is necessary. Ideally they should be the
-# same.
-
-set count 0
-foreach arg [subst -nocommands -novariables {
- c
- {argument
- which spans
- multiple lines}
- {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}
- {argument which spans multiple lines
- and is long enough to be truncated and
-" <- includes a false lead in the prune point search
- and must be longer still to force truncation}
- {contrived example: rare circumstance
- where the point at which to prune the
- error stack cannot be uniquely determined.
- foo bar foo
-"}
- {contrived example: rare circumstance
- where the point at which to prune the
- error stack cannot be uniquely determined.
- foo bar
-"}
- {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}
- }] { ;# emacs needs -> "
-
- test init-4.$count.0 {::errorInfo produced by [unknown]} -setup {
- auto_reset
- } -body {
- catch {parray a b $arg}
- set first $::errorInfo
- catch {parray a b $arg}
- list $first $::errorInfo
- } -match pairwise -result equal
- test init-4.$count.1 {::errorInfo produced by [unknown]} -setup {
- auto_reset
- } -body {
- namespace eval junk [list array set $arg [list 1 2 3 4]]
- trace variable ::junk::$arg r \
- "[list error [subst {Variable \"$arg\" is write-only}]] ;# "
- catch {parray ::junk::$arg}
- set first $::errorInfo
- catch {parray ::junk::$arg}
- list $first $::errorInfo
- } -match pairwise -result equal
-
- incr count
-}
-
-test init-5.0 {return options passed through ::unknown} -setup {
- catch {rename xxx {}}
- set ::auto_index(::xxx) {proc ::xxx {} {
- return -code error -level 2 xxx
- }}
-} -body {
- set code [catch {::xxx} foo bar]
- set code2 [catch {::xxx} foo2 bar2]
- list $code $foo $bar $code2 $foo2 $bar2
-} -cleanup {
- unset ::auto_index(::xxx)
-} -match glob -result {2 xxx {-errorcode NONE -code 1 -level 1} 2 xxx {-code 1 -level 1 -errorcode NONE}}
-\f
-cleanupTests
-} ;# End of [interp eval $testInterp]
-
-# cleanup
-interp delete $testInterp
-::tcltest::cleanupTests
-return
-
-# Local Variables:
-# mode: tcl
-# fill-column: 78
-# End:
OSDN Git Service
