os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/info.test
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/info.test Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1081 @@
1.4 +# -*- tcl -*-
1.5 +# Commands covered: info
1.6 +#
1.7 +# This file contains a collection of tests for one or more of the Tcl
1.8 +# built-in commands. Sourcing this file into Tcl runs the tests and
1.9 +# generates output for errors. No output means no errors were found.
1.10 +#
1.11 +# Copyright (c) 1991-1994 The Regents of the University of California.
1.12 +# Copyright (c) 1994-1997 Sun Microsystems, Inc.
1.13 +# Copyright (c) 1998-1999 by Scriptics Corporation.
1.14 +# Copyright (c) 2006 ActiveState
1.15 +#
1.16 +# See the file "license.terms" for information on usage and redistribution
1.17 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.18 +#
1.19 +# RCS: @(#) $Id: info.test,v 1.24.2.5 2006/11/28 22:20:02 andreas_kupries Exp $
1.20 +
1.21 +if {[lsearch [namespace children] ::tcltest] == -1} {
1.22 + package require tcltest 2
1.23 + namespace import -force ::tcltest::*
1.24 +}
1.25 +
1.26 +# Set up namespaces needed to test operation of "info args", "info body",
1.27 +# "info default", and "info procs" with imported procedures.
1.28 +
1.29 +catch {namespace delete test_ns_info1 test_ns_info2}
1.30 +
1.31 +namespace eval test_ns_info1 {
1.32 + namespace export *
1.33 + proc p {x} {return "x=$x"}
1.34 + proc q {{y 27} {z {}}} {return "y=$y"}
1.35 +}
1.36 +
1.37 +testConstraint tip280 [info exists tcl_platform(tip,280)]
1.38 +testConstraint !tip280 [expr {![info exists tcl_platform(tip,280)]}]
1.39 +
1.40 +
1.41 +test info-1.1 {info args option} {
1.42 + proc t1 {a bbb c} {return foo}
1.43 + info args t1
1.44 +} {a bbb c}
1.45 +test info-1.2 {info args option} {
1.46 + proc t1 {{a default1} {bbb default2} {c default3} args} {return foo}
1.47 + info a t1
1.48 +} {a bbb c args}
1.49 +test info-1.3 {info args option} {
1.50 + proc t1 "" {return foo}
1.51 + info args t1
1.52 +} {}
1.53 +test info-1.4 {info args option} {
1.54 + catch {rename t1 {}}
1.55 + list [catch {info args t1} msg] $msg
1.56 +} {1 {"t1" isn't a procedure}}
1.57 +test info-1.5 {info args option} {
1.58 + list [catch {info args set} msg] $msg
1.59 +} {1 {"set" isn't a procedure}}
1.60 +test info-1.6 {info args option} {
1.61 + proc t1 {a b} {set c 123; set d $c}
1.62 + t1 1 2
1.63 + info args t1
1.64 +} {a b}
1.65 +test info-1.7 {info args option} {
1.66 + catch {namespace delete test_ns_info2}
1.67 + namespace eval test_ns_info2 {
1.68 + namespace import ::test_ns_info1::*
1.69 + list [info args p] [info args q]
1.70 + }
1.71 +} {x {y z}}
1.72 +
1.73 +test info-2.1 {info body option} {
1.74 + proc t1 {} {body of t1}
1.75 + info body t1
1.76 +} {body of t1}
1.77 +test info-2.2 {info body option} {
1.78 + list [catch {info body set} msg] $msg
1.79 +} {1 {"set" isn't a procedure}}
1.80 +test info-2.3 {info body option} {
1.81 + list [catch {info args set 1} msg] $msg
1.82 +} {1 {wrong # args: should be "info args procname"}}
1.83 +test info-2.4 {info body option} {
1.84 + catch {namespace delete test_ns_info2}
1.85 + namespace eval test_ns_info2 {
1.86 + namespace import ::test_ns_info1::*
1.87 + list [info body p] [info body q]
1.88 + }
1.89 +} {{return "x=$x"} {return "y=$y"}}
1.90 +# Prior to 8.3.0 this would cause a crash because [info body]
1.91 +# would return the bytecompiled version of foo, which the catch
1.92 +# would then try and eval out of the foo context, accessing
1.93 +# compiled local indices
1.94 +test info-2.5 {info body option, returning bytecompiled bodies} {
1.95 + catch {unset args}
1.96 + proc foo {args} {
1.97 + foreach v $args {
1.98 + upvar $v var
1.99 + return "variable $v existence: [info exists var]"
1.100 + }
1.101 + }
1.102 + foo a
1.103 + list [catch [info body foo] msg] $msg
1.104 +} {1 {can't read "args": no such variable}}
1.105 +# Fix for problem tested for in info-2.5 caused problems when
1.106 +# procedure body had no string rep (i.e. was not yet bytecode)
1.107 +# causing an empty string to be returned [Bug #545644]
1.108 +test info-2.6 {info body option, returning list bodies} {
1.109 + proc foo args [list subst bar]
1.110 + list [string bytelength [info body foo]] \
1.111 + [foo; string bytelength [info body foo]]
1.112 +} {9 9}
1.113 +
1.114 +# "info cmdcount" is no longer accurate for compiled commands!
1.115 +# The expected result for info-3.1 used to be "3" and is now "1"
1.116 +# since the "set"s have been compiled away. info-3.2 was corrected
1.117 +# in 8.3 because the eval'ed body won't be compiled.
1.118 +proc testinfocmdcount {} {
1.119 + set x [info cmdcount]
1.120 + set y 12345
1.121 + set z [info cm]
1.122 + expr $z-$x
1.123 +}
1.124 +test info-3.1 {info cmdcount compiled} {
1.125 + testinfocmdcount
1.126 +} 1
1.127 +test info-3.2 {info cmdcount evaled} {
1.128 + set x [info cmdcount]
1.129 + set y 12345
1.130 + set z [info cm]
1.131 + expr $z-$x
1.132 +} 3
1.133 +test info-3.3 {info cmdcount evaled} [info body testinfocmdcount] 3
1.134 +test info-3.4 {info cmdcount option} {
1.135 + list [catch {info cmdcount 1} msg] $msg
1.136 +} {1 {wrong # args: should be "info cmdcount"}}
1.137 +
1.138 +test info-4.1 {info commands option} {
1.139 + proc t1 {} {}
1.140 + proc t2 {} {}
1.141 + set x " [info commands] "
1.142 + list [string match {* t1 *} $x] [string match {* t2 *} $x] \
1.143 + [string match {* set *} $x] [string match {* list *} $x]
1.144 +} {1 1 1 1}
1.145 +test info-4.2 {info commands option} {
1.146 + proc t1 {} {}
1.147 + rename t1 {}
1.148 + set x [info comm]
1.149 + string match {* t1 *} $x
1.150 +} 0
1.151 +test info-4.3 {info commands option} {
1.152 + proc _t1_ {} {}
1.153 + proc _t2_ {} {}
1.154 + info commands _t1_
1.155 +} _t1_
1.156 +test info-4.4 {info commands option} {
1.157 + proc _t1_ {} {}
1.158 + proc _t2_ {} {}
1.159 + lsort [info commands _t*]
1.160 +} {_t1_ _t2_}
1.161 +catch {rename _t1_ {}}
1.162 +catch {rename _t2_ {}}
1.163 +test info-4.5 {info commands option} {
1.164 + list [catch {info commands a b} msg] $msg
1.165 +} {1 {wrong # args: should be "info commands ?pattern?"}}
1.166 +
1.167 +test info-5.1 {info complete option} {
1.168 + list [catch {info complete} msg] $msg
1.169 +} {1 {wrong # args: should be "info complete command"}}
1.170 +test info-5.2 {info complete option} {
1.171 + info complete abc
1.172 +} 1
1.173 +test info-5.3 {info complete option} {
1.174 + info complete "\{abcd "
1.175 +} 0
1.176 +test info-5.4 {info complete option} {
1.177 + info complete {# Comment should be complete command}
1.178 +} 1
1.179 +test info-5.5 {info complete option} {
1.180 + info complete {[a [b] }
1.181 +} 0
1.182 +test info-5.6 {info complete option} {
1.183 + info complete {[a [b]}
1.184 +} 0
1.185 +
1.186 +test info-6.1 {info default option} {
1.187 + proc t1 {a b {c d} {e "long default value"}} {}
1.188 + info default t1 a value
1.189 +} 0
1.190 +test info-6.2 {info default option} {
1.191 + proc t1 {a b {c d} {e "long default value"}} {}
1.192 + set value 12345
1.193 + info d t1 a value
1.194 + set value
1.195 +} {}
1.196 +test info-6.3 {info default option} {
1.197 + proc t1 {a b {c d} {e "long default value"}} {}
1.198 + info default t1 c value
1.199 +} 1
1.200 +test info-6.4 {info default option} {
1.201 + proc t1 {a b {c d} {e "long default value"}} {}
1.202 + set value 12345
1.203 + info default t1 c value
1.204 + set value
1.205 +} d
1.206 +test info-6.5 {info default option} {
1.207 + proc t1 {a b {c d} {e "long default value"}} {}
1.208 + set value 12345
1.209 + set x [info default t1 e value]
1.210 + list $x $value
1.211 +} {1 {long default value}}
1.212 +test info-6.6 {info default option} {
1.213 + list [catch {info default a b} msg] $msg
1.214 +} {1 {wrong # args: should be "info default procname arg varname"}}
1.215 +test info-6.7 {info default option} {
1.216 + list [catch {info default _nonexistent_ a b} msg] $msg
1.217 +} {1 {"_nonexistent_" isn't a procedure}}
1.218 +test info-6.8 {info default option} {
1.219 + proc t1 {a b} {}
1.220 + list [catch {info default t1 x value} msg] $msg
1.221 +} {1 {procedure "t1" doesn't have an argument "x"}}
1.222 +test info-6.9 {info default option} {
1.223 + catch {unset a}
1.224 + set a(0) 88
1.225 + proc t1 {a b} {}
1.226 + list [catch {info default t1 a a} msg] $msg
1.227 +} {1 {couldn't store default value in variable "a"}}
1.228 +test info-6.10 {info default option} {
1.229 + catch {unset a}
1.230 + set a(0) 88
1.231 + proc t1 {{a 18} b} {}
1.232 + list [catch {info default t1 a a} msg] $msg
1.233 +} {1 {couldn't store default value in variable "a"}}
1.234 +test info-6.11 {info default option} {
1.235 + catch {namespace delete test_ns_info2}
1.236 + namespace eval test_ns_info2 {
1.237 + namespace import ::test_ns_info1::*
1.238 + list [info default p x foo] $foo [info default q y bar] $bar
1.239 + }
1.240 +} {0 {} 1 27}
1.241 +catch {unset a}
1.242 +
1.243 +test info-7.1 {info exists option} {
1.244 + set value foo
1.245 + info exists value
1.246 +} 1
1.247 +catch {unset _nonexistent_}
1.248 +test info-7.2 {info exists option} {
1.249 + info exists _nonexistent_
1.250 +} 0
1.251 +test info-7.3 {info exists option} {
1.252 + proc t1 {x} {return [info exists x]}
1.253 + t1 2
1.254 +} 1
1.255 +test info-7.4 {info exists option} {
1.256 + proc t1 {x} {
1.257 + global _nonexistent_
1.258 + return [info exists _nonexistent_]
1.259 + }
1.260 + t1 2
1.261 +} 0
1.262 +test info-7.5 {info exists option} {
1.263 + proc t1 {x} {
1.264 + set y 47
1.265 + return [info exists y]
1.266 + }
1.267 + t1 2
1.268 +} 1
1.269 +test info-7.6 {info exists option} {
1.270 + proc t1 {x} {return [info exists value]}
1.271 + t1 2
1.272 +} 0
1.273 +test info-7.7 {info exists option} {
1.274 + catch {unset x}
1.275 + set x(2) 44
1.276 + list [info exists x] [info exists x(1)] [info exists x(2)]
1.277 +} {1 0 1}
1.278 +catch {unset x}
1.279 +test info-7.8 {info exists option} {
1.280 + list [catch {info exists} msg] $msg
1.281 +} {1 {wrong # args: should be "info exists varName"}}
1.282 +test info-7.9 {info exists option} {
1.283 + list [catch {info exists 1 2} msg] $msg
1.284 +} {1 {wrong # args: should be "info exists varName"}}
1.285 +
1.286 +test info-8.1 {info globals option} {
1.287 + set x 1
1.288 + set y 2
1.289 + set value 23
1.290 + set a " [info globals] "
1.291 + list [string match {* x *} $a] [string match {* y *} $a] \
1.292 + [string match {* value *} $a] [string match {* _foobar_ *} $a]
1.293 +} {1 1 1 0}
1.294 +test info-8.2 {info globals option} {
1.295 + set _xxx1 1
1.296 + set _xxx2 2
1.297 + lsort [info g _xxx*]
1.298 +} {_xxx1 _xxx2}
1.299 +test info-8.3 {info globals option} {
1.300 + list [catch {info globals 1 2} msg] $msg
1.301 +} {1 {wrong # args: should be "info globals ?pattern?"}}
1.302 +test info-8.4 {info globals option: may have leading namespace qualifiers} {
1.303 + set x 0
1.304 + list [info globals x] [info globals :x] [info globals ::x] [info globals :::x] [info globals ::::x]
1.305 +} {x {} x x x}
1.306 +test info-8.5 {info globals option: only return existing global variables} {
1.307 + -setup {
1.308 + catch {unset ::NO_SUCH_VAR}
1.309 + proc evalInProc script {eval $script}
1.310 + }
1.311 + -body {
1.312 + evalInProc {global NO_SUCH_VAR; info globals NO_SUCH_VAR}
1.313 + }
1.314 + -cleanup {
1.315 + rename evalInProc {}
1.316 + }
1.317 + -result {}
1.318 +}
1.319 +
1.320 +test info-9.1 {info level option} {
1.321 + info level
1.322 +} 0
1.323 +test info-9.2 {info level option} {
1.324 + proc t1 {a b} {
1.325 + set x [info le]
1.326 + set y [info level 1]
1.327 + list $x $y
1.328 + }
1.329 + t1 146 testString
1.330 +} {1 {t1 146 testString}}
1.331 +test info-9.3 {info level option} {
1.332 + proc t1 {a b} {
1.333 + t2 [expr $a*2] $b
1.334 + }
1.335 + proc t2 {x y} {
1.336 + list [info level] [info level 1] [info level 2] [info level -1] \
1.337 + [info level 0]
1.338 + }
1.339 + t1 146 {a {b c} {{{c}}}}
1.340 +} {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}}}}}}
1.341 +test info-9.4 {info level option} {
1.342 + proc t1 {} {
1.343 + set x [info level]
1.344 + set y [info level 1]
1.345 + list $x $y
1.346 + }
1.347 + t1
1.348 +} {1 t1}
1.349 +test info-9.5 {info level option} {
1.350 + list [catch {info level 1 2} msg] $msg
1.351 +} {1 {wrong # args: should be "info level ?number?"}}
1.352 +test info-9.6 {info level option} {
1.353 + list [catch {info level 123a} msg] $msg
1.354 +} {1 {expected integer but got "123a"}}
1.355 +test info-9.7 {info level option} {
1.356 + list [catch {info level 0} msg] $msg
1.357 +} {1 {bad level "0"}}
1.358 +test info-9.8 {info level option} {
1.359 + proc t1 {} {info level -1}
1.360 + list [catch {t1} msg] $msg
1.361 +} {1 {bad level "-1"}}
1.362 +test info-9.9 {info level option} {
1.363 + proc t1 {x} {info level $x}
1.364 + list [catch {t1 -3} msg] $msg
1.365 +} {1 {bad level "-3"}}
1.366 +test info-9.10 {info level option, namespaces} {
1.367 + set msg [namespace eval t {info level 0}]
1.368 + namespace delete t
1.369 + set msg
1.370 +} {namespace eval t {info level 0}}
1.371 +
1.372 +set savedLibrary $tcl_library
1.373 +test info-10.1 {info library option} {
1.374 + list [catch {info library x} msg] $msg
1.375 +} {1 {wrong # args: should be "info library"}}
1.376 +test info-10.2 {info library option} {
1.377 + set tcl_library 12345
1.378 + info library
1.379 +} {12345}
1.380 +test info-10.3 {info library option} {
1.381 + unset tcl_library
1.382 + list [catch {info library} msg] $msg
1.383 +} {1 {no library has been specified for Tcl}}
1.384 +set tcl_library $savedLibrary
1.385 +
1.386 +test info-11.1 {info loaded option} {
1.387 + list [catch {info loaded a b} msg] $msg
1.388 +} {1 {wrong # args: should be "info loaded ?interp?"}}
1.389 +test info-11.2 {info loaded option} {
1.390 + list [catch {info loaded {}}] [catch {info loaded gorp} msg] $msg
1.391 +} {0 1 {could not find interpreter "gorp"}}
1.392 +
1.393 +test info-12.1 {info locals option} {
1.394 + set a 22
1.395 + proc t1 {x y} {
1.396 + set b 13
1.397 + set c testing
1.398 + global a
1.399 + global aa
1.400 + set aa 23
1.401 + return [info locals]
1.402 + }
1.403 + lsort [t1 23 24]
1.404 +} {b c x y}
1.405 +test info-12.2 {info locals option} {
1.406 + proc t1 {x y} {
1.407 + set xx1 2
1.408 + set xx2 3
1.409 + set y 4
1.410 + return [info loc x*]
1.411 + }
1.412 + lsort [t1 2 3]
1.413 +} {x xx1 xx2}
1.414 +test info-12.3 {info locals option} {
1.415 + list [catch {info locals 1 2} msg] $msg
1.416 +} {1 {wrong # args: should be "info locals ?pattern?"}}
1.417 +test info-12.4 {info locals option} {
1.418 + info locals
1.419 +} {}
1.420 +test info-12.5 {info locals option} {
1.421 + proc t1 {} {return [info locals]}
1.422 + t1
1.423 +} {}
1.424 +test info-12.6 {info locals vs unset compiled locals} {
1.425 + proc t1 {lst} {
1.426 + foreach $lst $lst {}
1.427 + unset lst
1.428 + return [info locals]
1.429 + }
1.430 + lsort [t1 {a b c c d e f}]
1.431 +} {a b c d e f}
1.432 +test info-12.7 {info locals with temporary variables} {
1.433 + proc t1 {} {
1.434 + foreach a {b c} {}
1.435 + info locals
1.436 + }
1.437 + t1
1.438 +} {a}
1.439 +
1.440 +test info-13.1 {info nameofexecutable option} {
1.441 + list [catch {info nameofexecutable foo} msg] $msg
1.442 +} {1 {wrong # args: should be "info nameofexecutable"}}
1.443 +
1.444 +test info-14.1 {info patchlevel option} {
1.445 + set a [info patchlevel]
1.446 + regexp {[0-9]+\.[0-9]+([p[0-9]+)?} $a
1.447 +} 1
1.448 +test info-14.2 {info patchlevel option} {
1.449 + list [catch {info patchlevel a} msg] $msg
1.450 +} {1 {wrong # args: should be "info patchlevel"}}
1.451 +test info-14.3 {info patchlevel option} {
1.452 + set t $tcl_patchLevel
1.453 + unset tcl_patchLevel
1.454 + set result [list [catch {info patchlevel} msg] $msg]
1.455 + set tcl_patchLevel $t
1.456 + set result
1.457 +} {1 {can't read "tcl_patchLevel": no such variable}}
1.458 +
1.459 +test info-15.1 {info procs option} {
1.460 + proc t1 {} {}
1.461 + proc t2 {} {}
1.462 + set x " [info procs] "
1.463 + list [string match {* t1 *} $x] [string match {* t2 *} $x] \
1.464 + [string match {* _undefined_ *} $x]
1.465 +} {1 1 0}
1.466 +test info-15.2 {info procs option} {
1.467 + proc _tt1 {} {}
1.468 + proc _tt2 {} {}
1.469 + lsort [info pr _tt*]
1.470 +} {_tt1 _tt2}
1.471 +catch {rename _tt1 {}}
1.472 +catch {rename _tt2 {}}
1.473 +test info-15.3 {info procs option} {
1.474 + list [catch {info procs 2 3} msg] $msg
1.475 +} {1 {wrong # args: should be "info procs ?pattern?"}}
1.476 +test info-15.4 {info procs option} {
1.477 + catch {namespace delete test_ns_info2}
1.478 + namespace eval test_ns_info2 {
1.479 + namespace import ::test_ns_info1::*
1.480 + proc r {} {}
1.481 + list [info procs] [info procs p*]
1.482 + }
1.483 +} {{p q r} p}
1.484 +test info-15.5 {info procs option with a proc in a namespace} {
1.485 + catch {namespace delete test_ns_info2}
1.486 + namespace eval test_ns_info2 {
1.487 + proc p1 { arg } {
1.488 + puts cmd
1.489 + }
1.490 + proc p2 { arg } {
1.491 + puts cmd
1.492 + }
1.493 + }
1.494 + info procs ::test_ns_info2::p1
1.495 +} {::test_ns_info2::p1}
1.496 +test info-15.6 {info procs option with a pattern in a namespace} {
1.497 + catch {namespace delete test_ns_info2}
1.498 + namespace eval test_ns_info2 {
1.499 + proc p1 { arg } {
1.500 + puts cmd
1.501 + }
1.502 + proc p2 { arg } {
1.503 + puts cmd
1.504 + }
1.505 + }
1.506 + lsort [info procs ::test_ns_info2::p*]
1.507 +} [lsort [list ::test_ns_info2::p1 ::test_ns_info2::p2]]
1.508 +test info-15.7 {info procs option with a global shadowing proc} {
1.509 + catch {namespace delete test_ns_info2}
1.510 + proc string_cmd { arg } {
1.511 + puts cmd
1.512 + }
1.513 + namespace eval test_ns_info2 {
1.514 + proc string_cmd { arg } {
1.515 + puts cmd
1.516 + }
1.517 + }
1.518 + info procs test_ns_info2::string*
1.519 +} {::test_ns_info2::string_cmd}
1.520 +# This regression test is currently commented out because it requires
1.521 +# that the implementation of "info procs" looks into the global namespace,
1.522 +# which it does not (in contrast to "info commands")
1.523 +if {0} {
1.524 +test info-15.8 {info procs option with a global shadowing proc} {
1.525 + catch {namespace delete test_ns_info2}
1.526 + proc string_cmd { arg } {
1.527 + puts cmd
1.528 + }
1.529 + proc string_cmd2 { arg } {
1.530 + puts cmd
1.531 + }
1.532 + namespace eval test_ns_info2 {
1.533 + proc string_cmd { arg } {
1.534 + puts cmd
1.535 + }
1.536 + }
1.537 + namespace eval test_ns_info2 {
1.538 + lsort [info procs string*]
1.539 + }
1.540 +} [lsort [list string_cmd string_cmd2]]
1.541 +}
1.542 +
1.543 +test info-16.1 {info script option} {
1.544 + list [catch {info script x x} msg] $msg
1.545 +} {1 {wrong # args: should be "info script ?filename?"}}
1.546 +test info-16.2 {info script option} {
1.547 + file tail [info sc]
1.548 +} "info.test"
1.549 +set gorpfile [makeFile "info script\n" gorp.info]
1.550 +test info-16.3 {info script option} {
1.551 + list [source $gorpfile] [file tail [info script]]
1.552 +} [list $gorpfile info.test]
1.553 +test info-16.4 {resetting "info script" after errors} {
1.554 + catch {source ~_nobody_/foo}
1.555 + file tail [info script]
1.556 +} "info.test"
1.557 +test info-16.5 {resetting "info script" after errors} {
1.558 + catch {source _nonexistent_}
1.559 + file tail [info script]
1.560 +} "info.test"
1.561 +test info-16.6 {info script option} {
1.562 + set script [info script]
1.563 + list [file tail [info script]] \
1.564 + [info script newname.txt] \
1.565 + [file tail [info script $script]]
1.566 +} [list info.test newname.txt info.test]
1.567 +test info-16.7 {info script option} {
1.568 + set script [info script]
1.569 + info script newname.txt
1.570 + list [source $gorpfile] [file tail [info script]] \
1.571 + [file tail [info script $script]]
1.572 +} [list $gorpfile newname.txt info.test]
1.573 +removeFile gorp.info
1.574 +set gorpfile [makeFile {list [info script] [info script foo.bar]} gorp.info]
1.575 +test info-16.8 {info script option} {
1.576 + list [source $gorpfile] [file tail [info script]]
1.577 +} [list [list $gorpfile foo.bar] info.test]
1.578 +removeFile gorp.info
1.579 +
1.580 +test info-17.1 {info sharedlibextension option} {
1.581 + list [catch {info sharedlibextension foo} msg] $msg
1.582 +} {1 {wrong # args: should be "info sharedlibextension"}}
1.583 +
1.584 +test info-18.1 {info tclversion option} {
1.585 + set x [info tclversion]
1.586 + scan $x "%d.%d%c" a b c
1.587 +} 2
1.588 +test info-18.2 {info tclversion option} {
1.589 + list [catch {info t 2} msg] $msg
1.590 +} {1 {wrong # args: should be "info tclversion"}}
1.591 +test info-18.3 {info tclversion option} {
1.592 + set t $tcl_version
1.593 + unset tcl_version
1.594 + set result [list [catch {info tclversion} msg] $msg]
1.595 + set tcl_version $t
1.596 + set result
1.597 +} {1 {can't read "tcl_version": no such variable}}
1.598 +
1.599 +test info-19.1 {info vars option} {
1.600 + set a 1
1.601 + set b 2
1.602 + proc t1 {x y} {
1.603 + global a b
1.604 + set c 33
1.605 + return [info vars]
1.606 + }
1.607 + lsort [t1 18 19]
1.608 +} {a b c x y}
1.609 +test info-19.2 {info vars option} {
1.610 + set xxx1 1
1.611 + set xxx2 2
1.612 + proc t1 {xxa y} {
1.613 + global xxx1 xxx2
1.614 + set c 33
1.615 + return [info vars x*]
1.616 + }
1.617 + lsort [t1 18 19]
1.618 +} {xxa xxx1 xxx2}
1.619 +test info-19.3 {info vars option} {
1.620 + lsort [info vars]
1.621 +} [lsort [info globals]]
1.622 +test info-19.4 {info vars option} {
1.623 + list [catch {info vars a b} msg] $msg
1.624 +} {1 {wrong # args: should be "info vars ?pattern?"}}
1.625 +test info-19.5 {info vars with temporary variables} {
1.626 + proc t1 {} {
1.627 + foreach a {b c} {}
1.628 + info vars
1.629 + }
1.630 + t1
1.631 +} {a}
1.632 +test info-19.6 {info vars: Bug 1072654} -setup {
1.633 + namespace eval :: unset -nocomplain foo
1.634 + catch {namespace delete x}
1.635 +} -body {
1.636 + namespace eval x info vars foo
1.637 +} -cleanup {
1.638 + namespace delete x
1.639 +} -result {}
1.640 +
1.641 +# Check whether the extra testing functions are defined...
1.642 +if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
1.643 + set functions {abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
1.644 +} else {
1.645 + set functions {T1 T2 T3 abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
1.646 +}
1.647 +test info-20.1 {info functions option} {info functions sin} sin
1.648 +test info-20.2 {info functions option} {lsort [info functions]} $functions
1.649 +test info-20.3 {info functions option} {
1.650 + lsort [info functions a*]
1.651 +} {abs acos asin atan atan2}
1.652 +test info-20.4 {info functions option} {
1.653 + lsort [info functions *tan*]
1.654 +} {atan atan2 tan tanh}
1.655 +test info-20.5 {info functions option} {
1.656 + list [catch {info functions raise an error} msg] $msg
1.657 +} {1 {wrong # args: should be "info functions ?pattern?"}}
1.658 +
1.659 +test info-21.1 {miscellaneous error conditions} {
1.660 + list [catch {info} msg] $msg
1.661 +} {1 {wrong # args: should be "info option ?arg arg ...?"}}
1.662 +test info-21.2 {miscellaneous error conditions} !tip280 {
1.663 + list [catch {info gorp} msg] $msg
1.664 +} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
1.665 +test info-21.2-280 {miscellaneous error conditions} tip280 {
1.666 + list [catch {info gorp} msg] $msg
1.667 +} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
1.668 +test info-21.3 {miscellaneous error conditions} !tip280 {
1.669 + list [catch {info c} msg] $msg
1.670 +} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
1.671 +test info-21.3-280 {miscellaneous error conditions} tip280 {
1.672 + list [catch {info c} msg] $msg
1.673 +} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
1.674 +test info-21.4 {miscellaneous error conditions} !tip280 {
1.675 + list [catch {info l} msg] $msg
1.676 +} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
1.677 +test info-21.4-280 {miscellaneous error conditions} tip280 {
1.678 + list [catch {info l} msg] $msg
1.679 +} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
1.680 +test info-21.5 {miscellaneous error conditions} !tip280 {
1.681 + list [catch {info s} msg] $msg
1.682 +} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
1.683 +test info-21.5-280 {miscellaneous error conditions} tip280 {
1.684 + list [catch {info s} msg] $msg
1.685 +} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
1.686 +
1.687 +##
1.688 +# ### ### ### ######### ######### #########
1.689 +## info frame
1.690 +
1.691 +## Helper
1.692 +# For the more complex results we cut the file name down to remove
1.693 +# path dependencies, and we use only part of the first line of the
1.694 +# reported command. The latter is required because otherwise the whole
1.695 +# test case may appear in some results, but the result is part of the
1.696 +# testcase. An infinite string would be required to describe that. The
1.697 +# cutting-down breaks this.
1.698 +
1.699 +proc reduce {frame} {
1.700 + set pos [lsearch -exact $frame cmd]
1.701 + incr pos
1.702 + set cmd [lindex $frame $pos]
1.703 + if {[regexp \n $cmd]} {
1.704 + set first [string range [lindex [split $cmd \n] 0] 0 end-11]
1.705 + set frame [lreplace $frame $pos $pos $first]
1.706 + }
1.707 + set pos [lsearch -exact $frame file]
1.708 + if {$pos >=0} {
1.709 + incr pos
1.710 + set tail [file tail [lindex $frame $pos]]
1.711 + set frame [lreplace $frame $pos $pos $tail]
1.712 + }
1.713 + set frame
1.714 +}
1.715 +
1.716 +## Helper
1.717 +# Generate a stacktrace from the current location to top. This code
1.718 +# not only depends on the exact location of things, but also on the
1.719 +# implementation of tcltest. Any changes and these tests will have to
1.720 +# be updated.
1.721 +
1.722 +proc etrace {} {
1.723 + set res {}
1.724 + set level [info frame]
1.725 + while {$level} {
1.726 + lappend res [list $level [reduce [info frame $level]]]
1.727 + incr level -1
1.728 + }
1.729 + return $res
1.730 +}
1.731 +
1.732 +##
1.733 +
1.734 +test info-22.0 {info frame, levels} tip280 {
1.735 + info frame
1.736 +} 7
1.737 +
1.738 +test info-22.1 {info frame, bad level relative} tip280 {
1.739 + # catch is another level!, i.e. we have 8, not 7
1.740 + catch {info frame -8} msg
1.741 + set msg
1.742 +} {bad level "-8"}
1.743 +
1.744 +test info-22.2 {info frame, bad level absolute} tip280 {
1.745 + # catch is another level!, i.e. we have 8, not 7
1.746 + catch {info frame 9} msg
1.747 + set msg
1.748 +} {bad level "9"}
1.749 +
1.750 +test info-22.3 {info frame, current, relative} tip280 {
1.751 + info frame 0
1.752 +} {type eval line 2 cmd {info frame 0}}
1.753 +
1.754 +test info-22.4 {info frame, current, relative, nested} tip280 {
1.755 + set res [info frame 0]
1.756 +} {type eval line 2 cmd {info frame 0}}
1.757 +
1.758 +test info-22.5 {info frame, current, absolute} tip280 {
1.759 + reduce [info frame 7]
1.760 +} {type eval line 2 cmd {info frame 7}}
1.761 +
1.762 +test info-22.6 {info frame, global, relative} tip280 {
1.763 + reduce [info frame -6]
1.764 +} {type source line 759 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relativ}
1.765 +
1.766 +test info-22.7 {info frame, global, absolute} tip280 {
1.767 + reduce [info frame 1]
1.768 +} {type source line 763 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolut}
1.769 +
1.770 +test info-22.8 {info frame, basic trace} tip280 {
1.771 + join [etrace] \n
1.772 +} {8 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
1.773 +7 {type eval line 2 cmd etrace}
1.774 +6 {type source line 2277 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest}
1.775 +5 {type eval line 1 cmd {::tcltest::RunTest }}
1.776 +4 {type source line 1619 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval}
1.777 +3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ }
1.778 +2 {type source line 1966 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test}
1.779 +1 {type source line 767 file info.test cmd test\ info-22.8\ \{info\ frame,\ basic\ trac}}
1.780 +## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0
1.781 +test info-23.0 {eval'd info frame} tip280 {
1.782 + eval {info frame}
1.783 +} 8
1.784 +
1.785 +test info-23.1 {eval'd info frame, semi-dynamic} tip280 {
1.786 + eval info frame
1.787 +} 8
1.788 +
1.789 +test info-23.2 {eval'd info frame, dynamic} tip280 {
1.790 + set script {info frame}
1.791 + eval $script
1.792 +} 8
1.793 +
1.794 +test info-23.3 {eval'd info frame, literal} tip280 {
1.795 + eval {
1.796 + info frame 0
1.797 + }
1.798 +} {type eval line 2 cmd {info frame 0}}
1.799 +
1.800 +test info-23.4 {eval'd info frame, semi-dynamic} tip280 {
1.801 + eval info frame 0
1.802 +} {type eval line 1 cmd {info frame 0}}
1.803 +
1.804 +test info-23.5 {eval'd info frame, dynamic} tip280 {
1.805 + set script {info frame 0}
1.806 + eval $script
1.807 +} {type eval line 1 cmd {info frame 0}}
1.808 +
1.809 +test info-23.6 {eval'd info frame, trace} tip280 {
1.810 + set script {etrace}
1.811 + join [eval $script] \n
1.812 +} {9 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
1.813 +8 {type eval line 1 cmd etrace}
1.814 +7 {type eval line 3 cmd {eval $script}}
1.815 +6 {type source line 2277 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest}
1.816 +5 {type eval line 1 cmd {::tcltest::RunTest }}
1.817 +4 {type source line 1619 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval}
1.818 +3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ }
1.819 +2 {type source line 1966 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test}
1.820 +1 {type source line 806 file info.test cmd test\ info-23.6\ \{eval'd\ info\ frame,\ trac}}
1.821 +## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0
1.822 +# -------------------------------------------------------------------------
1.823 +
1.824 +# Procedures defined in scripts which are arguments to control
1.825 +# structures (like 'namespace eval', 'interp eval', 'if', 'while',
1.826 +# 'switch', 'catch', 'for', 'foreach', etc.) have no absolute
1.827 +# location. The command implementations execute such scripts through
1.828 +# Tcl_EvalObjEx. Flag 0 causes it to use the bytecode compiler. This
1.829 +# causes the connection to the context to be lost. Currently only
1.830 +# procedure bodies are able to remember their context.
1.831 +
1.832 +# -------------------------------------------------------------------------
1.833 +
1.834 +namespace eval foo {
1.835 + proc bar {} {info frame 0}
1.836 +}
1.837 +
1.838 +test info-24.0 {info frame, interaction, namespace eval} tip280 {
1.839 + reduce [foo::bar]
1.840 +} {type source line 832 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1.841 +
1.842 +namespace delete foo
1.843 +
1.844 +# -------------------------------------------------------------------------
1.845 +
1.846 +set flag 1
1.847 +if {$flag} {
1.848 + namespace eval foo {}
1.849 + proc ::foo::bar {} {info frame 0}
1.850 +}
1.851 +
1.852 +test info-24.1 {info frame, interaction, if} tip280 {
1.853 + reduce [foo::bar]
1.854 +} {type source line 846 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1.855 +
1.856 +namespace delete foo
1.857 +
1.858 +# -------------------------------------------------------------------------
1.859 +
1.860 +set flag 1
1.861 +while {$flag} {
1.862 + namespace eval foo {}
1.863 + proc ::foo::bar {} {info frame 0}
1.864 + set flag 0
1.865 +}
1.866 +
1.867 +test info-24.2 {info frame, interaction, while} tip280 {
1.868 + reduce [foo::bar]
1.869 +} {type source line 860 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1.870 +
1.871 +namespace delete foo
1.872 +
1.873 +# -------------------------------------------------------------------------
1.874 +
1.875 +catch {
1.876 + namespace eval foo {}
1.877 + proc ::foo::bar {} {info frame 0}
1.878 +}
1.879 +
1.880 +test info-24.3 {info frame, interaction, catch} tip280 {
1.881 + reduce [foo::bar]
1.882 +} {type source line 874 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1.883 +
1.884 +namespace delete foo
1.885 +
1.886 +# -------------------------------------------------------------------------
1.887 +
1.888 +foreach var val {
1.889 + namespace eval foo {}
1.890 + proc ::foo::bar {} {info frame 0}
1.891 + break
1.892 +}
1.893 +
1.894 +test info-24.4 {info frame, interaction, foreach} tip280 {
1.895 + reduce [foo::bar]
1.896 +} {type source line 887 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1.897 +
1.898 +namespace delete foo
1.899 +
1.900 +# -------------------------------------------------------------------------
1.901 +
1.902 +for {} {1} {} {
1.903 + namespace eval foo {}
1.904 + proc ::foo::bar {} {info frame 0}
1.905 + break
1.906 +}
1.907 +
1.908 +test info-24.5 {info frame, interaction, for} tip280 {
1.909 + reduce [foo::bar]
1.910 +} {type source line 901 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1.911 +
1.912 +namespace delete foo
1.913 +
1.914 +# -------------------------------------------------------------------------
1.915 +
1.916 +eval {
1.917 + proc bar {} {info frame 0}
1.918 +}
1.919 +
1.920 +test info-25.0 {info frame, proc in eval} tip280 {
1.921 + reduce [bar]
1.922 +} {type source line 914 file info.test cmd {info frame 0} proc ::bar level 0}
1.923 +
1.924 +proc bar {} {info frame 0}
1.925 +test info-25.1 {info frame, regular proc} tip280 {
1.926 + reduce [bar]
1.927 +} {type source line 921 file info.test cmd {info frame 0} proc ::bar level 0}
1.928 +rename bar {}
1.929 +
1.930 +
1.931 +
1.932 +test info-30.0 {bs+nl in literal words} {tip280 knownBug} {
1.933 + if {1} {
1.934 + set res \
1.935 + [reduce [info frame 0]]
1.936 + }
1.937 + set res
1.938 + # This is reporting line 3 instead of the correct 4 because the
1.939 + # bs+nl combination is subst by the parser before the 'if'
1.940 + # command, and the the bcc sees the word. To fix record the
1.941 + # offsets of all bs+nl sequences in literal words, then use the
1.942 + # information in the bcc to bump line numbers when parsing over
1.943 + # the location. Also affected: testcases 22.8 and 23.6.
1.944 +} {type eval line 4 cmd {info frame 0} proc ::tcltest::RunTest}
1.945 +
1.946 +
1.947 +
1.948 +# -------------------------------------------------------------------------
1.949 +# See 24.0 - 24.5 for similar situations, using literal scripts.
1.950 +
1.951 +set body {set flag 0
1.952 + set a c
1.953 + set res [info frame 0]} ;# line 3!
1.954 +
1.955 +test info-31.0 {ns eval, script in variable} tip280 {
1.956 + namespace eval foo $body
1.957 + set res
1.958 +} {type eval line 3 cmd {info frame 0} level 0}
1.959 +catch {namespace delete foo}
1.960 +
1.961 +
1.962 +test info-31.1 {if, script in variable} tip280 {
1.963 + if 1 $body
1.964 + set res
1.965 +} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
1.966 +
1.967 +test info-31.1a {if, script in variable} tip280 {
1.968 + if 1 then $body
1.969 + set res
1.970 +} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
1.971 +
1.972 +
1.973 +
1.974 +test info-31.2 {while, script in variable} tip280 {
1.975 + set flag 1
1.976 + while {$flag} $body
1.977 + set res
1.978 +} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
1.979 +
1.980 +# .3 - proc - scoping prevent return of result ...
1.981 +
1.982 +test info-31.4 {foreach, script in variable} tip280 {
1.983 + foreach var val $body
1.984 + set res
1.985 +} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
1.986 +
1.987 +test info-31.5 {for, script in variable} tip280 {
1.988 + set flag 1
1.989 + for {} {$flag} {} $body
1.990 + set res
1.991 +} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
1.992 +
1.993 +test info-31.6 {eval, script in variable} tip280 {
1.994 + eval $body
1.995 + set res
1.996 +} {type eval line 3 cmd {info frame 0}}
1.997 +
1.998 +# -------------------------------------------------------------------------
1.999 +
1.1000 +namespace eval foo {}
1.1001 +set x foo
1.1002 +switch -exact -- $x {
1.1003 + foo {
1.1004 + proc ::foo::bar {} {info frame 0}
1.1005 + }
1.1006 +}
1.1007 +
1.1008 +test info-24.6.0 {info frame, interaction, switch, list body} tip280 {
1.1009 + reduce [foo::bar]
1.1010 +} {type source line 1001 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1.1011 +
1.1012 +namespace delete foo
1.1013 +unset x
1.1014 +
1.1015 +# -------------------------------------------------------------------------
1.1016 +
1.1017 +namespace eval foo {}
1.1018 +set x foo
1.1019 +switch -exact -- $x foo {
1.1020 + proc ::foo::bar {} {info frame 0}
1.1021 +}
1.1022 +
1.1023 +test info-24.6.1 {info frame, interaction, switch, multi-body} tip280 {
1.1024 + reduce [foo::bar]
1.1025 +} {type source line 1017 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1.1026 +
1.1027 +namespace delete foo
1.1028 +unset x
1.1029 +
1.1030 +# -------------------------------------------------------------------------
1.1031 +
1.1032 +namespace eval foo {}
1.1033 +set x foo
1.1034 +switch -exact -- $x [list foo {
1.1035 + proc ::foo::bar {} {info frame 0}
1.1036 +}]
1.1037 +
1.1038 +test info-24.6.2 {info frame, interaction, switch, list body, dynamic} tip280 {
1.1039 + reduce [foo::bar]
1.1040 +} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
1.1041 +
1.1042 +namespace delete foo
1.1043 +unset x
1.1044 +
1.1045 +# -------------------------------------------------------------------------
1.1046 +
1.1047 +set body {
1.1048 + foo {
1.1049 + proc ::foo::bar {} {info frame 0}
1.1050 + }
1.1051 +}
1.1052 +
1.1053 +namespace eval foo {}
1.1054 +set x foo
1.1055 +switch -exact -- $x $body
1.1056 +
1.1057 +test info-31.7 {info frame, interaction, switch, dynamic} tip280 {
1.1058 + reduce [foo::bar]
1.1059 +} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
1.1060 +
1.1061 +namespace delete foo
1.1062 +unset x
1.1063 +
1.1064 +# -------------------------------------------------------------------------
1.1065 +
1.1066 +set body {
1.1067 + proc ::foo::bar {} {info frame 0}
1.1068 +}
1.1069 +
1.1070 +namespace eval foo {}
1.1071 +eval $body
1.1072 +
1.1073 +test info-32.0 {info frame, dynamic procedure} tip280 {
1.1074 + reduce [foo::bar]
1.1075 +} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
1.1076 +
1.1077 +namespace delete foo
1.1078 +
1.1079 +# -------------------------------------------------------------------------
1.1080 +
1.1081 +# cleanup
1.1082 +catch {namespace delete test_ns_info1 test_ns_info2}
1.1083 +::tcltest::cleanupTests
1.1084 +return