Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/info.test@bde4ae8d615e

     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 script\n" 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

author	sl@SLION-WIN7.fritz.box
	Fri, 15 Jun 2012 03:10:57 +0200
changeset 0	bde4ae8d615e
permissions	-rw-r--r--