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