开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
info.test
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：34k
源码类别：

通讯编程

开发平台：

Visual C++

info.test：源码内容
  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 (c) 1991-1994 The Regents of the University of California.
  9. # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  10. # Copyright (c) 1998-1999 by Scriptics Corporation.
  11. # Copyright (c) 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. # RCS: @(#) $Id: info.test,v 1.24.2.5 2006/11/28 22:20:02 andreas_kupries Exp $
  18. if {[lsearch [namespace children] ::tcltest] == -1} {
  19.     package require tcltest 2
  20.     namespace import -force ::tcltest::*
  21. }
  23. # Set up namespaces needed to test operation of "info args", "info body",
  24. # "info default", and "info procs" with imported procedures.
  26. catch {namespace delete test_ns_info1 test_ns_info2}
  28. namespace eval test_ns_info1 {
  29.     namespace export *
  30.     proc p {x} {return "x=$x"}
  31.     proc q {{y 27} {z {}}} {return "y=$y"}
  32. }
  34. testConstraint tip280  [info exists tcl_platform(tip,280)]
  35. testConstraint !tip280 [expr {![info exists tcl_platform(tip,280)]}]
  38. test info-1.1 {info args option} {
  39.     proc t1 {a bbb c} {return foo}
  40.     info args t1
  41. } {a bbb c}
  42. test info-1.2 {info args option} {
  43.     proc t1 {{a default1} {bbb default2} {c default3} args} {return foo}
  44.     info a t1
  45. } {a bbb c args}
  46. test info-1.3 {info args option} {
  47.     proc t1 "" {return foo}
  48.     info args t1
  49. } {}
  50. test info-1.4 {info args option} {
  51.     catch {rename t1 {}}
  52.     list [catch {info args t1} msg] $msg
  53. } {1 {"t1" isn't a procedure}}
  54. test info-1.5 {info args option} {
  55.     list [catch {info args set} msg] $msg
  56. } {1 {"set" isn't a procedure}}
  57. test info-1.6 {info args option} {
  58.     proc t1 {a b} {set c 123; set d $c}
  59.     t1 1 2
  60.     info args t1
  61. } {a b}
  62. test info-1.7 {info args option} {
  63.     catch {namespace delete test_ns_info2}
  64.     namespace eval test_ns_info2 {
  65.         namespace import ::test_ns_info1::*
  66.         list [info args p] [info args q]
  67.     }
  68. } {x {y z}}
  70. test info-2.1 {info body option} {
  71.     proc t1 {} {body of t1}
  72.     info body t1
  73. } {body of t1}
  74. test info-2.2 {info body option} {
  75.     list [catch {info body set} msg] $msg
  76. } {1 {"set" isn't a procedure}}
  77. test info-2.3 {info body option} {
  78.     list [catch {info args set 1} msg] $msg
  79. } {1 {wrong # args: should be "info args procname"}}
  80. test info-2.4 {info body option} {
  81.     catch {namespace delete test_ns_info2}
  82.     namespace eval test_ns_info2 {
  83.         namespace import ::test_ns_info1::*
  84.         list [info body p] [info body q]
  85.     }
  86. } {{return "x=$x"} {return "y=$y"}}
  87. # Prior to 8.3.0 this would cause a crash because [info body]
  88. # would return the bytecompiled version of foo, which the catch
  89. # would then try and eval out of the foo context, accessing
  90. # compiled local indices
  91. test info-2.5 {info body option, returning bytecompiled bodies} {
  92.     catch {unset args}
  93.     proc foo {args} {
  94. foreach v $args {
  95.     upvar $v var
  96.     return "variable $v existence: [info exists var]"
  97. }
  98.     }
  99.     foo a
  100.     list [catch [info body foo] msg] $msg
  101. } {1 {can't read "args": no such variable}}
  102. # Fix for problem tested for in info-2.5 caused problems when
  103. # procedure body had no string rep (i.e. was not yet bytecode)
  104. # causing an empty string to be returned [Bug #545644]
  105. test info-2.6 {info body option, returning list bodies} {
  106.     proc foo args [list subst bar]
  107.     list [string bytelength [info body foo]] 
  108.     [foo; string bytelength [info body foo]]
  109. } {9 9}
  111. # "info cmdcount" is no longer accurate for compiled commands!
  112. # The expected result for info-3.1 used to be "3" and is now "1"
  113. # since the "set"s have been compiled away.  info-3.2 was corrected
  114. # in 8.3 because the eval'ed body won't be compiled.
  115. proc testinfocmdcount {} {
  116.     set x [info cmdcount]
  117.     set y 12345
  118.     set z [info cm]
  119.     expr $z-$x
  120. }
  121. test info-3.1 {info cmdcount compiled} {
  122.     testinfocmdcount
  123. } 1
  124. test info-3.2 {info cmdcount evaled} {
  125.     set x [info cmdcount]
  126.     set y 12345
  127.     set z [info cm]
  128.     expr $z-$x
  129. } 3
  130. test info-3.3 {info cmdcount evaled} [info body testinfocmdcount] 3
  131. test info-3.4 {info cmdcount option} {
  132.     list [catch {info cmdcount 1} msg] $msg
  133. } {1 {wrong # args: should be "info cmdcount"}}
  135. test info-4.1 {info commands option} {
  136.     proc t1 {} {}
  137.     proc t2 {} {}
  138.     set x " [info commands] "
  139.     list [string match {* t1 *} $x] [string match {* t2 *} $x] 
  140.             [string match {* set *} $x] [string match {* list *} $x]
  141. } {1 1 1 1}
  142. test info-4.2 {info commands option} {
  143.     proc t1 {} {}
  144.     rename t1 {}
  145.     set x [info comm]
  146.     string match {* t1 *} $x
  147. } 0
  148. test info-4.3 {info commands option} {
  149.     proc _t1_ {} {}
  150.     proc _t2_ {} {}
  151.     info commands _t1_
  152. } _t1_
  153. test info-4.4 {info commands option} {
  154.     proc _t1_ {} {}
  155.     proc _t2_ {} {}
  156.     lsort [info commands _t*]
  157. } {_t1_ _t2_}
  158. catch {rename _t1_ {}}
  159. catch {rename _t2_ {}}
  160. test info-4.5 {info commands option} {
  161.     list [catch {info commands a b} msg] $msg
  162. } {1 {wrong # args: should be "info commands ?pattern?"}}
  164. test info-5.1 {info complete option} {
  165.     list [catch {info complete} msg] $msg
  166. } {1 {wrong # args: should be "info complete command"}}
  167. test info-5.2 {info complete option} {
  168.     info complete abc
  169. } 1
  170. test info-5.3 {info complete option} {
  171.     info complete "{abcd "
  172. } 0
  173. test info-5.4 {info complete option} {
  174.     info complete {# Comment should be complete command}
  175. } 1
  176. test info-5.5 {info complete option} {
  177.     info complete {[a [b] }
  178. } 0
  179. test info-5.6 {info complete option} {
  180.     info complete {[a [b]}
  181. } 0
  183. test info-6.1 {info default option} {
  184.     proc t1 {a b {c d} {e "long default value"}} {}
  185.     info default t1 a value
  186. } 0
  187. test info-6.2 {info default option} {
  188.     proc t1 {a b {c d} {e "long default value"}} {}
  189.     set value 12345
  190.     info d t1 a value
  191.     set value
  192. } {}
  193. test info-6.3 {info default option} {
  194.     proc t1 {a b {c d} {e "long default value"}} {}
  195.     info default t1 c value
  196. } 1
  197. test info-6.4 {info default option} {
  198.     proc t1 {a b {c d} {e "long default value"}} {}
  199.     set value 12345
  200.     info default t1 c value
  201.     set value
  202. } d
  203. test info-6.5 {info default option} {
  204.     proc t1 {a b {c d} {e "long default value"}} {}
  205.     set value 12345
  206.     set x [info default t1 e value]
  207.     list $x $value
  208. } {1 {long default value}}
  209. test info-6.6 {info default option} {
  210.     list [catch {info default a b} msg] $msg
  211. } {1 {wrong # args: should be "info default procname arg varname"}}
  212. test info-6.7 {info default option} {
  213.     list [catch {info default _nonexistent_ a b} msg] $msg
  214. } {1 {"_nonexistent_" isn't a procedure}}
  215. test info-6.8 {info default option} {
  216.     proc t1 {a b} {}
  217.     list [catch {info default t1 x value} msg] $msg
  218. } {1 {procedure "t1" doesn't have an argument "x"}}
  219. test info-6.9 {info default option} {
  220.     catch {unset a}
  221.     set a(0) 88
  222.     proc t1 {a b} {}
  223.     list [catch {info default t1 a a} msg] $msg
  224. } {1 {couldn't store default value in variable "a"}}
  225. test info-6.10 {info default option} {
  226.     catch {unset a}
  227.     set a(0) 88
  228.     proc t1 {{a 18} b} {}
  229.     list [catch {info default t1 a a} msg] $msg
  230. } {1 {couldn't store default value in variable "a"}}
  231. test info-6.11 {info default option} {
  232.     catch {namespace delete test_ns_info2}
  233.     namespace eval test_ns_info2 {
  234.         namespace import ::test_ns_info1::*
  235.         list [info default p x foo] $foo [info default q y bar] $bar
  236.     }
  237. } {0 {} 1 27}
  238. catch {unset a}
  240. test info-7.1 {info exists option} {
  241.     set value foo
  242.     info exists value
  243. } 1
  244. catch {unset _nonexistent_}
  245. test info-7.2 {info exists option} {
  246.     info exists _nonexistent_
  247. } 0
  248. test info-7.3 {info exists option} {
  249.     proc t1 {x} {return [info exists x]}
  250.     t1 2
  251. } 1
  252. test info-7.4 {info exists option} {
  253.     proc t1 {x} {
  254.         global _nonexistent_
  255.         return [info exists _nonexistent_]
  256.     }
  257.     t1 2
  258. } 0
  259. test info-7.5 {info exists option} {
  260.     proc t1 {x} {
  261.         set y 47
  262.         return [info exists y]
  263.     }
  264.     t1 2
  265. } 1
  266. test info-7.6 {info exists option} {
  267.     proc t1 {x} {return [info exists value]}
  268.     t1 2
  269. } 0
  270. test info-7.7 {info exists option} {
  271.     catch {unset x}
  272.     set x(2) 44
  273.     list [info exists x] [info exists x(1)] [info exists x(2)]
  274. } {1 0 1}
  275. catch {unset x}
  276. test info-7.8 {info exists option} {
  277.     list [catch {info exists} msg] $msg
  278. } {1 {wrong # args: should be "info exists varName"}}
  279. test info-7.9 {info exists option} {
  280.     list [catch {info exists 1 2} msg] $msg
  281. } {1 {wrong # args: should be "info exists varName"}}
  283. test info-8.1 {info globals option} {
  284.     set x 1
  285.     set y 2
  286.     set value 23
  287.     set a " [info globals] "
  288.     list [string match {* x *} $a] [string match {* y *} $a] 
  289.             [string match {* value *} $a] [string match {* _foobar_ *} $a]
  290. } {1 1 1 0}
  291. test info-8.2 {info globals option} {
  292.     set _xxx1 1
  293.     set _xxx2 2
  294.     lsort [info g _xxx*]
  295. } {_xxx1 _xxx2}
  296. test info-8.3 {info globals option} {
  297.     list [catch {info globals 1 2} msg] $msg
  298. } {1 {wrong # args: should be "info globals ?pattern?"}}
  299. test info-8.4 {info globals option: may have leading namespace qualifiers} {
  300.     set x 0
  301.     list [info globals x] [info globals :x] [info globals ::x] [info globals :::x] [info globals ::::x]
  302. } {x {} x x x}
  303. test info-8.5 {info globals option: only return existing global variables} {
  304.     -setup {
  305. catch {unset ::NO_SUCH_VAR}
  306. proc evalInProc script {eval $script}
  307.     }
  308.     -body {
  309. evalInProc {global NO_SUCH_VAR; info globals NO_SUCH_VAR}
  310.     }
  311.     -cleanup {
  312. rename evalInProc {}
  313.     }
  314.     -result {}
  315. }
  317. test info-9.1 {info level option} {
  318.     info level
  319. } 0
  320. test info-9.2 {info level option} {
  321.     proc t1 {a b} {
  322.         set x [info le]
  323.         set y [info level 1]
  324.         list $x $y
  325.     }
  326.     t1 146 testString
  327. } {1 {t1 146 testString}}
  328. test info-9.3 {info level option} {
  329.     proc t1 {a b} {
  330.         t2 [expr $a*2] $b
  331.     }
  332.     proc t2 {x y} {
  333.         list [info level] [info level 1] [info level 2] [info level -1] 
  334.                 [info level 0]
  335.     }
  336.     t1 146 {a {b c} {{{c}}}}
  337. } {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}}}}}}
  338. test info-9.4 {info level option} {
  339.     proc t1 {} {
  340.         set x [info level]
  341.         set y [info level 1]
  342.         list $x $y
  343.     }
  344.     t1
  345. } {1 t1}
  346. test info-9.5 {info level option} {
  347.     list [catch {info level 1 2} msg] $msg
  348. } {1 {wrong # args: should be "info level ?number?"}}
  349. test info-9.6 {info level option} {
  350.     list [catch {info level 123a} msg] $msg
  351. } {1 {expected integer but got "123a"}}
  352. test info-9.7 {info level option} {
  353.     list [catch {info level 0} msg] $msg
  354. } {1 {bad level "0"}}
  355. test info-9.8 {info level option} {
  356.     proc t1 {} {info level -1}
  357.     list [catch {t1} msg] $msg
  358. } {1 {bad level "-1"}}
  359. test info-9.9 {info level option} {
  360.     proc t1 {x} {info level $x}
  361.     list [catch {t1 -3} msg] $msg
  362. } {1 {bad level "-3"}}
  363. test info-9.10 {info level option, namespaces} {
  364.     set msg [namespace eval t {info level 0}]
  365.     namespace delete t
  366.     set msg
  367. } {namespace eval t {info level 0}}
  369. set savedLibrary $tcl_library
  370. test info-10.1 {info library option} {
  371.     list [catch {info library x} msg] $msg
  372. } {1 {wrong # args: should be "info library"}}
  373. test info-10.2 {info library option} {
  374.     set tcl_library 12345
  375.     info library
  376. } {12345}
  377. test info-10.3 {info library option} {
  378.     unset tcl_library
  379.     list [catch {info library} msg] $msg
  380. } {1 {no library has been specified for Tcl}}
  381. set tcl_library $savedLibrary
  383. test info-11.1 {info loaded option} {
  384.     list [catch {info loaded a b} msg] $msg
  385. } {1 {wrong # args: should be "info loaded ?interp?"}}
  386. test info-11.2 {info loaded option} {
  387.     list [catch {info loaded {}}] [catch {info loaded gorp} msg] $msg
  388. } {0 1 {could not find interpreter "gorp"}}
  390. test info-12.1 {info locals option} {
  391.     set a 22
  392.     proc t1 {x y} {
  393.         set b 13
  394.         set c testing
  395.         global a
  396. global aa
  397. set aa 23
  398.         return [info locals]
  399.     }
  400.     lsort [t1 23 24]
  401. } {b c x y}
  402. test info-12.2 {info locals option} {
  403.     proc t1 {x y} {
  404.         set xx1 2
  405.         set xx2 3
  406.         set y 4
  407.         return [info loc x*]
  408.     }
  409.     lsort [t1 2 3]
  410. } {x xx1 xx2}
  411. test info-12.3 {info locals option} {
  412.     list [catch {info locals 1 2} msg] $msg
  413. } {1 {wrong # args: should be "info locals ?pattern?"}}
  414. test info-12.4 {info locals option} {
  415.     info locals
  416. } {}
  417. test info-12.5 {info locals option} {
  418.     proc t1 {} {return [info locals]}
  419.     t1
  420. } {}
  421. test info-12.6 {info locals vs unset compiled locals} {
  422.     proc t1 {lst} {
  423.         foreach $lst $lst {}
  424.         unset lst
  425.         return [info locals]
  426.     }
  427.     lsort [t1 {a b c c d e f}]
  428. } {a b c d e f}
  429. test info-12.7 {info locals with temporary variables} {
  430.     proc t1 {} {
  431.         foreach a {b c} {}
  432.         info locals
  433.     }
  434.     t1
  435. } {a}
  437. test info-13.1 {info nameofexecutable option} {
  438.     list [catch {info nameofexecutable foo} msg] $msg
  439. } {1 {wrong # args: should be "info nameofexecutable"}}
  441. test info-14.1 {info patchlevel option} {
  442.     set a [info patchlevel]
  443.     regexp {[0-9]+.[0-9]+([p[0-9]+)?} $a
  444. } 1
  445. test info-14.2 {info patchlevel option} {
  446.     list [catch {info patchlevel a} msg] $msg
  447. } {1 {wrong # args: should be "info patchlevel"}}
  448. test info-14.3 {info patchlevel option} {
  449.     set t $tcl_patchLevel
  450.     unset tcl_patchLevel
  451.     set result [list [catch {info patchlevel} msg] $msg]
  452.     set tcl_patchLevel $t
  453.     set result
  454. } {1 {can't read "tcl_patchLevel": no such variable}}
  456. test info-15.1 {info procs option} {
  457.     proc t1 {} {}
  458.     proc t2 {} {}
  459.     set x " [info procs] "
  460.     list [string match {* t1 *} $x] [string match {* t2 *} $x] 
  461.             [string match {* _undefined_ *} $x]
  462. } {1 1 0}
  463. test info-15.2 {info procs option} {
  464.     proc _tt1 {} {}
  465.     proc _tt2 {} {}
  466.     lsort [info pr _tt*]
  467. } {_tt1 _tt2}
  468. catch {rename _tt1 {}}
  469. catch {rename _tt2 {}}
  470. test info-15.3 {info procs option} {
  471.     list [catch {info procs 2 3} msg] $msg
  472. } {1 {wrong # args: should be "info procs ?pattern?"}}
  473. test info-15.4 {info procs option} {
  474.     catch {namespace delete test_ns_info2}
  475.     namespace eval test_ns_info2 {
  476.         namespace import ::test_ns_info1::*
  477.         proc r {} {}
  478.         list [info procs] [info procs p*]
  479.     }
  480. } {{p q r} p}
  481. test info-15.5 {info procs option with a proc in a namespace} {
  482.     catch {namespace delete test_ns_info2}
  483.     namespace eval test_ns_info2 {
  484. proc p1 { arg } {
  485.     puts cmd
  486. }
  487.         proc p2 { arg } {
  488.     puts cmd
  489. }
  490.     }
  491.     info procs ::test_ns_info2::p1
  492. } {::test_ns_info2::p1}
  493. test info-15.6 {info procs option with a pattern in a namespace} {
  494.     catch {namespace delete test_ns_info2}
  495.     namespace eval test_ns_info2 {
  496. proc p1 { arg } {
  497.     puts cmd
  498. }
  499.         proc p2 { arg } {
  500.     puts cmd
  501. }
  502.     }
  503.     lsort [info procs ::test_ns_info2::p*]
  504. } [lsort [list ::test_ns_info2::p1 ::test_ns_info2::p2]]
  505. test info-15.7 {info procs option with a global shadowing proc} {
  506.     catch {namespace delete test_ns_info2}
  507.     proc string_cmd { arg } {
  508.         puts cmd
  509.     }
  510.     namespace eval test_ns_info2 {
  511. proc string_cmd { arg } {
  512.     puts cmd
  513. }
  514.     }
  515.     info procs test_ns_info2::string*
  516. } {::test_ns_info2::string_cmd}
  517. # This regression test is currently commented out because it requires
  518. # that the implementation of "info procs" looks into the global namespace,
  519. # which it does not (in contrast to "info commands")
  520. if {0} {
  521. test info-15.8 {info procs option with a global shadowing proc} {
  522.     catch {namespace delete test_ns_info2}
  523.     proc string_cmd { arg } {
  524.         puts cmd
  525.     }
  526.     proc string_cmd2 { arg } {
  527.         puts cmd
  528.     }
  529.     namespace eval test_ns_info2 {
  530. proc string_cmd { arg } {
  531.     puts cmd
  532. }
  533.     }
  534.     namespace eval test_ns_info2 {
  535.         lsort [info procs string*]
  536.     }
  537. } [lsort [list string_cmd string_cmd2]]
  538. }
  540. test info-16.1 {info script option} {
  541.     list [catch {info script x x} msg] $msg
  542. } {1 {wrong # args: should be "info script ?filename?"}}
  543. test info-16.2 {info script option} {
  544.     file tail [info sc]
  545. } "info.test"
  546. set gorpfile [makeFile "info scriptn" gorp.info]
  547. test info-16.3 {info script option} {
  548.     list [source $gorpfile] [file tail [info script]]
  549. } [list $gorpfile info.test]
  550. test info-16.4 {resetting "info script" after errors} {
  551.     catch {source ~_nobody_/foo}
  552.     file tail [info script]
  553. } "info.test"
  554. test info-16.5 {resetting "info script" after errors} {
  555.     catch {source _nonexistent_}
  556.     file tail [info script]
  557. } "info.test"
  558. test info-16.6 {info script option} {
  559.     set script [info script]
  560.     list [file tail [info script]] 
  561.     [info script newname.txt] 
  562.     [file tail [info script $script]]
  563. } [list info.test newname.txt info.test]
  564. test info-16.7 {info script option} {
  565.     set script [info script]
  566.     info script newname.txt
  567.     list [source $gorpfile] [file tail [info script]] 
  568.     [file tail [info script $script]]
  569. } [list $gorpfile newname.txt info.test]
  570. removeFile gorp.info
  571. set gorpfile [makeFile {list [info script] [info script foo.bar]} gorp.info]
  572. test info-16.8 {info script option} {
  573.     list [source $gorpfile] [file tail [info script]]
  574. } [list [list $gorpfile foo.bar] info.test]
  575. removeFile gorp.info
  577. test info-17.1 {info sharedlibextension option} {
  578.     list [catch {info sharedlibextension foo} msg] $msg
  579. } {1 {wrong # args: should be "info sharedlibextension"}}
  581. test info-18.1 {info tclversion option} {
  582.     set x [info tclversion]
  583.     scan $x "%d.%d%c" a b c
  584. } 2
  585. test info-18.2 {info tclversion option} {
  586.     list [catch {info t 2} msg] $msg
  587. } {1 {wrong # args: should be "info tclversion"}}
  588. test info-18.3 {info tclversion option} {
  589.     set t $tcl_version
  590.     unset tcl_version
  591.     set result [list [catch {info tclversion} msg] $msg]
  592.     set tcl_version $t
  593.     set result
  594. } {1 {can't read "tcl_version": no such variable}}
  596. test info-19.1 {info vars option} {
  597.     set a 1
  598.     set b 2
  599.     proc t1 {x y} {
  600.         global a b
  601.         set c 33
  602.         return [info vars]
  603.     }
  604.     lsort [t1 18 19]
  605. } {a b c x y}
  606. test info-19.2 {info vars option} {
  607.     set xxx1 1
  608.     set xxx2 2
  609.     proc t1 {xxa y} {
  610.         global xxx1 xxx2
  611.         set c 33
  612.         return [info vars x*]
  613.     }
  614.     lsort [t1 18 19]
  615. } {xxa xxx1 xxx2}
  616. test info-19.3 {info vars option} {
  617.     lsort [info vars]
  618. } [lsort [info globals]]
  619. test info-19.4 {info vars option} {
  620.     list [catch {info vars a b} msg] $msg
  621. } {1 {wrong # args: should be "info vars ?pattern?"}}
  622. test info-19.5 {info vars with temporary variables} {
  623.     proc t1 {} {
  624.         foreach a {b c} {}
  625.         info vars
  626.     }
  627.     t1
  628. } {a}
  629. test info-19.6 {info vars: Bug 1072654} -setup {
  630.     namespace eval :: unset -nocomplain foo
  631.     catch {namespace delete x}
  632. } -body {
  633.     namespace eval x info vars foo
  634. } -cleanup {
  635.     namespace delete x
  636. } -result {}
  638. # Check whether the extra testing functions are defined...
  639. if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
  640.     set functions {abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
  641. } else {
  642.     set functions {T1 T2 T3 abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
  643. }
  644. test info-20.1 {info functions option} {info functions sin} sin
  645. test info-20.2 {info functions option} {lsort [info functions]} $functions
  646. test info-20.3 {info functions option} {
  647.     lsort [info functions a*]
  648. } {abs acos asin atan atan2}
  649. test info-20.4 {info functions option} {
  650.     lsort [info functions *tan*]
  651. } {atan atan2 tan tanh}
  652. test info-20.5 {info functions option} {
  653.     list [catch {info functions raise an error} msg] $msg
  654. } {1 {wrong # args: should be "info functions ?pattern?"}}
  656. test info-21.1 {miscellaneous error conditions} {
  657.     list [catch {info} msg] $msg
  658. } {1 {wrong # args: should be "info option ?arg arg ...?"}}
  659. test info-21.2 {miscellaneous error conditions} !tip280 {
  660.     list [catch {info gorp} msg] $msg
  661. } {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
  662. test info-21.2-280 {miscellaneous error conditions} tip280 {
  663.     list [catch {info gorp} msg] $msg
  664. } {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
  665. test info-21.3 {miscellaneous error conditions} !tip280 {
  666.     list [catch {info c} msg] $msg
  667. } {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
  668. test info-21.3-280 {miscellaneous error conditions} tip280 {
  669.     list [catch {info c} msg] $msg
  670. } {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
  671. test info-21.4 {miscellaneous error conditions} !tip280 {
  672.     list [catch {info l} msg] $msg
  673. } {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
  674. test info-21.4-280 {miscellaneous error conditions} tip280 {
  675.     list [catch {info l} msg] $msg
  676. } {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
  677. test info-21.5 {miscellaneous error conditions} !tip280 {
  678.     list [catch {info s} msg] $msg
  679. } {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
  680. test info-21.5-280 {miscellaneous error conditions} tip280 {
  681.     list [catch {info s} msg] $msg
  682. } {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
  684. ##
  685. # ### ### ### ######### ######### #########
  686. ## info frame
  688. ## Helper
  689. # For the more complex results we cut the file name down to remove
  690. # path dependencies, and we use only part of the first line of the
  691. # reported command. The latter is required because otherwise the whole
  692. # test case may appear in some results, but the result is part of the
  693. # testcase. An infinite string would be required to describe that. The
  694. # cutting-down breaks this.
  696. proc reduce {frame} {
  697.     set pos [lsearch -exact $frame cmd]
  698.     incr pos
  699.     set cmd   [lindex $frame $pos]
  700.     if {[regexp n $cmd]} {
  701. set first [string range [lindex [split $cmd n] 0] 0 end-11]
  702. set frame [lreplace $frame $pos $pos $first]
  703.     }
  704.     set pos [lsearch -exact $frame file]
  705.     if {$pos >=0} {
  706. incr pos
  707. set tail  [file tail [lindex $frame $pos]]
  708. set frame [lreplace $frame $pos $pos $tail]
  709.     }
  710.     set frame
  711. }
  713. ## Helper
  714. # Generate a stacktrace from the current location to top.  This code
  715. # not only depends on the exact location of things, but also on the
  716. # implementation of tcltest. Any changes and these tests will have to
  717. # be updated.
  719. proc etrace {} {
  720.     set res {}
  721.     set level [info frame]
  722.     while {$level} {
  723. lappend res [list $level [reduce [info frame $level]]]
  724. incr level -1
  725.     }
  726.     return $res
  727. }
  729. ##
  731. test info-22.0 {info frame, levels} tip280 {
  732.     info frame
  733. } 7
  735. test info-22.1 {info frame, bad level relative} tip280 {
  736.     # catch is another level!, i.e. we have 8, not 7
  737.     catch {info frame -8} msg
  738.     set msg
  739. } {bad level "-8"}
  741. test info-22.2 {info frame, bad level absolute} tip280 {
  742.     # catch is another level!, i.e. we have 8, not 7
  743.     catch {info frame 9} msg
  744.     set msg
  745. } {bad level "9"}
  747. test info-22.3 {info frame, current, relative} tip280 {
  748.     info frame 0
  749. } {type eval line 2 cmd {info frame 0}}
  751. test info-22.4 {info frame, current, relative, nested} tip280 {
  752.     set res [info frame 0]
  753. } {type eval line 2 cmd {info frame 0}}
  755. test info-22.5 {info frame, current, absolute} tip280 {
  756.     reduce [info frame 7]
  757. } {type eval line 2 cmd {info frame 7}}
  759. test info-22.6 {info frame, global, relative} tip280 {
  760.     reduce [info frame -6]
  761. } {type source line 759 file info.test cmd test info-22.6 {info frame, global, relativ}
  763. test info-22.7 {info frame, global, absolute} tip280 {
  764.     reduce [info frame 1]
  765. } {type source line 763 file info.test cmd test info-22.7 {info frame, global, absolut}
  767. test info-22.8 {info frame, basic trace} tip280 {
  768.     join [etrace] n
  769. } {8 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
  770. 7 {type eval line 2 cmd etrace}
  771. 6 {type source line 2277 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest}
  772. 5 {type eval line 1 cmd {::tcltest::RunTest }}
  773. 4 {type source line 1619 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval}
  774. 3 {type eval line 1 cmd ::tcltest::Eval {::tcltest::RunTest }
  775. 2 {type source line 1966 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test}
  776. 1 {type source line 767 file info.test cmd test info-22.8 {info frame, basic trac}}
  777. ## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0
  778. test info-23.0 {eval'd info frame} tip280 {
  779.     eval {info frame}
  780. } 8
  782. test info-23.1 {eval'd info frame, semi-dynamic} tip280 {
  783.     eval info frame
  784. } 8
  786. test info-23.2 {eval'd info frame, dynamic} tip280 {
  787.     set script {info frame}
  788.     eval $script
  789. } 8
  791. test info-23.3 {eval'd info frame, literal} tip280 {
  792.     eval {
  793. info frame 0
  794.     }
  795. } {type eval line 2 cmd {info frame 0}}
  797. test info-23.4 {eval'd info frame, semi-dynamic} tip280 {
  798.     eval info frame 0
  799. } {type eval line 1 cmd {info frame 0}}
  801. test info-23.5 {eval'd info frame, dynamic} tip280 {
  802.     set script {info frame 0}
  803.     eval $script
  804. } {type eval line 1 cmd {info frame 0}}
  806. test info-23.6 {eval'd info frame, trace} tip280 {
  807.     set script {etrace}
  808.     join [eval $script] n
  809. } {9 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
  810. 8 {type eval line 1 cmd etrace}
  811. 7 {type eval line 3 cmd {eval $script}}
  812. 6 {type source line 2277 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest}
  813. 5 {type eval line 1 cmd {::tcltest::RunTest }}
  814. 4 {type source line 1619 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval}
  815. 3 {type eval line 1 cmd ::tcltest::Eval {::tcltest::RunTest }
  816. 2 {type source line 1966 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test}
  817. 1 {type source line 806 file info.test cmd test info-23.6 {eval'd info frame, trac}}
  818. ## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0
  819. # -------------------------------------------------------------------------
  821. # Procedures defined in scripts which are arguments to control
  822. # structures (like 'namespace eval', 'interp eval', 'if', 'while',
  823. # 'switch', 'catch', 'for', 'foreach', etc.) have no absolute
  824. # location. The command implementations execute such scripts through
  825. # Tcl_EvalObjEx. Flag 0 causes it to use the bytecode compiler. This
  826. # causes the connection to the context to be lost. Currently only
  827. # procedure bodies are able to remember their context.
  829. # -------------------------------------------------------------------------
  831. namespace eval foo {
  832.     proc bar {} {info frame 0}
  833. }
  835. test info-24.0 {info frame, interaction, namespace eval} tip280 {
  836.     reduce [foo::bar]
  837. } {type source line 832 file info.test cmd {info frame 0} proc ::foo::bar level 0}
  839. namespace delete foo
  841. # -------------------------------------------------------------------------
  843. set flag 1
  844. if {$flag} {
  845.     namespace eval foo {}
  846.     proc ::foo::bar {} {info frame 0}
  847. }
  849. test info-24.1 {info frame, interaction, if} tip280 {
  850.     reduce [foo::bar]
  851. } {type source line 846 file info.test cmd {info frame 0} proc ::foo::bar level 0}
  853. namespace delete foo
  855. # -------------------------------------------------------------------------
  857. set flag 1
  858. while {$flag} {
  859.     namespace eval foo {}
  860.     proc ::foo::bar {} {info frame 0}
  861.     set flag 0
  862. }
  864. test info-24.2 {info frame, interaction, while} tip280 {
  865.     reduce [foo::bar]
  866. } {type source line 860 file info.test cmd {info frame 0} proc ::foo::bar level 0}
  868. namespace delete foo
  870. # -------------------------------------------------------------------------
  872. catch {
  873.     namespace eval foo {}
  874.     proc ::foo::bar {} {info frame 0}
  875. }
  877. test info-24.3 {info frame, interaction, catch} tip280 {
  878.     reduce [foo::bar]
  879. } {type source line 874 file info.test cmd {info frame 0} proc ::foo::bar level 0}
  881. namespace delete foo
  883. # -------------------------------------------------------------------------
  885. foreach var val {
  886.     namespace eval foo {}
  887.     proc ::foo::bar {} {info frame 0}
  888.     break
  889. }
  891. test info-24.4 {info frame, interaction, foreach} tip280 {
  892.     reduce [foo::bar]
  893. } {type source line 887 file info.test cmd {info frame 0} proc ::foo::bar level 0}
  895. namespace delete foo
  897. # -------------------------------------------------------------------------
  899. for {} {1} {} {
  900.     namespace eval foo {}
  901.     proc ::foo::bar {} {info frame 0}
  902.     break
  903. }
  905. test info-24.5 {info frame, interaction, for} tip280 {
  906.     reduce [foo::bar]
  907. } {type source line 901 file info.test cmd {info frame 0} proc ::foo::bar level 0}
  909. namespace delete foo
  911. # -------------------------------------------------------------------------
  913. eval {
  914.     proc bar {} {info frame 0}
  915. }
  917. test info-25.0 {info frame, proc in eval} tip280 {
  918.     reduce [bar]
  919. } {type source line 914 file info.test cmd {info frame 0} proc ::bar level 0}
  921. proc bar {} {info frame 0}
  922. test info-25.1 {info frame, regular proc} tip280 {
  923.     reduce [bar]
  924. } {type source line 921 file info.test cmd {info frame 0} proc ::bar level 0}
  925. rename bar {}
  929. test info-30.0 {bs+nl in literal words} {tip280 knownBug} {
  930.     if {1} {
  931. set res 
  932.     [reduce [info frame 0]]
  933.     }
  934.     set res
  935.     # This is reporting line 3 instead of the correct 4 because the
  936.     # bs+nl combination is subst by the parser before the 'if'
  937.     # command, and the the bcc sees the word. To fix record the
  938.     # offsets of all bs+nl sequences in literal words, then use the
  939.     # information in the bcc to bump line numbers when parsing over
  940.     # the location. Also affected: testcases 22.8 and 23.6.
  941. } {type eval line 4 cmd {info frame 0} proc ::tcltest::RunTest}
  945. # -------------------------------------------------------------------------
  946. # See 24.0 - 24.5 for similar situations, using literal scripts.
  948. set body {set flag 0
  949.     set a c
  950.     set res [info frame 0]} ;# line 3!
  952. test info-31.0 {ns eval, script in variable} tip280 {
  953.     namespace eval foo $body
  954.     set res
  955. } {type eval line 3 cmd {info frame 0} level 0}
  956. catch {namespace delete foo}
  959. test info-31.1 {if, script in variable} tip280 {
  960.     if 1 $body
  961.     set res
  962. } {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
  964. test info-31.1a {if, script in variable} tip280 {
  965.     if 1 then $body
  966.     set res
  967. } {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
  971. test info-31.2 {while, script in variable} tip280 {
  972.     set flag 1
  973.     while {$flag} $body
  974.     set res
  975. } {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
  977. # .3 - proc - scoping prevent return of result ...
  979. test info-31.4 {foreach, script in variable} tip280 {
  980.     foreach var val $body
  981.     set res
  982. } {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
  984. test info-31.5 {for, script in variable} tip280 {
  985.     set flag 1
  986.     for {} {$flag} {} $body
  987.     set res
  988. } {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
  990. test info-31.6 {eval, script in variable} tip280 {
  991.     eval $body
  992.     set res
  993. } {type eval line 3 cmd {info frame 0}}
  995. # -------------------------------------------------------------------------
  997. namespace eval foo {}
  998. set x foo
  999. switch -exact -- $x {
  1000.     foo {
  1001. proc ::foo::bar {} {info frame 0}
  1002.     }
  1003. }
  1005. test info-24.6.0 {info frame, interaction, switch, list body} tip280 {
  1006.     reduce [foo::bar]
  1007. } {type source line 1001 file info.test cmd {info frame 0} proc ::foo::bar level 0}
  1009. namespace delete foo
  1010. unset x
  1012. # -------------------------------------------------------------------------
  1014. namespace eval foo {}
  1015. set x foo
  1016. switch -exact -- $x foo {
  1017.     proc ::foo::bar {} {info frame 0}
  1018. }
  1020. test info-24.6.1 {info frame, interaction, switch, multi-body} tip280 {
  1021.     reduce [foo::bar]
  1022. } {type source line 1017 file info.test cmd {info frame 0} proc ::foo::bar level 0}
  1024. namespace delete foo
  1025. unset x
  1027. # -------------------------------------------------------------------------
  1029. namespace eval foo {}
  1030. set x foo
  1031. switch -exact -- $x [list foo {
  1032.     proc ::foo::bar {} {info frame 0}
  1033. }]
  1035. test info-24.6.2 {info frame, interaction, switch, list body, dynamic} tip280 {
  1036.     reduce [foo::bar]
  1037. } {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
  1039. namespace delete foo
  1040. unset x
  1042. # -------------------------------------------------------------------------
  1044. set body {
  1045.     foo {
  1046. proc ::foo::bar {} {info frame 0}
  1047.     }
  1048. }
  1050. namespace eval foo {}
  1051. set x foo
  1052. switch -exact -- $x $body
  1054. test info-31.7 {info frame, interaction, switch, dynamic} tip280 {
  1055.     reduce [foo::bar]
  1056. } {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
  1058. namespace delete foo
  1059. unset x
  1061. # -------------------------------------------------------------------------
  1063. set body {
  1064.     proc ::foo::bar {} {info frame 0}
  1065. }
  1067. namespace eval foo {}
  1068. eval $body
  1070. test info-32.0 {info frame, dynamic procedure} tip280 {
  1071.     reduce [foo::bar]
  1072. } {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
  1074. namespace delete foo
  1076. # -------------------------------------------------------------------------
  1078. # cleanup
  1079. catch {namespace delete test_ns_info1 test_ns_info2}
  1080. ::tcltest::cleanupTests
  1081. return