diff options
Diffstat (limited to 'tests/info.test')
| -rw-r--r-- | tests/info.test | 517 |
1 files changed, 0 insertions, 517 deletions
diff --git a/tests/info.test b/tests/info.test deleted file mode 100644 index 4522520..0000000 --- a/tests/info.test +++ /dev/null @@ -1,517 +0,0 @@ -# Commands covered: info -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-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. -# -# RCS: @(#) $Id: info.test,v 1.6 1999/04/16 00:47:29 stanton Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -# Set up namespaces needed to test operation of "info args", "info body", -# "info default", and "info procs" with imported procedures. - -catch {namespace delete test_ns_info1 test_ns_info2} - -namespace eval test_ns_info1 { - namespace export * - proc p {x} {return "x=$x"} - proc q {{y 27} z} {return "y=$y"} -} - - -test info-1.1 {info args option} { - proc t1 {a bbb c} {return foo} - info args t1 -} {a bbb c} -test info-1.2 {info args option} { - proc t1 {{a default1} {bbb default2} {c default3} args} {return foo} - info a t1 -} {a bbb c args} -test info-1.3 {info args option} { - proc t1 "" {return foo} - info args t1 -} {} -test info-1.4 {info args option} { - catch {rename t1 {}} - list [catch {info args t1} msg] $msg -} {1 {"t1" isn't a procedure}} -test info-1.5 {info args option} { - list [catch {info args set} msg] $msg -} {1 {"set" isn't a procedure}} -test info-1.6 {info args option} { - proc t1 {a b} {set c 123; set d $c} - t1 1 2 - info args t1 -} {a b} -test info-1.7 {info args option} { - catch {namespace delete test_ns_info2} - namespace eval test_ns_info2 { - namespace import ::test_ns_info1::* - list [info args p] [info args q] - } -} {x {y z}} - -test info-2.1 {info body option} { - proc t1 {} {body of t1} - info body t1 -} {body of t1} -test info-2.2 {info body option} { - list [catch {info body set} msg] $msg -} {1 {"set" isn't a procedure}} -test info-2.3 {info body option} { - list [catch {info args set 1} msg] $msg -} {1 {wrong # args: should be "info args procname"}} -test info-2.4 {info body option} { - catch {namespace delete test_ns_info2} - namespace eval test_ns_info2 { - namespace import ::test_ns_info1::* - list [info body p] [info body q] - } -} {{return "x=$x"} {return "y=$y"}} - -# "info cmdcount" is no longer accurate for compiled commands! The expected -# result for info-3.1 used to be "3" and is now "1" since the "set"s have -# been compiled away. -test info-3.1 {info cmdcount option} { - set x [info cmdcount] - set y 12345 - set z [info cm] - expr $z-$x -} 1 -test info-3.2 {info cmdcount option} { - list [catch {info cmdcount 1} msg] $msg -} {1 {wrong # args: should be "info cmdcount"}} - -test info-4.1 {info commands option} { - proc t1 {} {} - proc t2 {} {} - set x " [info commands] " - list [string match {* t1 *} $x] [string match {* t2 *} $x] \ - [string match {* set *} $x] [string match {* list *} $x] -} {1 1 1 1} -test info-4.2 {info commands option} { - proc t1 {} {} - rename t1 {} - set x [info comm] - string match {* t1 *} $x -} 0 -test info-4.3 {info commands option} { - proc _t1_ {} {} - proc _t2_ {} {} - info commands _t1_ -} _t1_ -test info-4.4 {info commands option} { - proc _t1_ {} {} - proc _t2_ {} {} - lsort [info commands _t*] -} {_t1_ _t2_} -catch {rename _t1_ {}} -catch {rename _t2_ {}} -test info-4.5 {info commands option} { - list [catch {info commands a b} msg] $msg -} {1 {wrong # args: should be "info commands ?pattern?"}} - -test info-5.1 {info complete option} { - list [catch {info complete} msg] $msg -} {1 {wrong # args: should be "info complete command"}} -test info-5.2 {info complete option} { - info complete abc -} 1 -test info-5.2 {info complete option} { - info complete "\{abcd " -} 0 -test info-5.3 {info complete option} { - info complete {# Comment should be complete command} -} 1 - -test info-6.1 {info default option} { - proc t1 {a b {c d} {e "long default value"}} {} - info default t1 a value -} 0 -test info-6.2 {info default option} { - proc t1 {a b {c d} {e "long default value"}} {} - set value 12345 - info d t1 a value - set value -} {} -test info-6.3 {info default option} { - proc t1 {a b {c d} {e "long default value"}} {} - info default t1 c value -} 1 -test info-6.4 {info default option} { - proc t1 {a b {c d} {e "long default value"}} {} - set value 12345 - info default t1 c value - set value -} d -test info-6.5 {info default option} { - proc t1 {a b {c d} {e "long default value"}} {} - set value 12345 - set x [info default t1 e value] - list $x $value -} {1 {long default value}} -test info-6.6 {info default option} { - list [catch {info default a b} msg] $msg -} {1 {wrong # args: should be "info default procname arg varname"}} -test info-6.7 {info default option} { - list [catch {info default _nonexistent_ a b} msg] $msg -} {1 {"_nonexistent_" isn't a procedure}} -test info-6.8 {info default option} { - proc t1 {a b} {} - list [catch {info default t1 x value} msg] $msg -} {1 {procedure "t1" doesn't have an argument "x"}} -test info-6.9 {info default option} { - catch {unset a} - set a(0) 88 - proc t1 {a b} {} - list [catch {info default t1 a a} msg] $msg -} {1 {couldn't store default value in variable "a"}} -test info-6.10 {info default option} { - catch {unset a} - set a(0) 88 - proc t1 {{a 18} b} {} - list [catch {info default t1 a a} msg] $msg -} {1 {couldn't store default value in variable "a"}} -test info-6.11 {info default option} { - catch {namespace delete test_ns_info2} - namespace eval test_ns_info2 { - namespace import ::test_ns_info1::* - list [info default p x foo] $foo [info default q y bar] $bar - } -} {0 {} 1 27} -catch {unset a} - -test info-7.1 {info exists option} { - set value foo - info exists value -} 1 -catch {unset _nonexistent_} -test info-7.2 {info exists option} { - info exists _nonexistent_ -} 0 -test info-7.3 {info exists option} { - proc t1 {x} {return [info exists x]} - t1 2 -} 1 -test info-7.4 {info exists option} { - proc t1 {x} { - global _nonexistent_ - return [info exists _nonexistent_] - } - t1 2 -} 0 -test info-7.5 {info exists option} { - proc t1 {x} { - set y 47 - return [info exists y] - } - t1 2 -} 1 -test info-7.6 {info exists option} { - proc t1 {x} {return [info exists value]} - t1 2 -} 0 -test info-7.7 {info exists option} { - catch {unset x} - set x(2) 44 - list [info exists x] [info exists x(1)] [info exists x(2)] -} {1 0 1} -catch {unset x} -test info-7.8 {info exists option} { - list [catch {info exists} msg] $msg -} {1 {wrong # args: should be "info exists varName"}} -test info-7.9 {info exists option} { - list [catch {info exists 1 2} msg] $msg -} {1 {wrong # args: should be "info exists varName"}} - -test info-8.1 {info globals option} { - set x 1 - set y 2 - set value 23 - set a " [info globals] " - list [string match {* x *} $a] [string match {* y *} $a] \ - [string match {* value *} $a] [string match {* _foobar_ *} $a] -} {1 1 1 0} -test info-8.2 {info globals option} { - set _xxx1 1 - set _xxx2 2 - lsort [info g _xxx*] -} {_xxx1 _xxx2} -test info-8.3 {info globals option} { - list [catch {info globals 1 2} msg] $msg -} {1 {wrong # args: should be "info globals ?pattern?"}} - -test info-9.1 {info level option} { - info level -} 0 -test info-9.2 {info level option} { - proc t1 {a b} { - set x [info le] - set y [info level 1] - list $x $y - } - t1 146 testString -} {1 {t1 146 testString}} -test info-9.3 {info level option} { - proc t1 {a b} { - t2 [expr $a*2] $b - } - proc t2 {x y} { - list [info level] [info level 1] [info level 2] [info level -1] \ - [info level 0] - } - t1 146 {a {b c} {{{c}}}} -} {2 {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}} {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}}} -test info-9.4 {info level option} { - proc t1 {} { - set x [info level] - set y [info level 1] - list $x $y - } - t1 -} {1 t1} -test info-9.5 {info level option} { - list [catch {info level 1 2} msg] $msg -} {1 {wrong # args: should be "info level ?number?"}} -test info-9.6 {info level option} { - list [catch {info level 123a} msg] $msg -} {1 {expected integer but got "123a"}} -test info-9.7 {info level option} { - list [catch {info level 0} msg] $msg -} {1 {bad level "0"}} -test info-9.8 {info level option} { - proc t1 {} {info level -1} - list [catch {t1} msg] $msg -} {1 {bad level "-1"}} -test info-9.9 {info level option} { - proc t1 {x} {info level $x} - list [catch {t1 -3} msg] $msg -} {1 {bad level "-3"}} - -set savedLibrary $tcl_library -test info-10.1 {info library option} { - list [catch {info library x} msg] $msg -} {1 {wrong # args: should be "info library"}} -test info-10.2 {info library option} { - set tcl_library 12345 - info library -} {12345} -test info-10.3 {info library option} { - unset tcl_library - list [catch {info library} msg] $msg -} {1 {no library has been specified for Tcl}} -set tcl_library $savedLibrary - -test info-11.1 {info loaded option} { - list [catch {info loaded a b} msg] $msg -} {1 {wrong # args: should be "info loaded ?interp?"}} -test info-11.2 {info loaded option} { - list [catch {info loaded {}}] [catch {info loaded gorp} msg] $msg -} {0 1 {could not find interpreter "gorp"}} - -test info-12.1 {info locals option} { - set a 22 - proc t1 {x y} { - set b 13 - set c testing - global a - return [info locals] - } - lsort [t1 23 24] -} {b c x y} -test info-12.2 {info locals option} { - proc t1 {x y} { - set xx1 2 - set xx2 3 - set y 4 - return [info loc x*] - } - lsort [t1 2 3] -} {x xx1 xx2} -test info-12.3 {info locals option} { - list [catch {info locals 1 2} msg] $msg -} {1 {wrong # args: should be "info locals ?pattern?"}} -test info-12.4 {info locals option} { - info locals -} {} -test info-12.5 {info locals option} { - proc t1 {} {return [info locals]} - t1 -} {} -test info-12.6 {info locals vs unset compiled locals} { - proc t1 {lst} { - foreach $lst $lst {} - unset lst - return [info locals] - } - lsort [t1 {a b c c d e f}] -} {a b c d e f} -test info-12.7 {info locals with temporary variables} { - proc t1 {} { - foreach a {b c} {} - info locals - } - t1 -} {a} - -test info-13.1 {info nameofexecutable option} { - list [catch {info nameofexecutable foo} msg] $msg -} {1 {wrong # args: should be "info nameofexecutable"}} - -test info-14.1 {info patchlevel option} { - set a [info patchlevel] - regexp {[0-9]+\.[0-9]+([p[0-9]+)?} $a -} 1 -test info-14.2 {info patchlevel option} { - list [catch {info patchlevel a} msg] $msg -} {1 {wrong # args: should be "info patchlevel"}} -test info-14.3 {info patchlevel option} { - set t $tcl_patchLevel - unset tcl_patchLevel - set result [list [catch {info patchlevel} msg] $msg] - set tcl_patchLevel $t - set result -} {1 {can't read "tcl_patchLevel": no such variable}} - -test info-15.1 {info procs option} { - proc t1 {} {} - proc t2 {} {} - set x " [info procs] " - list [string match {* t1 *} $x] [string match {* t2 *} $x] \ - [string match {* _undefined_ *} $x] -} {1 1 0} -test info-15.2 {info procs option} { - proc _tt1 {} {} - proc _tt2 {} {} - lsort [info pr _tt*] -} {_tt1 _tt2} -catch {rename _tt1 {}} -catch {rename _tt2 {}} -test info-15.3 {info procs option} { - list [catch {info procs 2 3} msg] $msg -} {1 {wrong # args: should be "info procs ?pattern?"}} -test info-15.4 {info procs option} { - catch {namespace delete test_ns_info2} - namespace eval test_ns_info2 { - namespace import ::test_ns_info1::* - proc r {} {} - list [info procs] [info procs p*] - } -} {{p q r} p} - -test info-16.1 {info script option} { - list [catch {info script x} msg] $msg -} {1 {wrong # args: should be "info script"}} -test info-16.2 {info script option} { - file tail [info sc] -} "info.test" -removeFile gorp.info -makeFile "info script\n" gorp.info -test info-16.3 {info script option} { - list [source gorp.info] [file tail [info script]] -} [list gorp.info info.test] -test info-16.4 {resetting "info script" after errors} { - catch {source ~_nobody_/foo} - file tail [info script] -} "info.test" -test info-16.5 {resetting "info script" after errors} { - catch {source _nonexistent_} - file tail [info script] -} "info.test" -removeFile gorp.info - -test info-17.1 {info sharedlibextension option} { - list [catch {info sharedlibextension foo} msg] $msg -} {1 {wrong # args: should be "info sharedlibextension"}} - -test info-18.1 {info tclversion option} { - set x [info tclversion] - scan $x "%d.%d%c" a b c -} 2 -test info-18.2 {info tclversion option} { - list [catch {info t 2} msg] $msg -} {1 {wrong # args: should be "info tclversion"}} -test info-18.3 {info tclversion option} { - set t $tcl_version - unset tcl_version - set result [list [catch {info tclversion} msg] $msg] - set tcl_version $t - set result -} {1 {can't read "tcl_version": no such variable}} - -test info-19.1 {info vars option} { - set a 1 - set b 2 - proc t1 {x y} { - global a b - set c 33 - return [info vars] - } - lsort [t1 18 19] -} {a b c x y} -test info-19.2 {info vars option} { - set xxx1 1 - set xxx2 2 - proc t1 {xxa y} { - global xxx1 xxx2 - set c 33 - return [info vars x*] - } - lsort [t1 18 19] -} {xxa xxx1 xxx2} -test info-19.3 {info vars option} { - lsort [info vars] -} [lsort [info globals]] -test info-19.4 {info vars option} { - list [catch {info vars a b} msg] $msg -} {1 {wrong # args: should be "info vars ?pattern?"}} -test info-19.5 {info vars with temporary variables} { - proc t1 {} { - foreach a {b c} {} - info vars - } - t1 -} {a} - -test info-20.1 {miscellaneous error conditions} { - list [catch {info} msg] $msg -} {1 {wrong # args: should be "info option ?arg arg ...?"}} -test info-20.2 {miscellaneous error conditions} { - list [catch {info gorp} msg] $msg -} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} -test info-20.3 {miscellaneous error conditions} { - list [catch {info c} msg] $msg -} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} -test info-20.4 {miscellaneous error conditions} { - list [catch {info l} msg] $msg -} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} -test info-20.5 {miscellaneous error conditions} { - list [catch {info s} msg] $msg -} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} - -# cleanup -catch {namespace delete test_ns_info1 test_ns_info2} -::tcltest::cleanupTests -return - - - - - - - - - - - - |