1# -*- tcl -*- 2# Commands covered: info 3# 4# This file contains a collection of tests for one or more of the Tcl 5# built-in commands. Sourcing this file into Tcl runs the tests and 6# generates output for errors. No output means no errors were found. 7# 8# Copyright © 1991-1994 The Regents of the University of California. 9# Copyright © 1994-1997 Sun Microsystems, Inc. 10# Copyright © 1998-1999 Scriptics Corporation. 11# Copyright © 2006 ActiveState 12# 13# See the file "license.terms" for information on usage and redistribution 14# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 15# 16# DO NOT DELETE THIS LINE 17 18if {{::tcltest} ni [namespace children]} { 19 package require tcltest 2.5 20 namespace import -force ::tcltest::* 21} 22::tcltest::loadTestedCommands 23catch [list package require -exact tcl::test [info patchlevel]] 24testConstraint zlib [llength [info commands zlib]] 25testConstraint nodep [info exists tcl_precision] 26# Set up namespaces needed to test operation of "info args", "info body", 27# "info default", and "info procs" with imported procedures. 28 29catch {namespace delete test_ns_info1 test_ns_info2} 30 31namespace eval test_ns_info1 { 32 namespace export * 33 proc p {x} {return "x=$x"} 34 proc q {{y 27} {z {}}} {return "y=$y"} 35} 36 37test info-1.1 {info args option} { 38 proc t1 {a bbb c} {return foo} 39 info args t1 40} {a bbb c} 41test info-1.2 {info args option} { 42 proc t1 {{a default1} {bbb default2} {c default3} args} {return foo} 43 info a t1 44} {a bbb c args} 45test info-1.3 {info args option} { 46 proc t1 "" {return foo} 47 info args t1 48} {} 49test info-1.4 {info args option} -body { 50 catch {rename t1 {}} 51 info args t1 52} -returnCodes error -result {"t1" isn't a procedure} 53test info-1.5 {info args option} -body { 54 info args set 55} -returnCodes error -result {"set" isn't a procedure} 56test info-1.6 {info args option} { 57 proc t1 {a b} {set c 123; set d $c} 58 t1 1 2 59 info args t1 60} {a b} 61test info-1.7 {info args option} { 62 catch {namespace delete test_ns_info2} 63 namespace eval test_ns_info2 { 64 namespace import ::test_ns_info1::* 65 list [info args p] [info args q] 66 } 67} {x {y z}} 68 69test info-2.1 {info body option} { 70 proc t1 {} {body of t1} 71 info body t1 72} {body of t1} 73test info-2.2 {info body option} -body { 74 info body set 75} -returnCodes error -result {"set" isn't a procedure} 76test info-2.3 {info body option} -body { 77 info args set 1 78} -returnCodes error -result {wrong # args: should be "info args procname"} 79test info-2.4 {info body option} { 80 catch {namespace delete test_ns_info2} 81 namespace eval test_ns_info2 { 82 namespace import ::test_ns_info1::* 83 list [info body p] [info body q] 84 } 85} {{return "x=$x"} {return "y=$y"}} 86# Prior to 8.3.0 this would cause a crash because [info body] 87# would return the bytecompiled version of foo, which the catch 88# would then try and eval out of the foo context, accessing 89# compiled local indices 90test info-2.5 {info body option, returning bytecompiled bodies} -body { 91 catch {unset args} 92 proc foo {args} { 93 foreach v $args { 94 upvar $v var 95 return "variable $v existence: [info exists var]" 96 } 97 } 98 foo a 99 eval [info body foo] 100} -returnCodes error -result {can't read "args": no such variable} 101# Fix for problem tested for in info-2.5 caused problems when 102# procedure body had no string rep (i.e. was not yet bytecode) 103# causing an empty string to be returned [Bug #545644] 104test info-2.6 {info body option, returning list bodies} nodep { 105 proc foo args [list subst bar] 106 list [string bytelength [info body foo]] \ 107 [foo; string bytelength [info body foo]] 108} {9 9} 109 110proc testinfocmdcount {} { 111 set x [info cmdcount] 112 set y 12345 113 set z [info cmdc] 114 expr {$z-$x} 115} 116test info-3.1 {info cmdcount compiled} { 117 testinfocmdcount 118} 4 119test info-3.2 {info cmdcount evaled} -body { 120 set x [info cmdcount] 121 set y 12345 122 set z [info cmdc] 123 expr {$z-$x} 124} -cleanup {unset x y z} -result 4 125test info-3.3 {info cmdcount evaled} -body [info body testinfocmdcount] -cleanup {unset x y z} -result 4 126test info-3.4 {info cmdcount option} -body { 127 info cmdcount 1 128} -returnCodes error -result {wrong # args: should be "info cmdcount"} 129 130test info-4.1 {info commands option} -body { 131 proc t1 {} {} 132 proc t2 {} {} 133 set x " [info commands] " 134 list [string match {* t1 *} $x] [string match {* t2 *} $x] \ 135 [string match {* set *} $x] [string match {* list *} $x] 136} -cleanup {unset x} -result {1 1 1 1} 137test info-4.2 {info commands option} -body { 138 proc t1 {} {} 139 rename t1 {} 140 string match {* t1 *} \ 141 [info comm] 142} -result 0 143test info-4.3 {info commands option} { 144 proc _t1_ {} {} 145 proc _t2_ {} {} 146 info commands _t1_ 147} _t1_ 148test info-4.4 {info commands option} { 149 proc _t1_ {} {} 150 proc _t2_ {} {} 151 lsort [info commands _t*] 152} {_t1_ _t2_} 153catch {rename _t1_ {}} 154catch {rename _t2_ {}} 155test info-4.5 {info commands option} -returnCodes error -body { 156 info commands a b 157} -result {wrong # args: should be "info commands ?pattern?"} 158# Also some tests in namespace.test 159 160test info-5.1 {info complete option} -body { 161 info complete 162} -returnCodes error -result {wrong # args: should be "info complete command"} 163test info-5.2 {info complete option} { 164 info complete abc 165} 1 166test info-5.3 {info complete option} { 167 info complete "\{abcd " 168} 0 169test info-5.4 {info complete option} { 170 info complete {# Comment should be complete command} 171} 1 172test info-5.5 {info complete option} { 173 info complete {[a [b] } 174} 0 175test info-5.6 {info complete option} { 176 info complete {[a [b]} 177} 0 178 179test info-6.1 {info default option} { 180 proc t1 {a b {c d} {e "long default value"}} {} 181 info default t1 a value 182} 0 183test info-6.2 {info default option} -body { 184 proc t1 {a b {c d} {e "long default value"}} {} 185 set value 12345 186 info d t1 a value 187 return $value 188} -cleanup {unset value} -result {} 189test info-6.3 {info default option} -body { 190 proc t1 {a b {c d} {e "long default value"}} {} 191 info default t1 c value 192} -cleanup {unset value} -result 1 193test info-6.4 {info default option} -body { 194 proc t1 {a b {c d} {e "long default value"}} {} 195 set value 12345 196 info default t1 c value 197 return $value 198} -cleanup {unset value} -result d 199test info-6.5 {info default option} -body { 200 proc t1 {a b {c d} {e "long default value"}} {} 201 set value 12345 202 set x [info default t1 e value] 203 list $x $value 204} -cleanup {unset x value} -result {1 {long default value}} 205test info-6.6 {info default option} -returnCodes error -body { 206 info default a b 207} -result {wrong # args: should be "info default procname arg varname"} 208test info-6.7 {info default option} -returnCodes error -body { 209 info default _nonexistent_ a b 210} -result {"_nonexistent_" isn't a procedure} 211test info-6.8 {info default option} -returnCodes error -body { 212 proc t1 {a b} {} 213 info default t1 x value 214} -result {procedure "t1" doesn't have an argument "x"} 215test info-6.9 {info default option} -returnCodes error -setup { 216 catch {unset a} 217} -cleanup {unset a} -body { 218 set a(0) 88 219 proc t1 {a b} {} 220 info default t1 a a 221} -returnCodes error -result {can't set "a": variable is array} 222test info-6.10 {info default option} -setup { 223 catch {unset a} 224} -cleanup {unset a} -body { 225 set a(0) 88 226 proc t1 {{a 18} b} {} 227 info default t1 a a 228} -returnCodes error -result {can't set "a": variable is array} 229test info-6.11 {info default option} { 230 catch {namespace delete test_ns_info2} 231 namespace eval test_ns_info2 { 232 namespace import ::test_ns_info1::* 233 list [info default p x foo] $foo [info default q y bar] $bar 234 } 235} {0 {} 1 27} 236 237test info-7.1 {info exists option} -body { 238 set value foo 239 info exists value 240} -cleanup {unset value} -result 1 241 242test info-7.2 {info exists option} -setup {catch {unset _nonexistent_}} -body { 243 info exists _nonexistent_ 244} -result 0 245test info-7.3 {info exists option} { 246 proc t1 {x} {return [info exists x]} 247 t1 2 248} 1 249test info-7.4 {info exists option} -body { 250 proc t1 {x} { 251 global _nonexistent_ 252 return [info exists _nonexistent_] 253 } 254 t1 2 255} -setup {unset -nocomplain _nonexistent_} -result 0 256test info-7.5 {info exists option} { 257 proc t1 {x} { 258 set y 47 259 return [info exists y] 260 } 261 t1 2 262} 1 263test info-7.6 {info exists option} { 264 proc t1 {x} {return [info exists value]} 265 t1 2 266} 0 267test info-7.7 {info exists option} -setup { 268 catch {unset x} 269} -body { 270 set x(2) 44 271 list [info exists x] [info exists x(1)] [info exists x(2)] 272} -result {1 0 1} 273catch {unset x} 274test info-7.8 {info exists option} -body { 275 info exists 276} -returnCodes error -result {wrong # args: should be "info exists varName"} 277test info-7.9 {info exists option} -body { 278 info exists 1 2 279} -returnCodes error -result {wrong # args: should be "info exists varName"} 280 281test info-8.1 {info globals option} -body { 282 set x 1 283 set y 2 284 set value 23 285 set a " [info globals] " 286 list [string match {* x *} $a] [string match {* y *} $a] \ 287 [string match {* value *} $a] [string match {* _foobar_ *} $a] 288} -cleanup {unset x y value a} -result {1 1 1 0} 289test info-8.2 {info globals option} -body { 290 set _xxx1 1 291 set _xxx2 2 292 lsort [info g _xxx*] 293} -cleanup {unset _xxx1 _xxx2} -result {_xxx1 _xxx2} 294test info-8.3 {info globals option} -returnCodes error -body { 295 info globals 1 2 296} -result {wrong # args: should be "info globals ?pattern?"} 297test info-8.4 {info globals option: may have leading namespace qualifiers} -body { 298 set x 0 299 list [info globals x] [info globals :x] [info globals ::x] [info globals :::x] [info globals ::::x] 300} -cleanup {unset x} -result {x {} x x x} 301test info-8.5 {info globals option: only return existing global variables} { 302 -setup { 303 unset -nocomplain ::NO_SUCH_VAR 304 proc evalInProc script {eval $script} 305 } 306 -body { 307 evalInProc {global NO_SUCH_VAR; info globals NO_SUCH_VAR} 308 } 309 -cleanup { 310 rename evalInProc {} 311 } 312 -result {} 313} 314 315test info-9.1 {info level option} { 316 info level 317} 0 318test info-9.2 {info level option} { 319 proc t1 {a b} { 320 set x [info le] 321 set y [info level 1] 322 list $x $y 323 } 324 t1 146 testString 325} {1 {t1 146 testString}} 326test info-9.3 {info level option} { 327 proc t1 {a b} { 328 t2 [expr {$a*2}] $b 329 } 330 proc t2 {x y} { 331 list [info level] [info level 1] [info level 2] [info level -1] \ 332 [info level 0] 333 } 334 t1 146 {a {b c} {{{c}}}} 335} {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}}}}}} 336test info-9.4 {info level option} { 337 proc t1 {} { 338 set x [info level] 339 set y [info level 1] 340 list $x $y 341 } 342 t1 343} {1 t1} 344test info-9.5 {info level option} -body { 345 info level 1 2 346} -returnCodes error -result {wrong # args: should be "info level ?number?"} 347test info-9.6 {info level option} -body { 348 info level 123a 349} -returnCodes error -result {expected integer but got "123a"} 350test info-9.7 {info level option} -body { 351 info level 0 352} -returnCodes error -result {bad level "0"} 353test info-9.8 {info level option} -body { 354 proc t1 {} {info level -1} 355 t1 356} -returnCodes error -result {bad level "-1"} 357test info-9.9 {info level option} -body { 358 proc t1 {x} {info level $x} 359 t1 -3 360} -returnCodes error -result {bad level "-3"} 361test info-9.10 {info level option, namespaces} -body { 362 namespace eval t {info level 0} 363} -cleanup { 364 namespace delete t 365} -result {namespace eval t {info level 0}} 366test info-9.11 {info level option, aliases} -constraints knownBug -setup { 367 proc w {x y z} {info level 0} 368 interp alias {} a {} w a b 369} -body { 370 a c 371} -cleanup { 372 rename a {} 373 rename w {} 374} -result {a c} 375test info-9.12 {info level option, ensembles} -constraints knownBug -setup { 376 proc w {x y z} {info level 0} 377 namespace ensemble create -command a -map {foo ::w} 378} -body { 379 a foo 1 2 3 380} -cleanup { 381 rename a {} 382 rename w {} 383} -result {a foo 1 2 3} 384 385set savedLibrary $tcl_library 386test info-10.1 {info library option} -body { 387 info library x 388} -returnCodes error -result {wrong # args: should be "info library"} 389test info-10.2 {info library option} { 390 set tcl_library 12345 391 info library 392} {12345} 393test info-10.3 {info library option} -body { 394 unset tcl_library 395 info library 396} -returnCodes error -result {no library has been specified for Tcl} 397set tcl_library $savedLibrary; unset savedLibrary 398 399test info-11.1 {info loaded option} -body { 400 info loaded a b c 401} -returnCodes error -result {wrong # args: should be "info loaded ?interp? ?packageName?"} 402test info-11.2 {info loaded option} -body { 403 info loaded {}; info loaded gorp 404} -returnCodes error -result {could not find interpreter "gorp"} 405 406test info-12.1 {info locals option} -body { 407 set a 22 408 proc t1 {x y} { 409 set b 13 410 set c testing 411 global a 412 global aa 413 set aa 23 414 return [info locals] 415 } 416 lsort [t1 23 24] 417} -cleanup {unset a aa} -result {b c x y} 418test info-12.2 {info locals option} { 419 proc t1 {x y} { 420 set xx1 2 421 set xx2 3 422 set y 4 423 return [info loc x*] 424 } 425 lsort [t1 2 3] 426} {x xx1 xx2} 427test info-12.3 {info locals option} -body { 428 info locals 1 2 429} -returnCodes error -result {wrong # args: should be "info locals ?pattern?"} 430test info-12.4 {info locals option} { 431 info locals 432} {} 433test info-12.5 {info locals option} { 434 proc t1 {} {return [info locals]} 435 t1 436} {} 437test info-12.6 {info locals vs unset compiled locals} { 438 proc t1 {lst} { 439 foreach $lst $lst {} 440 unset lst 441 return [info locals] 442 } 443 lsort [t1 {a b c c d e f}] 444} {a b c d e f} 445test info-12.7 {info locals with temporary variables} { 446 proc t1 {} { 447 foreach a {b c} {} 448 info locals 449 } 450 t1 451} {a} 452 453test info-13.1 {info nameofexecutable option} -returnCodes error -body { 454 info nameofexecutable foo 455} -result {wrong # args: should be "info nameofexecutable"} 456 457test info-14.1 {info patchlevel option} -body { 458 set a [info patchlevel] 459 regexp {[0-9]+\.[0-9]+([p[0-9]+)?} $a 460} -cleanup {unset a} -result 1 461test info-14.2 {info patchlevel option} -returnCodes error -body { 462 info patchlevel a 463} -result {wrong # args: should be "info patchlevel"} 464test info-14.3 {info patchlevel option} -setup { 465 set t $tcl_patchLevel 466} -body { 467 unset tcl_patchLevel 468 info patchlevel 469} -cleanup { 470 set tcl_patchLevel $t; unset t 471} -returnCodes error -result {can't read "tcl_patchLevel": no such variable} 472 473test info-15.1 {info procs option} -body { 474 proc t1 {} {} 475 proc t2 {} {} 476 set x " [info procs] " 477 list [string match {* t1 *} $x] [string match {* t2 *} $x] \ 478 [string match {* _undefined_ *} $x] 479} -cleanup {unset x} -result {1 1 0} 480test info-15.2 {info procs option} { 481 proc _tt1 {} {} 482 proc _tt2 {} {} 483 lsort [info pr _tt*] 484} {_tt1 _tt2} 485catch {rename _tt1 {}} 486catch {rename _tt2 {}} 487test info-15.3 {info procs option} -body { 488 info procs 2 3 489} -returnCodes error -result {wrong # args: should be "info procs ?pattern?"} 490test info-15.4 {info procs option} -setup { 491 catch {namespace delete test_ns_info2} 492} -body { 493 namespace eval test_ns_info2 { 494 namespace import ::test_ns_info1::* 495 proc r {} {} 496 list [lsort [info procs]] [info procs p*] 497 } 498} -result {{p q r} p} 499test info-15.5 {info procs option with a proc in a namespace} -setup { 500 catch {namespace delete test_ns_info2} 501} -body { 502 namespace eval test_ns_info2 { 503 proc p1 { arg } { 504 puts cmd 505 } 506 proc p2 { arg } { 507 puts cmd 508 } 509 } 510 info procs ::test_ns_info2::p1 511} -result {::test_ns_info2::p1} 512test info-15.6 {info procs option with a pattern in a namespace} -setup { 513 catch {namespace delete test_ns_info2} 514} -body { 515 namespace eval test_ns_info2 { 516 proc p1 { arg } { 517 puts cmd 518 } 519 proc p2 { arg } { 520 puts cmd 521 } 522 } 523 lsort [info procs ::test_ns_info2::p*] 524} -result [lsort [list ::test_ns_info2::p1 ::test_ns_info2::p2]] 525test info-15.7 {info procs option with a global shadowing proc} -setup { 526 catch {namespace delete test_ns_info2} 527} -body { 528 proc string_cmd { arg } { 529 puts cmd 530 } 531 namespace eval test_ns_info2 { 532 proc string_cmd { arg } { 533 puts cmd 534 } 535 } 536 info procs test_ns_info2::string* 537} -result {::test_ns_info2::string_cmd} 538# This regression test is currently commented out because it requires 539# that the implementation of "info procs" looks into the global namespace, 540# which it does not (in contrast to "info commands") 541test info-15.8 {info procs option with a global shadowing proc} -setup { 542 catch {namespace delete test_ns_info2} 543} -constraints knownBug -body { 544 proc string_cmd { arg } { 545 puts cmd 546 } 547 proc string_cmd2 { arg } { 548 puts cmd 549 } 550 namespace eval test_ns_info2 { 551 proc string_cmd { arg } { 552 puts cmd 553 } 554 } 555 namespace eval test_ns_info2 { 556 lsort [info procs string*] 557 } 558} -result [lsort [list string_cmd string_cmd2]] 559 560test info-16.1 {info script option} -returnCodes error -body { 561 info script x x 562} -result {wrong # args: should be "info script ?filename?"} 563test info-16.2 {info script option} { 564 file tail [info sc] 565} "info.test" 566set gorpfile [makeFile "info script\n" gorp.info] 567test info-16.3 {info script option} { 568 list [source $gorpfile] [file tail [info script]] 569} [list $gorpfile info.test] 570test info-16.4 {resetting "info script" after errors} { 571 catch {source ~_nobody_/foo} 572 file tail [info script] 573} "info.test" 574test info-16.5 {resetting "info script" after errors} { 575 catch {source _nonexistent_} 576 file tail [info script] 577} "info.test" 578test info-16.6 {info script option} -body { 579 set script [info script] 580 list [file tail [info script]] \ 581 [info script newname.txt] \ 582 [file tail [info script $script]] 583} -result [list info.test newname.txt info.test] -cleanup {unset script} 584test info-16.7 {info script option} -body { 585 set script [info script] 586 info script newname.txt 587 list [source $gorpfile] [file tail [info script]] \ 588 [file tail [info script $script]] 589} -result [list $gorpfile newname.txt info.test] -cleanup {unset script} 590removeFile gorp.info 591set gorpfile [makeFile {list [info script] [info script foo.bar]} gorp.info] 592test info-16.8 {info script option} { 593 list [source $gorpfile] [file tail [info script]] 594} [list [list $gorpfile foo.bar] info.test] 595removeFile gorp.info; unset gorpfile 596 597test info-17.1 {info sharedlibextension option} -returnCodes error -body { 598 info sharedlibextension foo 599} -result {wrong # args: should be "info sharedlibextension"} 600 601test info-18.1 {info tclversion option} -body { 602 scan [info tclversion] "%d.%d%c" a b c 603} -cleanup {unset -nocomplain a b c} -result 2 604test info-18.2 {info tclversion option} -body { 605 info t 2 606} -returnCodes error -result {wrong # args: should be "info tclversion"} 607test info-18.3 {info tclversion option} -body { 608 unset tcl_version 609 info tclversion 610} -returnCodes error -setup { 611 set t $tcl_version 612} -cleanup { 613 set tcl_version $t; unset t 614} -result {can't read "tcl_version": no such variable} 615 616test info-19.1 {info vars option} -body { 617 set a 1 618 set b 2 619 proc t1 {x y} { 620 global a b 621 set c 33 622 return [info vars] 623 } 624 lsort [t1 18 19] 625} -cleanup {unset a b} -result {a b c x y} 626test info-19.2 {info vars option} -body { 627 set xxx1 1 628 set xxx2 2 629 proc t1 {xxa y} { 630 global xxx1 xxx2 631 set c 33 632 return [info vars x*] 633 } 634 lsort [t1 18 19] 635} -cleanup {unset xxx1 xxx2} -result {xxa xxx1 xxx2} 636test info-19.3 {info vars option} { 637 lsort [info vars] 638} [lsort [info globals]] 639test info-19.4 {info vars option} -returnCodes error -body { 640 info vars a b 641} -result {wrong # args: should be "info vars ?pattern?"} 642test info-19.5 {info vars with temporary variables} { 643 proc t1 {} { 644 foreach a {b c} {} 645 info vars 646 } 647 t1 648} {a} 649test info-19.6 {info vars: Bug 1072654} -setup { 650 namespace eval :: unset -nocomplain foo 651 catch {namespace delete x} 652} -body { 653 namespace eval x info vars foo 654} -cleanup { 655 namespace delete x 656} -result {} 657 658set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isfinite isinf isnan isnormal isqrt issubnormal isunordered log log10 max min pow rand round sin sinh sqrt srand tan tanh wide} 659# Check whether the extra testing functions are defined... 660if {!([catch {expr {T1()}} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"}))} { 661 set functions "T1 T2 T3 $functions" ;# A lazy way of prepending! 662} 663test info-20.1 {info functions option} {info functions sin} sin 664test info-20.2 {info functions option} {lsort [info functions]} $functions 665test info-20.3 {info functions option} { 666 lsort [info functions a*] 667} {abs acos asin atan atan2} 668test info-20.4 {info functions option} { 669 lsort [info functions *tan*] 670} {atan atan2 tan tanh} 671test info-20.5 {info functions option} -returnCodes error -body { 672 info functions raise an error 673} -result {wrong # args: should be "info functions ?pattern?"} 674unset functions msg 675 676test info-21.1 {miscellaneous error conditions} -returnCodes error -body { 677 info 678} -result {wrong # args: should be "info subcommand ?arg ...?"} 679test info-21.2 {miscellaneous error conditions} -returnCodes error -body { 680 info gorp 681} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} 682test info-21.3 {miscellaneous error conditions} -returnCodes error -body { 683 info c 684} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} 685test info-21.4 {miscellaneous error conditions} -returnCodes error -body { 686 info l 687} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} 688test info-21.5 {miscellaneous error conditions} -returnCodes error -body { 689 info s 690} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} 691 692## 693# ### ### ### ######### ######### ######### 694## info frame 695 696## Helper 697# For the more complex results we cut the file name down to remove path 698# dependencies, and we use only part of the first line of the reported 699# command. The latter is required because otherwise the whole test case may 700# appear in some results, but the result is part of the testcase. An infinite 701# string would be required to describe that. The cutting-down breaks this. 702 703proc reduce {frame} { 704 set cmd [dict get $frame cmd] 705 if {[regexp \n $cmd]} { 706 dict set frame cmd \ 707 [string range [lindex [split $cmd \n] 0] 0 end-4] 708 } 709 if {[dict exists $frame file]} { 710 dict set frame file \ 711 [file tail [dict get $frame file]] 712 } 713 return $frame 714} 715 716proc subinterp {} { interp create sub ; interp debug sub -frame 1; 717 interp eval sub [list proc reduce [info args reduce] [info body reduce]] 718} 719 720## Helper 721# Generate a stacktrace from the current location to top. This code 722# not only depends on the exact location of things, but also on the 723# implementation of tcltest. Any changes and these tests will have to 724# be updated. 725 726proc etrace {} { 727 set res {} 728 set level [info frame] 729 while {$level} { 730 lappend res [list $level [reduce [info frame $level]]] 731 incr level -1 732 } 733 return $res 734} 735 736test info-22.0 {info frame, levels} {!singleTestInterp} { 737 info frame 738} 7 739test info-22.1 {info frame, bad level relative} {!singleTestInterp} { 740 # catch is another level!, i.e. we have 8, not 7 741 catch {info frame -8} msg 742 set msg 743} {bad level "-8"} 744test info-22.2 {info frame, bad level absolute} {!singleTestInterp} { 745 # catch is another level!, i.e. we have 8, not 7 746 catch {info frame 9} msg 747 set msg 748} {bad level "9"} 749test info-22.3 {info frame, current, relative} -match glob -body { 750 info frame 0 751} -result {type source line 750 file */info.test cmd {info frame 0} proc ::tcltest::RunTest} 752test info-22.4 {info frame, current, relative, nested} -match glob -body { 753 set res [info frame 0] 754} -result {type source line 753 file */info.test cmd {info frame 0} proc ::tcltest::RunTest} -cleanup {unset res} 755test info-22.5 {info frame, current, absolute} -constraints {!singleTestInterp} -match glob -body { 756 reduce [info frame 7] 757} -result {type source line 756 file info.test cmd {info frame 7} proc ::tcltest::RunTest} 758test info-22.6 {info frame, global, relative} {!singleTestInterp} { 759 reduce [info frame -6] 760} {type source line 758 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0} 761test info-22.7 {info frame, global, absolute} {!singleTestInterp} { 762 reduce [info frame 1] 763} {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0} 764test info-22.8 {info frame, basic trace} -match glob -body { 765 join [lrange [etrace] 0 2] \n 766} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} 767* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest} 768* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}} 769unset -nocomplain msg 770 771 772 773 774 775 776 777 778 779 780## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0 781test info-23.0 {eval'd info frame} -constraints {!singleTestInterp} -body { 782 list [i eval {info frame}] [i eval {eval {info frame}}] 783} -setup {interp create i} -cleanup {interp delete i} -result {1 2} 784test info-23.1 {eval'd info frame, semi-dynamic} -constraints {!singleTestInterp} -body { 785 i eval {eval info frame} 786} -setup {interp create i} -cleanup {interp delete i} -result 2 787test info-23.2 {eval'd info frame, dynamic} -constraints {!singleTestInterp} -body { 788 i eval { set script {info frame} 789 eval $script} 790} -setup {interp create i} -cleanup {interp delete i} -result 2 791test info-23.3 {eval'd info frame, literal} -match glob -body { 792 eval { 793 info frame 0 794 } 795} -result {type source line 793 file * cmd {info frame 0} proc ::tcltest::RunTest} 796test info-23.4 {eval'd info frame, semi-dynamic} { 797 eval info frame 0 798} {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest} 799test info-23.5 {eval'd info frame, dynamic} -cleanup {unset script} -body { 800 set script {info frame 0} 801 eval $script 802} -result {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest} 803test info-23.6 {eval'd info frame, trace} -match glob -cleanup {unset script} -body { 804 set script {etrace} 805 join [lrange [eval $script] 0 2] \n 806} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} 807* {type eval line 1 cmd etrace proc ::tcltest::RunTest} 808* {type source line 805 file info.test cmd {eval $script} proc ::tcltest::RunTest}} 809 810# ------------------------------------------------------------------------- 811 812# Procedures defined in scripts which are arguments to control 813# structures (like 'namespace eval', 'interp eval', 'if', 'while', 814# 'switch', 'catch', 'for', 'foreach', etc.) have no absolute 815# location. The command implementations execute such scripts through 816# Tcl_EvalObjEx. Flag 0 causes it to use the bytecode compiler. This 817# causes the connection to the context to be lost. Currently only 818# procedure bodies are able to remember their context. 819 820# NOTE THAT THESE DO NOT USE THE -setup OPTION TO [test] 821 822# ------------------------------------------------------------------------- 823 824namespace eval foo { 825 proc bar {} {info frame 0} 826} 827 828test info-24.0 {info frame, interaction, namespace eval} -body { 829 reduce [foo::bar] 830} -cleanup { 831 namespace delete foo 832} -result {type source line 825 file info.test cmd {info frame 0} proc ::foo::bar level 0} 833 834# ------------------------------------------------------------------------- 835 836set flag 1 837if {$flag} { 838 namespace eval foo {} 839 proc ::foo::bar {} {info frame 0} 840} 841 842test info-24.1 {info frame, interaction, if} -body { 843 reduce [foo::bar] 844} -cleanup { 845 namespace delete foo 846} -result {type source line 839 file info.test cmd {info frame 0} proc ::foo::bar level 0} 847 848# ------------------------------------------------------------------------- 849 850set flag 1 851while {$flag} { 852 namespace eval foo {} 853 proc ::foo::bar {} {info frame 0} 854 set flag 0 855};unset flag 856 857test info-24.2 {info frame, interaction, while} -body { 858 reduce [foo::bar] 859} -cleanup { 860 namespace delete foo 861} -result {type source line 853 file info.test cmd {info frame 0} proc ::foo::bar level 0} 862 863# ------------------------------------------------------------------------- 864 865catch { 866 namespace eval foo {} 867 proc ::foo::bar {} {info frame 0} 868} 869 870test info-24.3 {info frame, interaction, catch} -body { 871 reduce [foo::bar] 872} -cleanup { 873 namespace delete foo 874} -result {type source line 867 file info.test cmd {info frame 0} proc ::foo::bar level 0} 875 876# ------------------------------------------------------------------------- 877 878foreach var val { 879 namespace eval foo {} 880 proc ::foo::bar {} {info frame 0} 881 break 882}; unset var 883 884test info-24.4 {info frame, interaction, foreach} -body { 885 reduce [foo::bar] 886} -cleanup { 887 namespace delete foo 888} -result {type source line 880 file info.test cmd {info frame 0} proc ::foo::bar level 0} 889 890# ------------------------------------------------------------------------- 891 892for {} {1} {} { 893 namespace eval foo {} 894 proc ::foo::bar {} {info frame 0} 895 break 896} 897 898test info-24.5 {info frame, interaction, for} -body { 899 reduce [foo::bar] 900} -cleanup { 901 namespace delete foo 902} -result {type source line 894 file info.test cmd {info frame 0} proc ::foo::bar level 0} 903 904# ------------------------------------------------------------------------- 905 906namespace eval foo {} 907set x foo 908switch -exact -- $x { 909 foo { 910 proc ::foo::bar {} {info frame 0} 911 } 912} 913 914test info-24.6.0 {info frame, interaction, switch, list body} -body { 915 reduce [foo::bar] 916} -cleanup { 917 namespace delete foo 918 unset x 919} -result {type source line 910 file info.test cmd {info frame 0} proc ::foo::bar level 0} 920 921# ------------------------------------------------------------------------- 922 923namespace eval foo {} 924set x foo 925switch -exact -- $x foo { 926 proc ::foo::bar {} {info frame 0} 927} 928 929test info-24.6.1 {info frame, interaction, switch, multi-body} -body { 930 reduce [foo::bar] 931} -cleanup { 932 namespace delete foo 933 unset x 934} -result {type source line 926 file info.test cmd {info frame 0} proc ::foo::bar level 0} 935 936# ------------------------------------------------------------------------- 937 938namespace eval foo {} 939set x foo 940switch -exact -- $x [list foo { 941 proc ::foo::bar {} {info frame 0} 942}] 943 944test info-24.6.2 {info frame, interaction, switch, list body, dynamic} -body { 945 reduce [foo::bar] 946} -cleanup { 947 namespace delete foo 948 unset x 949} -result {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} 950 951# ------------------------------------------------------------------------- 952 953namespace eval foo {} 954dict for {k v} {foo bar} { 955 proc ::foo::bar {} {info frame 0} 956} 957 958test info-24.7 {info frame, interaction, dict for} { 959 reduce [foo::bar] 960} {type source line 955 file info.test cmd {info frame 0} proc ::foo::bar level 0} 961 962namespace delete foo; unset k v 963 964# ------------------------------------------------------------------------- 965 966namespace eval foo {} 967set thedict {foo bar} 968dict with thedict { 969 proc ::foo::bar {} {info frame 0} 970} 971 972test info-24.8 {info frame, interaction, dict with} { 973 reduce [foo::bar] 974} {type source line 969 file info.test cmd {info frame 0} proc ::foo::bar level 0} 975 976namespace delete foo 977unset thedict foo 978 979# ------------------------------------------------------------------------- 980 981namespace eval foo {} 982dict filter {foo bar} script {k v} { 983 proc ::foo::bar {} {info frame 0} 984 set x 1 985}; unset k v x 986 987test info-24.9 {info frame, interaction, dict filter} { 988 reduce [foo::bar] 989} {type source line 983 file info.test cmd {info frame 0} proc ::foo::bar level 0} 990 991namespace delete foo 992#unset x 993 994# ------------------------------------------------------------------------- 995 996eval { 997 proc bar {} {info frame 0} 998} 999 1000test info-25.0 {info frame, proc in eval} { 1001 reduce [bar] 1002} {type source line 997 file info.test cmd {info frame 0} proc ::bar level 0} 1003# Don't need to clean up yet... 1004 1005proc bar {} {info frame 0} 1006 1007test info-25.1 {info frame, regular proc} { 1008 reduce [bar] 1009} {type source line 1005 file info.test cmd {info frame 0} proc ::bar level 0} 1010 1011rename bar {} 1012 1013# ------------------------------------------------------------------------- 1014# More info-30.x test cases at the end of the file. 1015test info-30.0 {bs+nl in literal words} -cleanup {unset res} -body { 1016 if {1} { 1017 set res \ 1018 [reduce [info frame 0]];#1018 1019 } 1020 return $res 1021 # This was reporting line 3 instead of the correct 4 because the 1022 # bs+nl combination is subst by the parser before the 'if' 1023 # command, and the bcc, see the word. Fixed by recording the 1024 # offsets of all bs+nl sequences in literal words, then using the 1025 # information in the bcc and other places to bump line numbers when 1026 # parsing over the location. Also affected: testcases 22.8 and 23.6. 1027} -result {type source line 1018 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1028 1029# ------------------------------------------------------------------------- 1030# See 24.0 - 24.5 for similar situations, using literal scripts. 1031 1032set body {set flag 0 1033 set a c 1034 set res [info frame 0]} ;# line 3! 1035 1036test info-31.0 {ns eval, script in variable} -body {namespace eval foo {variable res {}} 1037 namespace eval foo $body 1038 return $foo::res 1039} -result {type eval line 3 cmd {info frame 0} level 0} -cleanup { 1040 catch {namespace delete foo} 1041} 1042test info-31.1 {if, script in variable} -cleanup {unset res a flag} -body { 1043 if 1 $body 1044 return $res 1045} -result {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} 1046 1047test info-31.1a {if, script in variable} -cleanup {unset res a flag} -body { 1048 if 1 then $body 1049 return $res 1050} -result {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} 1051 1052test info-31.2 {while, script in variable} -cleanup {unset flag res a} -body { 1053 set flag 1 1054 while {$flag} $body 1055 return $res 1056} -result {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} 1057 1058# .3 - proc - scoping prevent return of result ... 1059 1060test info-31.4 {foreach, script in variable} -cleanup {unset var res a flag} -body { 1061 foreach var val $body 1062 set res 1063} -result {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} 1064 1065test info-31.5 {for, script in variable} -cleanup {unset flag res a} -body { 1066 set flag 1 1067 for {} {$flag} {} $body 1068 return $res 1069} -result {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} 1070 1071test info-31.6 {eval, script in variable} -cleanup {unset res a flag} -body { 1072 eval $body 1073 return $res 1074} -result {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} 1075 1076# ------------------------------------------------------------------------- 1077 1078set body { 1079 foo { 1080 proc ::foo::bar {} {info frame 0} 1081 } 1082} 1083 1084namespace eval foo {} 1085set x foo 1086switch -exact -- $x $body; unset body 1087 1088test info-31.7 {info frame, interaction, switch, dynamic} -body { 1089 reduce [foo::bar] 1090} -cleanup { 1091 namespace delete foo 1092 unset x 1093} -result {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} 1094 1095# ------------------------------------------------------------------------- 1096 1097set body { 1098 proc ::foo::bar {} {info frame 0} 1099} 1100 1101namespace eval foo {} 1102eval $body 1103 1104test info-32.0 {info frame, dynamic procedure} -body { 1105 reduce [foo::bar] 1106} -cleanup { 1107 namespace delete foo 1108} -result {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} 1109 1110# ------------------------------------------------------------------------- 1111 1112namespace {*}{ 1113 eval 1114 foo 1115 {proc bar {} {info frame 0}} 1116} 1117test info-33.0 {{*}, literal, direct} -body { 1118 reduce [foo::bar] 1119} -cleanup { 1120 namespace delete foo 1121} -result {type source line 1115 file info.test cmd {info frame 0} proc ::foo::bar level 0} 1122 1123# ------------------------------------------------------------------------- 1124 1125namespace eval foo {} 1126proc foo::bar {} { 1127 set flag 1 1128 if {*}{ 1129 {$flag} 1130 {info frame 0} 1131 } 1132} 1133test info-33.1 {{*}, literal, simple, bytecompiled} -body { 1134 reduce [foo::bar] 1135} -cleanup { 1136 namespace delete foo 1137} -result {type source line 1130 file info.test cmd {info frame 0} proc ::foo::bar level 0} 1138 1139# ------------------------------------------------------------------------- 1140 1141namespace {*}" 1142 eval 1143 foo 1144 {proc bar {} {info frame 0}} 1145" 1146test info-33.2 {{*}, literal, direct} { 1147 reduce [foo::bar] 1148} {type source line 1144 file info.test cmd {info frame 0} proc ::foo::bar level 0} 1149 1150namespace delete foo 1151 1152# ------------------------------------------------------------------------- 1153 1154namespace {*}"eval\nfoo\n{proc bar {} {info frame 0}}\n" 1155 1156test info-33.2a {{*}, literal, not simple, direct} { 1157 reduce [foo::bar] 1158} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} 1159 1160namespace delete foo 1161 1162# ------------------------------------------------------------------------- 1163 1164namespace eval foo {} 1165proc foo::bar {} { 1166 set flag 1 1167 if {*}" 1168 {1} 1169 {info frame 0} 1170 " 1171} 1172test info-33.3 {{*}, literal, simple, bytecompiled} { 1173 reduce [foo::bar] 1174} {type source line 1169 file info.test cmd {info frame 0} proc ::foo::bar level 0} 1175 1176namespace delete foo 1177 1178# ------------------------------------------------------------------------- 1179 1180namespace eval foo {} 1181proc foo::bar {} { 1182 set flag 1 1183 if {*}"\n{1}\n{info frame 0}" 1184} 1185test info-33.3a {{*}, literal, not simple, bytecompiled} { 1186 reduce [foo::bar] 1187} {type eval line 1 cmd {info frame 0} proc ::foo::bar level 0} 1188 1189namespace delete foo 1190 1191# ------------------------------------------------------------------------- 1192 1193set body { 1194 eval 1195 foo 1196 {proc bar {} { 1197 info frame 0 1198 }} 1199} 1200namespace {*}$body 1201test info-34.0 {{*}, dynamic, direct} { 1202 reduce [foo::bar] 1203} {type proc line 2 cmd {info frame 0} proc ::foo::bar level 0} 1204 1205unset body 1206namespace delete foo 1207 1208# ------------------------------------------------------------------------- 1209 1210namespace eval foo {} 1211set body { 1212 {$flag} 1213 {info frame 0} 1214} 1215proc foo::bar {} { 1216 global body ; set flag 1 1217 if {*}$body 1218} 1219test info-34.1 {{*}, literal, bytecompiled} { 1220 reduce [foo::bar] 1221} {type eval line 1 cmd {info frame 0} proc ::foo::bar level 0} 1222 1223unset body 1224namespace delete foo 1225 1226# ------------------------------------------------------------------------- 1227 1228proc foo {} { 1229 apply { 1230 {x y} 1231 {info frame 0} 1232 } 0 0 1233} 1234test info-35.0 {apply, literal} { 1235 reduce [foo] 1236} {type source line 1231 file info.test cmd {info frame 0} lambda { 1237 {x y} 1238 {info frame 0} 1239 } level 0} 1240rename foo {} 1241 1242set lambda { 1243 {x y} 1244 {info frame 0} 1245} 1246test info-35.1 {apply, dynamic} { 1247 reduce [apply $lambda 0 0] 1248} {type proc line 1 cmd {info frame 0} lambda { 1249 {x y} 1250 {info frame 0} 1251} level 0} 1252unset lambda 1253 1254# ------------------------------------------------------------------------- 1255 1256namespace eval foo {} 1257proc foo::bar {} { 1258 dict for {k v} {foo bar} { 1259 set x [info frame 0] 1260 } 1261 set x 1262} 1263test info-36.0 {info frame, dict for, bcc} -body { 1264 reduce [foo::bar] 1265} -result {type source line 1259 file info.test cmd {info frame 0} proc ::foo::bar level 0} 1266 1267namespace delete foo 1268 1269# ------------------------------------------------------------------------- 1270 1271namespace eval foo {} 1272proc foo::bar {} { 1273 set x foo 1274 switch -exact -- $x { 1275 foo {set y [info frame 0]} 1276 } 1277 set y 1278} 1279 1280test info-36.1.0 {switch, list literal, bcc} -body { 1281 reduce [foo::bar] 1282} -result {type source line 1275 file info.test cmd {info frame 0} proc ::foo::bar level 0} 1283 1284namespace delete foo 1285 1286# ------------------------------------------------------------------------- 1287 1288namespace eval foo {} 1289proc foo::bar {} { 1290 set x foo 1291 switch -exact -- $x foo {set y [info frame 0]} 1292 set y 1293} 1294 1295test info-36.1.1 {switch, multi-body literals, bcc} -body { 1296 reduce [foo::bar] 1297} -result {type source line 1291 file info.test cmd {info frame 0} proc ::foo::bar level 0} 1298 1299namespace delete foo 1300 1301# ------------------------------------------------------------------------- 1302 1303test info-37.0 {eval pure list, single line} -match glob -body { 1304 # Basically, counting the newline in the word seen through $foo 1305 # doesn't really make sense. It makes a bit of sense if the word 1306 # would have been a string literal in the command list. 1307 # 1308 # Problem: At the point where we see the list elements we cannot 1309 # distinguish the two cases, thus we cannot switch between 1310 # count/not-count, it is has to be one or the other for all 1311 # cases. Of the two possibilities miguel convinced me that 'not 1312 # counting' is the more proper. 1313 set foo {b 1314 c} 1315 set cmd [list foreach $foo {x y} { 1316 set res [join [lrange [etrace] 0 2] \n] 1317 break 1318 }] 1319 eval $cmd 1320 return $res 1321} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} 1322* {type eval line 2 cmd etrace proc ::tcltest::RunTest} 1323* {type eval line 1 cmd foreac proc ::tcltest::RunTest}} -cleanup {unset foo cmd res b c} 1324 1325# ------------------------------------------------------------------------- 1326 1327# 6 cases. 1328## DV. direct-var - unchanged 1329## DPV direct-proc-var - ditto 1330## PPV proc-proc-var - ditto 1331## DL. direct-literal - now tracking absolute location 1332## DPL direct-proc-literal - ditto 1333## PPL proc-proc-literal - ditto 1334## ### ### ### ######### ######### #########" 1335 1336proc control {vv script} { 1337 upvar 1 $vv var 1338 return [uplevel 1 $script] 1339} 1340 1341proc datal {} { 1342 control y { 1343 set y PPL 1344 etrace 1345 } 1346} 1347 1348proc datav {} { 1349 set script { 1350 set y PPV 1351 etrace 1352 } 1353 control y $script 1354} 1355 1356test info-38.1 {location information for uplevel, dv, direct-var} -match glob -body { 1357 set script { 1358 set y DV. 1359 etrace 1360 } 1361 join [lrange [uplevel \#0 $script] 0 2] \n 1362} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} 1363* {type eval line 3 cmd etrace proc ::tcltest::RunTest} 1364* {type source line 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y} 1365 1366# 38.2 moved to bottom to not disturb other tests with the necessary changes to this one. 1367 1368 1369 1370 1371 1372 1373 1374 1375test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match glob -body { 1376 set script { 1377 set y DPV 1378 etrace 1379 } 1380 join [lrange [control y $script] 0 3] \n 1381} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} 1382* {type eval line 3 cmd etrace proc ::control} 1383* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} 1384* {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y} 1385 1386# 38.4 moved to bottom to not disturb other tests with the necessary changes to this one. 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body { 1397 join [lrange [datav] 0 4] \n 1398} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} 1399* {type eval line 3 cmd etrace proc ::control} 1400* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} 1401* {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1} 1402* {type source line 1397 file info.test cmd datav proc ::tcltest::RunTest}} 1403 1404# 38.6 moved to bottom to not disturb other tests with the necessary changes to this one. 1405 1406 1407 1408 1409 1410 1411 1412testConstraint testevalex [llength [info commands testevalex]] 1413test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body { 1414 join [lrange [testevalex {return -level 0 [etrace]}] 0 3] \n 1415} -result {* {type source line 730 file info.test cmd {info frame \$level} proc ::etrace level 0} 1416* {type eval line 1 cmd etrace proc ::tcltest::RunTest} 1417* {type source line 1414 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest} 1418* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}} 1419 1420# ------------------------------------------------------------------------- 1421# literal sharing 1422 1423test info-39.0 {location information not confused by literal sharing} -body { 1424 namespace eval ::foo {} 1425 proc ::foo::bar {} { 1426 lappend res {} 1427 lappend res [reduce [eval {info frame 0}]] 1428 lappend res [reduce [eval {info frame 0}]] 1429 return $res 1430 } 1431 set res [::foo::bar] 1432 namespace delete ::foo 1433 join $res \n 1434} -cleanup {unset res} -result { 1435type source line 1427 file info.test cmd {info frame 0} proc ::foo::bar level 0 1436type source line 1428 file info.test cmd {info frame 0} proc ::foo::bar level 0} 1437 1438# ------------------------------------------------------------------------- 1439# Additional tests for info-30.*, handling of continuation lines (bs+nl sequences). 1440 1441test info-30.1 {bs+nl in literal words, procedure body, compiled} -body { 1442 proc abra {} { 1443 if {1} \ 1444 { 1445 return \ 1446 [reduce [info frame 0]];# line 1446 1447 } 1448 } 1449 abra 1450} -cleanup { 1451 rename abra {} 1452} -result {type source line 1446 file info.test cmd {info frame 0} proc ::abra level 0} 1453 1454test info-30.2 {bs+nl in literal words, namespace script} { 1455 namespace eval xxx { 1456 variable res \ 1457 [info frame 0];# line 1457 1458 } 1459 return [reduce $xxx::res] 1460} {type source line 1457 file info.test cmd {info frame 0} level 0} 1461 1462test info-30.3 {bs+nl in literal words, namespace multi-word script} { 1463 namespace eval xxx variable res \ 1464 [list [reduce [info frame 0]]];# line 1464 1465 return $xxx::res 1466} {type source line 1464 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1467 1468test info-30.4 {bs+nl in literal words, eval script} -cleanup {unset res} -body { 1469 eval { 1470 set ::res \ 1471 [reduce [info frame 0]];# line 1471 1472 } 1473 return $res 1474} -result {type source line 1471 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1475 1476test info-30.5 {bs+nl in literal words, eval script, with nested words} -body { 1477 eval { 1478 if {1} \ 1479 { 1480 set ::res \ 1481 [reduce [info frame 0]];# line 1481 1482 } 1483 } 1484 return $res 1485} -cleanup {unset res} -result {type source line 1481 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1486 1487test info-30.6 {bs+nl in computed word} -cleanup {unset res} -body { 1488 set res "\ 1489[reduce [info frame 0]]";# line 1489 1490} -result { type source line 1489 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1491 1492test info-30.7 {bs+nl in computed word, in proc} -body { 1493 proc abra {} { 1494 return "\ 1495[reduce [info frame 0]]";# line 1495 1496 } 1497 abra 1498} -cleanup { 1499 rename abra {} 1500} -result { type source line 1495 file info.test cmd {info frame 0} proc ::abra level 0} 1501 1502test info-30.8 {bs+nl in computed word, nested eval} -body { 1503 eval { 1504 set \ 1505 res "\ 1506[reduce [info frame 0]]";# line 1506 1507} 1508} -cleanup {unset res} -result { type source line 1506 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1509 1510test info-30.9 {bs+nl in computed word, nested eval} -body { 1511 eval { 1512 set \ 1513 res "\ 1514[reduce \ 1515 [info frame 0]]";# line 1515 1516} 1517} -cleanup {unset res} -result { type source line 1515 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1518 1519test info-30.10 {bs+nl in computed word, key to array} -body { 1520 set tmp([set \ 1521 res "\ 1522[reduce \ 1523 [info frame 0]]"]) x ; #1523 1524 unset tmp 1525 set res 1526} -cleanup {unset res} -result { type source line 1523 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1527 1528test info-30.11 {bs+nl in subst arguments} -body { 1529 subst {[set \ 1530 res "\ 1531[reduce \ 1532 [info frame 0]]"]} ; #1532 1533} -cleanup {unset res} -result { type source line 1532 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1534 1535test info-30.12 {bs+nl in computed word, nested eval} -body { 1536 eval { 1537 set \ 1538 res "\ 1539[set x {}] \ 1540[reduce \ 1541 [info frame 0]]";# line 1541 1542} 1543} -cleanup {unset res x} -result { type source line 1541 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1544 1545test info-30.13 {bs+nl in literal words, uplevel script, with nested words} -body { 1546 subinterp ; set res [interp eval sub { uplevel #0 { 1547 if {1} \ 1548 { 1549 set ::res \ 1550 [reduce [info frame 0]];# line 1550 1551 } 1552 } 1553 set res }] ; interp delete sub ; set res 1554} -cleanup {unset res} -result {type source line 1550 file info.test cmd {info frame 0} level 0} 1555 1556test info-30.14 {bs+nl, literal word, uplevel through proc} { 1557 subinterp ; set res [interp eval sub { proc abra {script} { 1558 uplevel 1 $script 1559 } 1560 set res [abra { 1561 return "\ 1562[reduce [info frame 0]]";# line 1562 1563 }] 1564 rename abra {} 1565 set res }] ; interp delete sub ; set res 1566} { type source line 1562 file info.test cmd {info frame 0} proc ::abra} 1567 1568test info-30.15 {bs+nl in literal words, nested proc body, compiled} { 1569 proc a {} { 1570 proc b {} { 1571 if {1} \ 1572 { 1573 return \ 1574 [reduce [info frame 0]];# line 1574 1575 } 1576 } 1577 } 1578 a ; set res [b] 1579 rename a {} 1580 rename b {} 1581 set res 1582} {type source line 1574 file info.test cmd {info frame 0} proc ::b level 0} 1583 1584test info-30.16 {bs+nl in multi-body switch, compiled} { 1585 proc a {value} { 1586 switch -regexp -- $value \ 1587 ^key { info frame 0; # 1587 } \ 1588 \t### { info frame 0; # 1588 } \ 1589 {[0-9]*} { info frame 0; # 1589 } 1590 } 1591 set res {} 1592 lappend res [reduce [a {key }]] 1593 lappend res [reduce [a {1alpha}]] 1594 set res "\n[join $res \n]" 1595} { 1596type source line 1587 file info.test cmd {info frame 0} proc ::a level 0 1597type source line 1589 file info.test cmd {info frame 0} proc ::a level 0} 1598 1599test info-30.17 {bs+nl in multi-body switch, direct} { 1600 switch -regexp -- {key } \ 1601 ^key { reduce [info frame 0] ;# 1601 } \ 1602 \t### { } \ 1603 {[0-9]*} { } 1604} {type source line 1601 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1605 1606test info-30.18 {bs+nl, literal word, uplevel through proc, appended, loss of primary tracking data} { 1607 proc abra {script} { 1608 append script "\n# end of script" 1609 uplevel 1 $script 1610 } 1611 set res [abra { 1612 return "\ 1613[reduce [info frame 0]]";# line 1613, still line of 3 appended script 1614 }] 1615 rename abra {} 1616 set res 1617} { type eval line 3 cmd {info frame 0} proc ::abra} 1618# { type source line 1606 file info.test cmd {info frame 0} proc ::abra} 1619 1620test info-30.19 {bs+nl in single-body switch, compiled} { 1621 proc a {value} { 1622 switch -regexp -- $value { 1623 ^key { reduce \ 1624 [info frame 0] } 1625 \t { reduce \ 1626 [info frame 0] } 1627 {[0-9]*} { reduce \ 1628 [info frame 0] } 1629 } 1630 } 1631 set res {} 1632 lappend res [a {key }] 1633 lappend res [a {1alpha}] 1634 set res "\n[join $res \n]" 1635} { 1636type source line 1624 file info.test cmd {info frame 0} proc ::a level 0 1637type source line 1628 file info.test cmd {info frame 0} proc ::a level 0} 1638 1639test info-30.20 {bs+nl in single-body switch, direct} { 1640 switch -regexp -- {key } { \ 1641 1642 ^key { reduce \ 1643 [info frame 0] } 1644 \t### { } 1645 {[0-9]*} { } 1646 } 1647} {type source line 1643 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1648 1649test info-30.21 {bs+nl in if, full compiled} { 1650 proc a {value} { 1651 if {$value} \ 1652 {info frame 0} \ 1653 {info frame 0} ; # 1653 1654 } 1655 set res {} 1656 lappend res [reduce [a 1]] 1657 lappend res [reduce [a 0]] 1658 set res "\n[join $res \n]" 1659} { 1660type source line 1652 file info.test cmd {info frame 0} proc ::a level 0 1661type source line 1653 file info.test cmd {info frame 0} proc ::a level 0} 1662 1663test info-30.22 {bs+nl in computed word, key to array, compiled} { 1664 proc a {} { 1665 set tmp([set \ 1666 res "\ 1667[reduce \ 1668 [info frame 0]]"]) x ; #1668 1669 unset tmp 1670 set res 1671 } 1672 set res [a] 1673 rename a {} 1674 set res 1675} { type source line 1668 file info.test cmd {info frame 0} proc ::a level 0} 1676 1677test info-30.23 {bs+nl in multi-body switch, full compiled} { 1678 proc a {value} { 1679 switch -exact -- $value \ 1680 key { info frame 0; # 1680 } \ 1681 xxx { info frame 0; # 1681 } \ 1682 000 { info frame 0; # 1682 } 1683 } 1684 set res {} 1685 lappend res [reduce [a key]] 1686 lappend res [reduce [a 000]] 1687 set res "\n[join $res \n]" 1688} { 1689type source line 1680 file info.test cmd {info frame 0} proc ::a level 0 1690type source line 1682 file info.test cmd {info frame 0} proc ::a level 0} 1691 1692test info-30.24 {bs+nl in single-body switch, full compiled} { 1693 proc a {value} { 1694 switch -exact -- $value { 1695 key { reduce \ 1696 [info frame 0] } 1697 xxx { reduce \ 1698 [info frame 0] } 1699 000 { reduce \ 1700 [info frame 0] } 1701 } 1702 } 1703 set res {} 1704 lappend res [a key] 1705 lappend res [a 000] 1706 set res "\n[join $res \n]" 1707} { 1708type source line 1696 file info.test cmd {info frame 0} proc ::a level 0 1709type source line 1700 file info.test cmd {info frame 0} proc ::a level 0} 1710 1711test info-30.25 {TIP 280 for compiled [subst]} { 1712 subst {[reduce [info frame 0]]} ; # 1712 1713} {type source line 1712 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1714test info-30.26 {TIP 280 for compiled [subst]} { 1715 subst \ 1716 {[reduce [info frame 0]]} ; # 1716 1717} {type source line 1716 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1718test info-30.27 {TIP 280 for compiled [subst]} { 1719 subst { 1720[reduce [info frame 0]]} ; # 1720 1721} { 1722type source line 1720 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1723test info-30.28 {TIP 280 for compiled [subst]} { 1724 subst {\ 1725[reduce [info frame 0]]} ; # 1725 1726} { type source line 1725 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1727test info-30.29 {TIP 280 for compiled [subst]} { 1728 subst {foo\ 1729[reduce [info frame 0]]} ; # 1729 1730} {foo type source line 1729 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1731test info-30.30 {TIP 280 for compiled [subst]} { 1732 subst {foo 1733[reduce [info frame 0]]} ; # 1733 1734} {foo 1735type source line 1733 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1736test info-30.31 {TIP 280 for compiled [subst]} { 1737 subst {[][reduce [info frame 0]]} ; # 1737 1738} {type source line 1737 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1739test info-30.32 {TIP 280 for compiled [subst]} { 1740 subst {[\ 1741][reduce [info frame 0]]} ; # 1741 1742} {type source line 1741 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1743test info-30.33 {TIP 280 for compiled [subst]} { 1744 subst {[ 1745][reduce [info frame 0]]} ; # 1745 1746} {type source line 1745 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1747test info-30.34 {TIP 280 for compiled [subst]} { 1748 subst {[format %s {} 1749][reduce [info frame 0]]} ; # 1749 1750} {type source line 1749 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1751test info-30.35 {TIP 280 for compiled [subst]} { 1752 subst {[format %s {} 1753] 1754[reduce [info frame 0]]} ; # 1754 1755} { 1756type source line 1754 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1757test info-30.36 {TIP 280 for compiled [subst]} { 1758 subst { 1759[format %s {}][reduce [info frame 0]]} ; # 1759 1760} { 1761type source line 1759 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1762test info-30.37 {TIP 280 for compiled [subst]} { 1763 subst { 1764[format %s {}] 1765[reduce [info frame 0]]} ; # 1765 1766} { 1767 1768type source line 1765 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1769test info-30.38 {TIP 280 for compiled [subst]} { 1770 subst {\ 1771[format %s {}][reduce [info frame 0]]} ; # 1771 1772} { type source line 1771 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1773test info-30.39 {TIP 280 for compiled [subst]} { 1774 subst {\ 1775[format %s {}]\ 1776[reduce [info frame 0]]} ; # 1776 1777} { type source line 1776 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1778test info-30.40 {TIP 280 for compiled [subst]} -setup { 1779 unset -nocomplain empty 1780} -body { 1781 set empty {} 1782 subst {$empty[reduce [info frame 0]]} ; # 1782 1783} -cleanup { 1784 unset empty 1785} -result {type source line 1782 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1786test info-30.41 {TIP 280 for compiled [subst]} -setup { 1787 unset -nocomplain empty 1788} -body { 1789 set empty {} 1790 subst {$empty 1791[reduce [info frame 0]]} ; # 1791 1792} -cleanup { 1793 unset empty 1794} -result { 1795type source line 1791 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1796test info-30.42 {TIP 280 for compiled [subst]} -setup { 1797 unset -nocomplain empty 1798} -body { 1799 set empty {}; subst {$empty\ 1800[reduce [info frame 0]]} ; # 1800 1801} -cleanup { 1802 unset empty 1803} -result { type source line 1800 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1804test info-30.43 {TIP 280 for compiled [subst]} -body { 1805 unset -nocomplain a\nb 1806 set a\nb {} 1807 subst {${a 1808b}[reduce [info frame 0]]} ; # 1808 1809} -cleanup {unset a\nb} -result {type source line 1808 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1810test info-30.44 {TIP 280 for compiled [subst]} { 1811 unset -nocomplain a 1812 set a(\n) {} 1813 subst {$a( 1814)[reduce [info frame 0]]} ; # 1814 1815} {type source line 1814 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1816test info-30.45 {TIP 280 for compiled [subst]} { 1817 unset -nocomplain a 1818 set a() {} 1819 subst {$a([ 1820return -level 0])[reduce [info frame 0]]} ; # 1820 1821} {type source line 1820 file info.test cmd {info frame 0} proc ::tcltest::RunTest} 1822test info-30.46 {TIP 280 for compiled [subst]} { 1823 unset -nocomplain a 1824 set a(1825) YES; set a(1824) 1824; set a(1826) 1826 1825 subst {$a([dict get [info frame 0] line])} ; # 1825 1826} YES 1827test info-30.47 {TIP 280 for compiled [subst]} { 1828 unset -nocomplain a 1829 set a(\n1831) YES; set a(\n1830) 1830; set a(\n1832) 1832 1830 subst {$a( 1831[dict get [info frame 0] line])} ; # 1831 1832} YES 1833unset -nocomplain a 1834 1835test info-30.48 {Bug 2850901} testevalex { 1836 testevalex {return -level 0 [format %s {} 1837][reduce [info frame 0]]} ; # line 2 of the eval 1838} {type eval line 2 cmd {info frame 0} proc ::tcltest::RunTest} 1839 1840 1841# ------------------------------------------------------------------------- 1842# literal sharing 2, bug 2933089 1843 1844test info-39.1 {location information not confused by literal sharing, bug 2933089} -setup { 1845 set result {} 1846 1847 proc print_one {} {} 1848 proc test_info_frame {} { 1849 set x 1 1850 set y x 1851 1852 if "$x != 1" { 1853 } else { 1854 print_one 1855 } ;#line 1854^ 1856 1857 if "$$y != 1" { 1858 } else { 1859 print_one 1860 } ;#line 1859^ 1861 # Do not put the comments listing the line numbers into the 1862 # branches. We need shared literals, and the comments would 1863 # make them different, thus unshared. 1864 } 1865 1866 proc get_frame_info { cmd_str op } { 1867 lappend ::result [reduce [eval {info frame -3}]] 1868 } 1869 trace add execution print_one enter get_frame_info 1870} -body { 1871 test_info_frame; 1872 join $result \n 1873} -cleanup { 1874 trace remove execution print_one enter get_frame_info 1875 rename get_frame_info {} 1876 rename test_info_frame {} 1877 rename print_one {} 1878} -result {type source line 1854 file info.test cmd print_one proc ::test_info_frame level 1 1879type source line 1859 file info.test cmd print_one proc ::test_info_frame level 1} 1880 1881# ------------------------------------------------------------------------- 1882# Tests moved to the end to not disturb other tests and their locations. 1883 1884test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -setup {subinterp} -body { 1885 interp eval sub { 1886 proc etrace {} { 1887 set res {} 1888 set level [info frame] 1889 while {$level} { 1890 lappend res [list $level [reduce [info frame $level]]] 1891 incr level -1 1892 } 1893 return $res 1894 } 1895 proc control {vv script} { 1896 upvar 1 $vv var 1897 return [uplevel 1 $script] 1898 } 1899 proc datal {} { 1900 control y { 1901 set y PPL 1902 etrace 1903 } 1904 } 1905 join [lrange [datal] 0 4] \n 1906 } 1907} -result {* {type source line 1890 file info.test cmd {info frame $level} proc ::etrace level 0} 1908* {type source line 1902 file info.test cmd etrace proc ::control} 1909* {type source line 1897 file info.test cmd {uplevel 1 $script} proc ::control} 1910* {type source line 1900 file info.test cmd control proc ::datal level 1} 1911* {type source line 1905 file info.test cmd datal level 2}} -cleanup {interp delete sub} 1912 1913test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -setup {subinterp} -body { 1914 interp eval sub { 1915 proc etrace {} { 1916 set res {} 1917 set level [info frame] 1918 while {$level} { 1919 lappend res [list $level [reduce [info frame $level]]] 1920 incr level -1 1921 } 1922 return $res 1923 } 1924 proc control {vv script} { 1925 upvar 1 $vv var 1926 return [uplevel 1 $script] 1927 } 1928 join [lrange [control y { 1929 set y DPL 1930 etrace 1931 }] 0 3] \n 1932 } 1933} -result {* {type source line 1919 file info.test cmd {info frame $level} proc ::etrace level 0} 1934* {type source line 1930 file info.test cmd etrace proc ::control} 1935* {type source line 1926 file info.test cmd {uplevel 1 $script} proc ::control} 1936* {type source line 1928 file info.test cmd control level 1}} -cleanup {interp delete sub} 1937 1938test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -setup {subinterp} -body { 1939 interp eval sub { 1940 proc etrace {} { 1941 set res {} 1942 set level [info frame] 1943 while {$level} { 1944 lappend res [list $level [reduce [info frame $level]]] 1945 incr level -1 1946 } 1947 return $res 1948 } 1949 join [lrange [uplevel \#0 { 1950 set y DL. 1951 etrace 1952 }] 0 2] \n 1953 } 1954} -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0} 1955* {type source line 1951 file info.test cmd etrace level 1} 1956* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub} 1957 1958# This test at the end of this file _only_ to avoid disturbing above line 1959# numbers. It _belongs_ after info-9.12 1960test info-9.13 {info level option, value in global context} -body { 1961 uplevel #0 {info level 2} 1962} -returnCodes error -result {bad level "2"} 1963 1964# ------------------------------------------------------------------------- 1965namespace eval foo {} 1966proc foo::bar {} { 1967 catch {*}{ 1968 {info frame 0} 1969 res 1970 } 1971 return $res 1972} 1973test info-33.4 {{*}, literal, simple, bytecompiled} -body { 1974 reduce [foo::bar] 1975} -cleanup { 1976 namespace delete foo 1977} -result {type source line 1968 file info.test cmd {info frame 0} proc ::foo::bar level 0} 1978 1979# ------------------------------------------------------------------------- 1980namespace eval foo {} 1981proc foo::bar {} { 1982 dict for {a b} {c d} {*}{ 1983 {set res [info frame 0]} 1984 } 1985 return $res 1986} 1987test info-33.5 {{*}, literal, simple, bytecompiled} -body { 1988 reduce [foo::bar] 1989} -cleanup { 1990 namespace delete foo 1991} -result {type source line 1983 file info.test cmd {info frame 0} proc ::foo::bar level 0} 1992 1993# ------------------------------------------------------------------------- 1994namespace eval foo {} 1995proc foo::bar {} { 1996 set d {a b} 1997 dict update d x y {*}{ 1998 {set res [info frame 0]} 1999 } 2000 return $res 2001} 2002test info-33.6 {{*}, literal, simple, bytecompiled} -body { 2003 reduce [foo::bar] 2004} -cleanup { 2005 namespace delete foo 2006} -result {type source line 1998 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2007 2008# ------------------------------------------------------------------------- 2009namespace eval foo {} 2010proc foo::bar {} { 2011 set d {} 2012 dict with d {*}{ 2013 {set res [info frame 0]} 2014 } 2015 return $res 2016} 2017test info-33.7 {{*}, literal, simple, bytecompiled} -body { 2018 reduce [foo::bar] 2019} -cleanup { 2020 namespace delete foo 2021} -result {type source line 2013 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2022 2023# ------------------------------------------------------------------------- 2024namespace eval foo {} 2025proc foo::bar {} { 2026 for {*}{ 2027 {set res [info frame 0]} 2028 {1} {} {break} 2029 } 2030 return $res 2031} 2032test info-33.8 {{*}, literal, simple, bytecompiled} -body { 2033 reduce [foo::bar] 2034} -cleanup { 2035 namespace delete foo 2036} -result {type source line 2027 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2037 2038# ------------------------------------------------------------------------- 2039namespace eval foo {} 2040proc foo::bar {} { 2041 for {*}{ 2042 {} {1} {} 2043 {set res [info frame 0]; break} 2044 } 2045 return $res 2046} 2047test info-33.9 {{*}, literal, simple, bytecompiled} -body { 2048 reduce [foo::bar] 2049} -cleanup { 2050 namespace delete foo 2051} -result {type source line 2043 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2052 2053# ------------------------------------------------------------------------- 2054namespace eval foo {} 2055proc foo::bar {} { 2056 for {*}{ 2057 {} {1} 2058 {return [info frame 0]} 2059 {} 2060 } 2061} 2062test info-33.10 {{*}, literal, simple, bytecompiled} -body { 2063 reduce [foo::bar] 2064} -cleanup { 2065 namespace delete foo 2066} -result {type source line 2058 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2067 2068# ------------------------------------------------------------------------- 2069namespace eval foo {} 2070proc foo::bar {} { 2071 for {*}{ 2072 {} 2073 {[return [info frame 0]]} 2074 {} {} 2075 } 2076} 2077test info-33.11 {{*}, literal, simple, bytecompiled} -body { 2078 reduce [foo::bar] 2079} -cleanup { 2080 namespace delete foo 2081} -result {type source line 2073 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2082 2083# ------------------------------------------------------------------------- 2084namespace eval foo {} 2085proc foo::bar {} { 2086 foreach {*}{ 2087 x 2088 } [return [info frame 0]] {} 2089} 2090test info-33.12 {{*}, literal, simple, bytecompiled} -body { 2091 reduce [foo::bar] 2092} -cleanup { 2093 namespace delete foo 2094} -result {type source line 2088 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2095 2096# ------------------------------------------------------------------------- 2097namespace eval foo {} 2098proc foo::bar {} { 2099 foreach {*}{ 2100 x y 2101 {set res [info frame 0]} 2102 } 2103 return $res 2104} 2105test info-33.13 {{*}, literal, simple, bytecompiled} -body { 2106 reduce [foo::bar] 2107} -cleanup { 2108 namespace delete foo 2109} -result {type source line 2101 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2110 2111# ------------------------------------------------------------------------- 2112namespace eval foo {} 2113proc foo::bar {} { 2114 if {*}{ 2115 {[return [info frame 0]]} 2116 {} 2117 } 2118} 2119test info-33.14 {{*}, literal, simple, bytecompiled} -body { 2120 reduce [foo::bar] 2121} -cleanup { 2122 namespace delete foo 2123} -result {type source line 2115 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2124 2125# ------------------------------------------------------------------------- 2126namespace eval foo {} 2127proc foo::bar {} { 2128 if 0 {*}{ 2129 {} else 2130 {return [info frame 0]} 2131 } 2132} 2133test info-33.15 {{*}, literal, simple, bytecompiled} -body { 2134 reduce [foo::bar] 2135} -cleanup { 2136 namespace delete foo 2137} -result {type source line 2130 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2138 2139# ------------------------------------------------------------------------- 2140namespace eval foo {} 2141proc foo::bar {} { 2142 incr {*}{ 2143 x 2144 } [return [info frame 0]] 2145} 2146test info-33.16 {{*}, literal, simple, bytecompiled} -body { 2147 reduce [foo::bar] 2148} -cleanup { 2149 namespace delete foo 2150} -result {type source line 2144 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2151 2152# ------------------------------------------------------------------------- 2153namespace eval foo {} 2154proc foo::bar {} { 2155 info level {*}{ 2156 } [return [info frame 0]] 2157} 2158test info-33.17 {{*}, literal, simple, bytecompiled} -body { 2159 reduce [foo::bar] 2160} -cleanup { 2161 namespace delete foo 2162} -result {type source line 2156 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2163 2164# ------------------------------------------------------------------------- 2165namespace eval foo {} 2166proc foo::bar {} { 2167 string match {*}{ 2168 } [return [info frame 0]] {} 2169} 2170test info-33.18 {{*}, literal, simple, bytecompiled} -body { 2171 reduce [foo::bar] 2172} -cleanup { 2173 namespace delete foo 2174} -result {type source line 2168 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2175 2176# ------------------------------------------------------------------------- 2177namespace eval foo {} 2178proc foo::bar {} { 2179 string match {*}{ 2180 {} 2181 } [return [info frame 0]] 2182} 2183test info-33.19 {{*}, literal, simple, bytecompiled} -body { 2184 reduce [foo::bar] 2185} -cleanup { 2186 namespace delete foo 2187} -result {type source line 2181 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2188 2189# ------------------------------------------------------------------------- 2190namespace eval foo {} 2191proc foo::bar {} { 2192 string length {*}{ 2193 } [return [info frame 0]] 2194} 2195test info-33.20 {{*}, literal, simple, bytecompiled} -body { 2196 reduce [foo::bar] 2197} -cleanup { 2198 namespace delete foo 2199} -result {type source line 2193 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2200 2201# ------------------------------------------------------------------------- 2202namespace eval foo {} 2203proc foo::bar {} { 2204 while {*}{ 2205 {[return [info frame 0]]} 2206 } {} 2207} 2208test info-33.21 {{*}, literal, simple, bytecompiled} -body { 2209 reduce [foo::bar] 2210} -cleanup { 2211 namespace delete foo 2212} -result {type source line 2205 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2213 2214# ------------------------------------------------------------------------- 2215namespace eval foo {} 2216proc foo::bar {} { 2217 switch -- {*}{ 2218 } [return [info frame 0]] {*}{ 2219 } x y 2220} 2221test info-33.22 {{*}, literal, simple, bytecompiled} -body { 2222 reduce [foo::bar] 2223} -cleanup { 2224 namespace delete foo 2225} -result {type source line 2218 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2226 2227# ------------------------------------------------------------------------- 2228namespace eval foo {} 2229proc foo::bar {} { 2230 try {*}{ 2231 {set res [info frame 0]} 2232 } 2233 return $res 2234} 2235test info-33.23 {{*}, literal, simple, bytecompiled} -body { 2236 reduce [foo::bar] 2237} -cleanup { 2238 namespace delete foo 2239} -result {type source line 2231 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2240 2241# ------------------------------------------------------------------------- 2242namespace eval foo {} 2243proc foo::bar {} { 2244 try {*}{ 2245 {set res [info frame 0]} 2246 } finally {} 2247 return $res 2248} 2249test info-33.24 {{*}, literal, simple, bytecompiled} -body { 2250 reduce [foo::bar] 2251} -cleanup { 2252 namespace delete foo 2253} -result {type source line 2245 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2254 2255# ------------------------------------------------------------------------- 2256namespace eval foo {} 2257proc foo::bar {} { 2258 try {*}{ 2259 {set res [info frame 0]} 2260 } on ok {} {} 2261 return $res 2262} 2263test info-33.25 {{*}, literal, simple, bytecompiled} -body { 2264 reduce [foo::bar] 2265} -cleanup { 2266 namespace delete foo 2267} -result {type source line 2259 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2268 2269# ------------------------------------------------------------------------- 2270namespace eval foo {} 2271proc foo::bar {} { 2272 try {*}{ 2273 {set res [info frame 0]} 2274 } on ok {} {} finally {} 2275 return $res 2276} 2277test info-33.26 {{*}, literal, simple, bytecompiled} -body { 2278 reduce [foo::bar] 2279} -cleanup { 2280 namespace delete foo 2281} -result {type source line 2273 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2282 2283# ------------------------------------------------------------------------- 2284namespace eval foo {} 2285proc foo::bar {} { 2286 while 1 {*}{ 2287 {return [info frame 0]} 2288 } 2289} 2290test info-33.27 {{*}, literal, simple, bytecompiled} -body { 2291 reduce [foo::bar] 2292} -cleanup { 2293 namespace delete foo 2294} -result {type source line 2287 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2295 2296# ------------------------------------------------------------------------- 2297namespace eval foo {} 2298proc foo::bar {} { 2299 try {} finally {*}{ 2300 {return [info frame 0]} 2301 } 2302} 2303test info-33.28 {{*}, literal, simple, bytecompiled} -body { 2304 reduce [foo::bar] 2305} -cleanup { 2306 namespace delete foo 2307} -result {type source line 2300 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2308 2309# ------------------------------------------------------------------------- 2310namespace eval foo {} 2311proc foo::bar {} { 2312 try {} on ok {} {} finally {*}{ 2313 {return [info frame 0]} 2314 } 2315} 2316test info-33.29 {{*}, literal, simple, bytecompiled} -body { 2317 reduce [foo::bar] 2318} -cleanup { 2319 namespace delete foo 2320} -result {type source line 2313 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2321 2322# ------------------------------------------------------------------------- 2323namespace eval foo {} 2324proc foo::bar {} { 2325 try {} on ok {} {*}{ 2326 {return [info frame 0]} 2327 } 2328} 2329test info-33.30 {{*}, literal, simple, bytecompiled} -body { 2330 reduce [foo::bar] 2331} -cleanup { 2332 namespace delete foo 2333} -result {type source line 2326 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2334 2335# ------------------------------------------------------------------------- 2336namespace eval foo {} 2337proc foo::bar {} { 2338 try {} on ok {} {*}{ 2339 {return [info frame 0]} 2340 } finally {} 2341} 2342test info-33.31 {{*}, literal, simple, bytecompiled} -body { 2343 reduce [foo::bar] 2344} -cleanup { 2345 namespace delete foo 2346} -result {type source line 2339 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2347 2348# ------------------------------------------------------------------------- 2349namespace eval foo {} 2350proc foo::bar {} { 2351 binary format {*}{ 2352 } [return [info frame 0]] 2353} 2354test info-33.32 {{*}, literal, simple, bytecompiled} -body { 2355 reduce [foo::bar] 2356} -cleanup { 2357 namespace delete foo 2358} -result {type source line 2352 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2359 2360# ------------------------------------------------------------------------- 2361namespace eval foo {} 2362proc foo::bar {} { 2363 set format format 2364 binary $format {*}{ 2365 } [return [info frame 0]] 2366} 2367test info-33.33 {{*}, literal, simple, bytecompiled} -body { 2368 reduce [foo::bar] 2369} -cleanup { 2370 namespace delete foo 2371} -result {type source line 2365 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2372 2373# ------------------------------------------------------------------------- 2374namespace eval foo {} 2375proc foo::bar {} { 2376 append x {*}{ 2377 } [return [info frame 0]] 2378} 2379test info-33.34 {{*}, literal, simple, bytecompiled} -body { 2380 reduce [foo::bar] 2381} -cleanup { 2382 namespace delete foo 2383} -result {type source line 2377 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2384 2385# ------------------------------------------------------------------------- 2386namespace eval foo {} 2387proc foo::bar {} { 2388 append {*}{ 2389 } x([return [info frame 0]]) {*}{ 2390 } a 2391} 2392test info-33.35 {{*}, literal, simple, bytecompiled} -body { 2393 reduce [foo::bar] 2394} -cleanup { 2395 namespace delete foo 2396} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0} 2397 2398# ------------------------------------------------------------------------- 2399namespace eval ::testinfocmdtype { 2400 apply {cmds { 2401 foreach c $cmds {rename $c {}} 2402 } ::testinfocmdtype} [info commands ::testinfocmdtype::*] 2403} 2404test info-40.1 {info cmdtype: syntax} -body { 2405 info cmdtype 2406} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"} 2407test info-40.2 {info cmdtype: syntax} -body { 2408 info cmdtype foo bar 2409} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"} 2410test info-40.3 {info cmdtype: no such command} -body { 2411 info cmdtype ::testinfocmdtype::foo 2412} -returnCodes error -result {unknown command "::testinfocmdtype::foo"} 2413test info-40.4 {info cmdtype: native commands} -body { 2414 info cmdtype ::if 2415} -result native 2416test info-40.5 {info cmdtype: native commands} -body { 2417 info cmdtype ::puts 2418} -result native 2419test info-40.6 {info cmdtype: native commands} -body { 2420 info cmdtype ::yield 2421} -result native 2422test info-40.7 {info cmdtype: procedures} -setup { 2423 proc ::testinfocmdtype::someproc {} {} 2424} -body { 2425 info cmdtype ::testinfocmdtype::someproc 2426} -cleanup { 2427 rename ::testinfocmdtype::someproc {} 2428} -result proc 2429test info-40.8 {info cmdtype: aliases} -setup { 2430 interp alias {} ::testinfocmdtype::somealias {} ::puts 2431} -body { 2432 info cmdtype ::testinfocmdtype::somealias 2433} -cleanup { 2434 rename ::testinfocmdtype::somealias {} 2435} -result alias 2436test info-40.9 {info cmdtype: imports} -setup { 2437 namespace eval ::testinfocmdtype { 2438 namespace eval foo { 2439 proc bar {} {} 2440 namespace export bar 2441 } 2442 namespace import foo::bar 2443 } 2444} -body { 2445 info cmdtype ::testinfocmdtype::bar 2446} -cleanup { 2447 rename ::testinfocmdtype::bar {} 2448 namespace delete ::testinfocmdtype::foo 2449} -result import 2450test info-40.10 {info cmdtype: interps} -setup { 2451 apply {i { 2452 rename $i ::testinfocmdtype::child 2453 variable ::testinfocmdtype::child $i 2454 }} [interp create] 2455} -body { 2456 info cmdtype ::testinfocmdtype::child 2457} -cleanup { 2458 interp delete $::testinfocmdtype::child 2459} -result interp 2460test info-40.11 {info cmdtype: objects} -setup { 2461 apply {{} { 2462 oo::object create obj 2463 } ::testinfocmdtype} 2464} -body { 2465 info cmdtype ::testinfocmdtype::obj 2466} -cleanup { 2467 ::testinfocmdtype::obj destroy 2468} -result object 2469test info-40.12 {info cmdtype: objects} -setup { 2470 apply {{} { 2471 oo::object create obj 2472 } ::testinfocmdtype} 2473} -body { 2474 info cmdtype [info object namespace ::testinfocmdtype::obj]::my 2475} -cleanup { 2476 ::testinfocmdtype::obj destroy 2477} -result privateObject 2478test info-40.13 {info cmdtype: ensembles} -setup { 2479 namespace eval ::testinfocmdtype { 2480 namespace eval ensmbl { 2481 proc bar {} {} 2482 namespace export * 2483 namespace ensemble create 2484 } 2485 } 2486} -body { 2487 info cmdtype ::testinfocmdtype::ensmbl 2488} -cleanup { 2489 namespace delete ::testinfocmdtype::ensmbl 2490} -result ensemble 2491test info-40.14 {info cmdtype: zlib streams} -constraints zlib -setup { 2492 namespace eval ::testinfocmdtype { 2493 rename [zlib stream gzip] zstream 2494 } 2495} -body { 2496 info cmdtype ::testinfocmdtype::zstream 2497} -cleanup { 2498 ::testinfocmdtype::zstream close 2499} -result zlibStream 2500test info-40.15 {info cmdtype: coroutines} -setup { 2501 coroutine ::testinfocmdtype::coro eval yield 2502} -body { 2503 info cmdtype ::testinfocmdtype::coro 2504} -cleanup { 2505 ::testinfocmdtype::coro 2506} -result coroutine 2507test info-40.16 {info cmdtype: dynamic behavior} -setup { 2508 proc ::testinfocmdtype::foo {} {} 2509} -body { 2510 namespace eval ::testinfocmdtype { 2511 list [catch {info cmdtype foo}] [catch {info cmdtype bar}] \ 2512 [namespace which foo] [rename foo bar] [namespace which bar] \ 2513 [catch {info cmdtype foo}] [catch {info cmdtype bar}] 2514 } 2515} -cleanup { 2516 namespace eval ::testinfocmdtype { 2517 catch {rename foo {}} 2518 catch {rename bar {}} 2519 } 2520} -result {0 1 ::testinfocmdtype::foo {} ::testinfocmdtype::bar 1 0} 2521test info-40.17 {info cmdtype: aliases in child interpreters} -setup { 2522 set i [interp create] 2523} -body { 2524 $i alias foo gorp 2525 $i eval { 2526 info cmdtype foo 2527 } 2528} -cleanup { 2529 interp delete $i 2530} -result alias 2531test info-40.18 {info cmdtype: aliases in child interpreters} -setup { 2532 set safe [interp create -safe] 2533} -body { 2534 $safe alias foo gorp 2535 $safe eval { 2536 info cmdtype foo 2537 } 2538} -returnCodes error -cleanup { 2539 interp delete $safe 2540} -result {not allowed to invoke subcommand cmdtype of info} 2541test info-40.19 {info cmdtype: aliases in child interpreters} -setup { 2542 set safe [interp create -safe] 2543} -body { 2544 set inner [interp create [list $safe bar]] 2545 interp alias $inner foo $safe gorp 2546 $safe eval { 2547 bar eval { 2548 info cmdtype foo 2549 } 2550 } 2551} -returnCodes error -cleanup { 2552 interp delete $safe 2553} -result {not allowed to invoke subcommand cmdtype of info} 2554test info-40.20 {info cmdtype: aliases in child interpreters} -setup { 2555 set safe [interp create -safe] 2556} -body { 2557 $safe eval { 2558 interp alias {} foo {} gorp 2559 info cmdtype foo 2560 } 2561} -returnCodes error -cleanup { 2562 interp delete $safe 2563} -result {not allowed to invoke subcommand cmdtype of info} 2564namespace delete ::testinfocmdtype 2565 2566# ------------------------------------------------------------------------- 2567unset -nocomplain res 2568 2569test info-39.2 {Bug 4b61afd660} -setup { 2570 proc probe {} { 2571 return [dict get [info frame -1] line] 2572 } 2573 set body { 2574 set cmd probe 2575 $cmd 2576 } 2577 proc demo {} $body 2578} -body { 2579 demo 2580} -cleanup { 2581 unset -nocomplain body 2582 rename demo {} 2583 rename probe {} 2584} -result 3 2585 2586# cleanup 2587catch {namespace delete test_ns_info1 test_ns_info2} 2588::tcltest::cleanupTests 2589return 2590