tcl/tests/info.test

   1 # Commands covered:  info
   2 #
   3 # This file contains a collection of tests for one or more of the Tcl
   4 # built-in commands.  Sourcing this file into Tcl runs the tests and
   5 # generates output for errors.  No output means no errors were found.
   6 #
   7 # Copyright (c) 1991-1994 The Regents of the University of California.
   8 # Copyright (c) 1994-1997 Sun Microsystems, Inc.
   9 # Copyright (c) 1998-1999 by Scriptics Corporation.
  10 #
  11 # See the file "license.terms" for information on usage and redistribution
  12 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13 #
  14 # RCS: @(#) $Id$
  15
  16 if {[lsearch [namespace children] ::tcltest] == -1} {
  17     package require tcltest
  18     namespace import -force ::tcltest::*
  19 }
  20
  21 # Set up namespaces needed to test operation of "info args", "info body",
  22 # "info default", and "info procs" with imported procedures.
  23
  24 catch {namespace delete test_ns_info1 test_ns_info2}
  25
  26 namespace eval test_ns_info1 {
  27     namespace export *
  28     proc p {x} {return "x=$x"}
  29     proc q {{y 27} {z {}}} {return "y=$y"}
  30 }
  31
  32
  33 test info-1.1 {info args option} {
  34     proc t1 {a bbb c} {return foo}
  35     info args t1
  36 } {a bbb c}
  37 test info-1.2 {info args option} {
  38     proc t1 {{a default1} {bbb default2} {c default3} args} {return foo}
  39     info a t1
  40 } {a bbb c args}
  41 test info-1.3 {info args option} {
  42     proc t1 "" {return foo}
  43     info args t1
  44 } {}
  45 test info-1.4 {info args option} {
  46     catch {rename t1 {}}
  47     list [catch {info args t1} msg] $msg
  48 } {1 {"t1" isn't a procedure}}
  49 test info-1.5 {info args option} {
  50     list [catch {info args set} msg] $msg
  51 } {1 {"set" isn't a procedure}}
  52 test info-1.6 {info args option} {
  53     proc t1 {a b} {set c 123; set d $c}
  54     t1 1 2
  55     info args t1
  56 } {a b}
  57 test info-1.7 {info args option} {
  58     catch {namespace delete test_ns_info2}
  59     namespace eval test_ns_info2 {
  60         namespace import ::test_ns_info1::*
  61         list [info args p] [info args q]
  62     }
  63 } {x {y z}}
  64
  65 test info-2.1 {info body option} {
  66     proc t1 {} {body of t1}
  67     info body t1
  68 } {body of t1}
  69 test info-2.2 {info body option} {
  70     list [catch {info body set} msg] $msg
  71 } {1 {"set" isn't a procedure}}
  72 test info-2.3 {info body option} {
  73     list [catch {info args set 1} msg] $msg
  74 } {1 {wrong # args: should be "info args procname"}}
  75 test info-2.4 {info body option} {
  76     catch {namespace delete test_ns_info2}
  77     namespace eval test_ns_info2 {
  78         namespace import ::test_ns_info1::*
  79         list [info body p] [info body q]
  80     }
  81 } {{return "x=$x"} {return "y=$y"}}
  82 test info-2.5 {info body option, returning bytecompiled bodies} {
  83     # Prior to 8.3.0 this would cause a crash because [info body]
  84     # would return the bytecompiled version of foo, which the catch
  85     # would then try and eval out of the foo context, accessing
  86     # compiled local indices
  87     catch {unset args}
  88     proc foo {args} {
  89         foreach v $args {
  90             upvar $v var
  91             return "variable $v existence: [info exists var]"
  92         }
  93     }
  94     foo a
  95     list [catch [info body foo] msg] $msg
  96 } {1 {can't read "args": no such variable}}
  97
  98 # "info cmdcount" is no longer accurate for compiled commands!
  99 # The expected result for info-3.1 used to be "3" and is now "1"
 100 # since the "set"s have been compiled away.  info-3.2 was corrected
 101 # in 8.3 because the eval'ed body won't be compiled.
 102 proc testinfocmdcount {} {
 103     set x [info cmdcount]
 104     set y 12345
 105     set z [info cm]
 106     expr $z-$x
 107 }
 108 test info-3.1 {info cmdcount compiled} {
 109     testinfocmdcount
 110 } 1
 111 test info-3.2 {info cmdcount evaled} {
 112     set x [info cmdcount]
 113     set y 12345
 114     set z [info cm]
 115     expr $z-$x
 116 } 3
 117 test info-3.3 {info cmdcount evaled} [info body testinfocmdcount] 3
 118 test info-3.4 {info cmdcount option} {
 119     list [catch {info cmdcount 1} msg] $msg
 120 } {1 {wrong # args: should be "info cmdcount"}}
 121
 122 test info-4.1 {info commands option} {
 123     proc t1 {} {}
 124     proc t2 {} {}
 125     set x " [info commands] "
 126     list [string match {* t1 *} $x] [string match {* t2 *} $x] \
 127             [string match {* set *} $x] [string match {* list *} $x]
 128 } {1 1 1 1}
 129 test info-4.2 {info commands option} {
 130     proc t1 {} {}
 131     rename t1 {}
 132     set x [info comm]
 133     string match {* t1 *} $x
 134 } 0
 135 test info-4.3 {info commands option} {
 136     proc _t1_ {} {}
 137     proc _t2_ {} {}
 138     info commands _t1_
 139 } _t1_
 140 test info-4.4 {info commands option} {
 141     proc _t1_ {} {}
 142     proc _t2_ {} {}
 143     lsort [info commands _t*]
 144 } {_t1_ _t2_}
 145 catch {rename _t1_ {}}
 146 catch {rename _t2_ {}}
 147 test info-4.5 {info commands option} {
 148     list [catch {info commands a b} msg] $msg
 149 } {1 {wrong # args: should be "info commands ?pattern?"}}
 150
 151 test info-5.1 {info complete option} {
 152     list [catch {info complete} msg] $msg
 153 } {1 {wrong # args: should be "info complete command"}}
 154 test info-5.2 {info complete option} {
 155     info complete abc
 156 } 1
 157 test info-5.2 {info complete option} {
 158     info complete "\{abcd "
 159 } 0
 160 test info-5.3 {info complete option} {
 161     info complete {# Comment should be complete command}
 162 } 1
 163 test info-5.4 {info complete option} {
 164     info complete {[a [b] }
 165 } 0
 166 test info-5.5 {info complete option} {
 167     info complete {[a [b]}
 168 } 0
 169
 170 test info-6.1 {info default option} {
 171     proc t1 {a b {c d} {e "long default value"}} {}
 172     info default t1 a value
 173 } 0
 174 test info-6.2 {info default option} {
 175     proc t1 {a b {c d} {e "long default value"}} {}
 176     set value 12345
 177     info d t1 a value
 178     set value
 179 } {}
 180 test info-6.3 {info default option} {
 181     proc t1 {a b {c d} {e "long default value"}} {}
 182     info default t1 c value
 183 } 1
 184 test info-6.4 {info default option} {
 185     proc t1 {a b {c d} {e "long default value"}} {}
 186     set value 12345
 187     info default t1 c value
 188     set value
 189 } d
 190 test info-6.5 {info default option} {
 191     proc t1 {a b {c d} {e "long default value"}} {}
 192     set value 12345
 193     set x [info default t1 e value]
 194     list $x $value
 195 } {1 {long default value}}
 196 test info-6.6 {info default option} {
 197     list [catch {info default a b} msg] $msg
 198 } {1 {wrong # args: should be "info default procname arg varname"}}
 199 test info-6.7 {info default option} {
 200     list [catch {info default _nonexistent_ a b} msg] $msg
 201 } {1 {"_nonexistent_" isn't a procedure}}
 202 test info-6.8 {info default option} {
 203     proc t1 {a b} {}
 204     list [catch {info default t1 x value} msg] $msg
 205 } {1 {procedure "t1" doesn't have an argument "x"}}
 206 test info-6.9 {info default option} {
 207     catch {unset a}
 208     set a(0) 88
 209     proc t1 {a b} {}
 210     list [catch {info default t1 a a} msg] $msg
 211 } {1 {couldn't store default value in variable "a"}}
 212 test info-6.10 {info default option} {
 213     catch {unset a}
 214     set a(0) 88
 215     proc t1 {{a 18} b} {}
 216     list [catch {info default t1 a a} msg] $msg
 217 } {1 {couldn't store default value in variable "a"}}
 218 test info-6.11 {info default option} {
 219     catch {namespace delete test_ns_info2}
 220     namespace eval test_ns_info2 {
 221         namespace import ::test_ns_info1::*
 222         list [info default p x foo] $foo [info default q y bar] $bar
 223     }
 224 } {0 {} 1 27}
 225 catch {unset a}
 226
 227 test info-7.1 {info exists option} {
 228     set value foo
 229     info exists value
 230 } 1
 231 catch {unset _nonexistent_}
 232 test info-7.2 {info exists option} {
 233     info exists _nonexistent_
 234 } 0
 235 test info-7.3 {info exists option} {
 236     proc t1 {x} {return [info exists x]}
 237     t1 2
 238 } 1
 239 test info-7.4 {info exists option} {
 240     proc t1 {x} {
 241         global _nonexistent_
 242         return [info exists _nonexistent_]
 243     }
 244     t1 2
 245 } 0
 246 test info-7.5 {info exists option} {
 247     proc t1 {x} {
 248         set y 47
 249         return [info exists y]
 250     }
 251     t1 2
 252 } 1
 253 test info-7.6 {info exists option} {
 254     proc t1 {x} {return [info exists value]}
 255     t1 2
 256 } 0
 257 test info-7.7 {info exists option} {
 258     catch {unset x}
 259     set x(2) 44
 260     list [info exists x] [info exists x(1)] [info exists x(2)]
 261 } {1 0 1}
 262 catch {unset x}
 263 test info-7.8 {info exists option} {
 264     list [catch {info exists} msg] $msg
 265 } {1 {wrong # args: should be "info exists varName"}}
 266 test info-7.9 {info exists option} {
 267     list [catch {info exists 1 2} msg] $msg
 268 } {1 {wrong # args: should be "info exists varName"}}
 269
 270 test info-8.1 {info globals option} {
 271     set x 1
 272     set y 2
 273     set value 23
 274     set a " [info globals] "
 275     list [string match {* x *} $a] [string match {* y *} $a] \
 276             [string match {* value *} $a] [string match {* _foobar_ *} $a]
 277 } {1 1 1 0}
 278 test info-8.2 {info globals option} {
 279     set _xxx1 1
 280     set _xxx2 2
 281     lsort [info g _xxx*]
 282 } {_xxx1 _xxx2}
 283 test info-8.3 {info globals option} {
 284     list [catch {info globals 1 2} msg] $msg
 285 } {1 {wrong # args: should be "info globals ?pattern?"}}
 286
 287 test info-9.1 {info level option} {
 288     info level
 289 } 0
 290 test info-9.2 {info level option} {
 291     proc t1 {a b} {
 292         set x [info le]
 293         set y [info level 1]
 294         list $x $y
 295     }
 296     t1 146 testString
 297 } {1 {t1 146 testString}}
 298 test info-9.3 {info level option} {
 299     proc t1 {a b} {
 300         t2 [expr $a*2] $b
 301     }
 302     proc t2 {x y} {
 303         list [info level] [info level 1] [info level 2] [info level -1] \
 304                 [info level 0]
 305     }
 306     t1 146 {a {b c} {{{c}}}}
 307 } {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}}}}}}
 308 test info-9.4 {info level option} {
 309     proc t1 {} {
 310         set x [info level]
 311         set y [info level 1]
 312         list $x $y
 313     }
 314     t1
 315 } {1 t1}
 316 test info-9.5 {info level option} {
 317     list [catch {info level 1 2} msg] $msg
 318 } {1 {wrong # args: should be "info level ?number?"}}
 319 test info-9.6 {info level option} {
 320     list [catch {info level 123a} msg] $msg
 321 } {1 {expected integer but got "123a"}}
 322 test info-9.7 {info level option} {
 323     list [catch {info level 0} msg] $msg
 324 } {1 {bad level "0"}}
 325 test info-9.8 {info level option} {
 326     proc t1 {} {info level -1}
 327     list [catch {t1} msg] $msg
 328 } {1 {bad level "-1"}}
 329 test info-9.9 {info level option} {
 330     proc t1 {x} {info level $x}
 331     list [catch {t1 -3} msg] $msg
 332 } {1 {bad level "-3"}}
 333
 334 set savedLibrary $tcl_library
 335 test info-10.1 {info library option} {
 336     list [catch {info library x} msg] $msg
 337 } {1 {wrong # args: should be "info library"}}
 338 test info-10.2 {info library option} {
 339     set tcl_library 12345
 340     info library
 341 } {12345}
 342 test info-10.3 {info library option} {
 343     unset tcl_library
 344     list [catch {info library} msg] $msg
 345 } {1 {no library has been specified for Tcl}}
 346 set tcl_library $savedLibrary
 347
 348 test info-11.1 {info loaded option} {
 349     list [catch {info loaded a b} msg] $msg
 350 } {1 {wrong # args: should be "info loaded ?interp?"}}
 351 test info-11.2 {info loaded option} {
 352     list [catch {info loaded {}}] [catch {info loaded gorp} msg] $msg
 353 } {0 1 {could not find interpreter "gorp"}}
 354
 355 test info-12.1 {info locals option} {
 356     set a 22
 357     proc t1 {x y} {
 358         set b 13
 359         set c testing
 360         global a
 361         return [info locals]
 362     }
 363     lsort [t1 23 24]
 364 } {b c x y}
 365 test info-12.2 {info locals option} {
 366     proc t1 {x y} {
 367         set xx1 2
 368         set xx2 3
 369         set y 4
 370         return [info loc x*]
 371     }
 372     lsort [t1 2 3]
 373 } {x xx1 xx2}
 374 test info-12.3 {info locals option} {
 375     list [catch {info locals 1 2} msg] $msg
 376 } {1 {wrong # args: should be "info locals ?pattern?"}}
 377 test info-12.4 {info locals option} {
 378     info locals
 379 } {}
 380 test info-12.5 {info locals option} {
 381     proc t1 {} {return [info locals]}
 382     t1
 383 } {}
 384 test info-12.6 {info locals vs unset compiled locals} {
 385     proc t1 {lst} {
 386         foreach $lst $lst {}
 387         unset lst
 388         return [info locals]
 389     }
 390     lsort [t1 {a b c c d e f}]
 391 } {a b c d e f}
 392 test info-12.7 {info locals with temporary variables} {
 393     proc t1 {} {
 394         foreach a {b c} {}
 395         info locals
 396     }
 397     t1
 398 } {a}
 399
 400 test info-13.1 {info nameofexecutable option} {
 401     list [catch {info nameofexecutable foo} msg] $msg
 402 } {1 {wrong # args: should be "info nameofexecutable"}}
 403
 404 test info-14.1 {info patchlevel option} {
 405     set a [info patchlevel]
 406     regexp {[0-9]+\.[0-9]+([p[0-9]+)?} $a
 407 } 1
 408 test info-14.2 {info patchlevel option} {
 409     list [catch {info patchlevel a} msg] $msg
 410 } {1 {wrong # args: should be "info patchlevel"}}
 411 test info-14.3 {info patchlevel option} {
 412     set t $tcl_patchLevel
 413     unset tcl_patchLevel
 414     set result [list [catch {info patchlevel} msg] $msg]
 415     set tcl_patchLevel $t
 416     set result
 417 } {1 {can't read "tcl_patchLevel": no such variable}}
 418
 419 test info-15.1 {info procs option} {
 420     proc t1 {} {}
 421     proc t2 {} {}
 422     set x " [info procs] "
 423     list [string match {* t1 *} $x] [string match {* t2 *} $x] \
 424             [string match {* _undefined_ *} $x]
 425 } {1 1 0}
 426 test info-15.2 {info procs option} {
 427     proc _tt1 {} {}
 428     proc _tt2 {} {}
 429     lsort [info pr _tt*]
 430 } {_tt1 _tt2}
 431 catch {rename _tt1 {}}
 432 catch {rename _tt2 {}}
 433 test info-15.3 {info procs option} {
 434     list [catch {info procs 2 3} msg] $msg
 435 } {1 {wrong # args: should be "info procs ?pattern?"}}
 436 test info-15.4 {info procs option} {
 437     catch {namespace delete test_ns_info2}
 438     namespace eval test_ns_info2 {
 439         namespace import ::test_ns_info1::*
 440         proc r {} {}
 441         list [info procs] [info procs p*]
 442     }
 443 } {{p q r} p}
 444 test info-15.5 {info procs option with a proc in a namespace} {
 445     catch {namespace delete test_ns_info2}
 446     namespace eval test_ns_info2 {
 447         proc p1 { arg } {
 448             puts cmd
 449         }
 450         proc p2 { arg } {
 451             puts cmd
 452         }
 453     }
 454     info procs ::test_ns_info2::p1
 455 } {::test_ns_info2::p1}
 456 test info-15.6 {info procs option with a pattern in a namespace} {
 457     catch {namespace delete test_ns_info2}
 458     namespace eval test_ns_info2 {
 459         proc p1 { arg } {
 460             puts cmd
 461         }
 462         proc p2 { arg } {
 463             puts cmd
 464         }
 465     }
 466     lsort [info procs ::test_ns_info2::p*]
 467 } [lsort [list ::test_ns_info2::p1 ::test_ns_info2::p2]]
 468 test info-15.7 {info procs option with a global shadowing proc} {
 469     catch {namespace delete test_ns_info2}
 470     proc string_cmd { arg } {
 471         puts cmd
 472     }
 473     namespace eval test_ns_info2 {
 474         proc string_cmd { arg } {
 475             puts cmd
 476         }
 477     }
 478     info procs test_ns_info2::string*
 479 } {::test_ns_info2::string_cmd}
 480 # This regression test is currently commented out because it requires
 481 # that the implementation of "info procs" looks into the global namespace,
 482 # which it does not (in contrast to "info commands")
 483 if {0} {
 484 test info-15.8 {info procs option with a global shadowing proc} {
 485     catch {namespace delete test_ns_info2}
 486     proc string_cmd { arg } {
 487         puts cmd
 488     }
 489     proc string_cmd2 { arg } {
 490         puts cmd
 491     }
 492     namespace eval test_ns_info2 {
 493         proc string_cmd { arg } {
 494             puts cmd
 495         }
 496     }
 497     namespace eval test_ns_info2 {
 498         lsort [info procs string*]
 499     }
 500 } [lsort [list string_cmd string_cmd2]]
 501 }
 502
 503 test info-16.1 {info script option} {
 504     list [catch {info script x} msg] $msg
 505 } {1 {wrong # args: should be "info script"}}
 506 test info-16.2 {info script option} {
 507     file tail [info sc]
 508 } "info.test"
 509 removeFile gorp.info
 510 makeFile "info script\n" gorp.info
 511 test info-16.3 {info script option} {
 512     list [source gorp.info] [file tail [info script]]
 513 } [list gorp.info info.test]
 514 test info-16.4 {resetting "info script" after errors} {
 515     catch {source ~_nobody_/foo}
 516     file tail [info script]
 517 } "info.test"
 518 test info-16.5 {resetting "info script" after errors} {
 519     catch {source _nonexistent_}
 520     file tail [info script]
 521 } "info.test"
 522 removeFile gorp.info
 523
 524 test info-17.1 {info sharedlibextension option} {
 525     list [catch {info sharedlibextension foo} msg] $msg
 526 } {1 {wrong # args: should be "info sharedlibextension"}}
 527
 528 test info-18.1 {info tclversion option} {
 529     set x [info tclversion]
 530     scan $x "%d.%d%c" a b c
 531 } 2
 532 test info-18.2 {info tclversion option} {
 533     list [catch {info t 2} msg] $msg
 534 } {1 {wrong # args: should be "info tclversion"}}
 535 test info-18.3 {info tclversion option} {
 536     set t $tcl_version
 537     unset tcl_version
 538     set result [list [catch {info tclversion} msg] $msg]
 539     set tcl_version $t
 540     set result
 541 } {1 {can't read "tcl_version": no such variable}}
 542
 543 test info-19.1 {info vars option} {
 544     set a 1
 545     set b 2
 546     proc t1 {x y} {
 547         global a b
 548         set c 33
 549         return [info vars]
 550     }
 551     lsort [t1 18 19]
 552 } {a b c x y}
 553 test info-19.2 {info vars option} {
 554     set xxx1 1
 555     set xxx2 2
 556     proc t1 {xxa y} {
 557         global xxx1 xxx2
 558         set c 33
 559         return [info vars x*]
 560     }
 561     lsort [t1 18 19]
 562 } {xxa xxx1 xxx2}
 563 test info-19.3 {info vars option} {
 564     lsort [info vars]
 565 } [lsort [info globals]]
 566 test info-19.4 {info vars option} {
 567     list [catch {info vars a b} msg] $msg
 568 } {1 {wrong # args: should be "info vars ?pattern?"}}
 569 test info-19.5 {info vars with temporary variables} {
 570     proc t1 {} {
 571         foreach a {b c} {}
 572         info vars
 573     }
 574     t1
 575 } {a}
 576
 577 test info-20.1 {miscellaneous error conditions} {
 578     list [catch {info} msg] $msg
 579 } {1 {wrong # args: should be "info option ?arg arg ...?"}}
 580 test info-20.2 {miscellaneous error conditions} {
 581     list [catch {info gorp} msg] $msg
 582 } {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
 583 test info-20.3 {miscellaneous error conditions} {
 584     list [catch {info c} msg] $msg
 585 } {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
 586 test info-20.4 {miscellaneous error conditions} {
 587     list [catch {info l} msg] $msg
 588 } {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
 589 test info-20.5 {miscellaneous error conditions} {
 590     list [catch {info s} msg] $msg
 591 } {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
 592
 593 # cleanup
 594 catch {namespace delete test_ns_info1 test_ns_info2}
 595 ::tcltest::cleanupTests
 596 return
 597