Diff
Not logged in
Home Timeline Branches Tags Tickets Wiki Login
Annotate Patch Side-by-side Diff

Differences From Artifact [246b82688b]:

To Artifact [1a17d9aa5a]:

︙
9
10
11
12
13
14
15
16

17
18
19
20
21
22
23

9
10
11
12
13
14
15

16
17
18
19
20
21
22
23








-
+








# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2006      ActiveState
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: info.test,v 1.78 2010/08/03 20:15:53 andreas_kupries Exp $
# RCS: @(#) $Id: info.test,v 1.78.2.1 2010/12/01 16:42:37 kennykb Exp $

if {{::tcltest} ni [namespace children]} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Set up namespaces needed to test operation of "info args", "info body",
︙
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716


717

718
719
720
721
722
723
724

686
687
688
689
690
691
692

693
694
695
696
697
698

699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716

717
718
719
720
721
722
723
724








-






-
















+
+
-
+








test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
    info s
} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}

##
# ### ### ### ######### ######### #########
## info frame

## Helper
# For the more complex results we cut the file name down to remove path
# dependencies, and we use only part of the first line of the reported
# command. The latter is required because otherwise the whole test case may
# appear in some results, but the result is part of the testcase. An infinite
# string would be required to describe that. The cutting-down breaks this.

proc reduce {frame} {
    set  pos [lsearch -exact $frame cmd]
    incr pos
    set  cmd [lindex $frame $pos]
    if {[regexp \n $cmd]} {
	set first [string range [lindex [split $cmd \n] 0] 0 end-4]
	set frame [lreplace $frame $pos $pos $first]
    }
    set pos [lsearch -exact $frame file]
    if {$pos >=0} {
	incr pos
	set tail  [file tail [lindex $frame $pos]]
	set frame [lreplace $frame $pos $pos $tail]
    }
    set frame
}
proc subinterp {} { interp create sub ; interp debug sub -frame 1;
    interp eval sub [list proc reduce [info args reduce] [info body reduce]]

}
## Helper
# Generate a stacktrace from the current location to top.  This code
# not only depends on the exact location of things, but also on the
# implementation of tcltest. Any changes and these tests will have to
# be updated.

proc etrace {} {
︙
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373








1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394









1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410







1411
1412
1413
1414
1415
1416
1417

1359
1360
1361
1362
1363
1364
1365








1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385









1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403







1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417








-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+












-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+









-
-
-
-
-
-
-
+
+
+
+
+
+
+








	etrace
    }
    join [lrange [uplevel \#0 $script] 0 2] \n
} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::tcltest::RunTest}
* {type source line 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y}

test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -body {
    join [lrange [uplevel \#0 {
	set y DL.
	etrace
    }] 0 2] \n
} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1369 file info.test cmd etrace proc ::tcltest::RunTest}
* {type source line 1367 file info.test cmd uplevel\\ \\\\ proc ::tcltest::RunTest}} -cleanup {unset y}
# 38.2 moved to bottom to not disturb other tests with the necessary changes to this one.








test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match glob -body {
    set script {
	set y DPV
	etrace
    }
    join [lrange [control y $script] 0 3] \n
} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y}

test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -body {
    join [lrange [control y {
	set y DPL
	etrace
    }] 0 3] \n
} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1389 file info.test cmd etrace proc ::control}
* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1387 file info.test cmd control proc ::tcltest::RunTest}} -cleanup {unset y}
# 38.4 moved to bottom to not disturb other tests with the necessary changes to this one.









test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body {
    join [lrange [datav] 0 4] \n
} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1}
* {type source line 1397 file info.test cmd datav proc ::tcltest::RunTest}}

test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -body {
    join [lrange [datal] 0 4] \n
} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1344 file info.test cmd etrace proc ::control}
* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1342 file info.test cmd control proc ::datal level 1}
* {type source line 1405 file info.test cmd datal proc ::tcltest::RunTest}}
# 38.6 moved to bottom to not disturb other tests with the necessary changes to this one.







testConstraint testevalex [llength [info commands testevalex]]
test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body {
    join [lrange [testevalex {return -level 0 [etrace]}] 0 3] \n
} -result {* {type source line 728 file info.test cmd {info frame \$level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line 1414 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest}
︙
1539
1540
1541
1542
1543
1544
1545
1546

1547
1548
1549
1550
1551
1552
1553
1554


1555
1556
1557

1558
1559
1560
1561
1562
1563
1564
1565

1566
1567
1568
1569
1570
1571
1572

1539
1540
1541
1542
1543
1544
1545

1546
1547
1548
1549
1550
1551
1552


1553
1554
1555
1556

1557
1558
1559
1560
1561
1562
1563
1564

1565
1566
1567
1568
1569
1570
1571
1572








-
+






-
-
+
+


-
+







-
+








[set x {}] \
[reduce \
     [info frame 0]]";# line 1541
}
} -cleanup {unset res x} -result {   type source line 1541 file info.test cmd {info frame 0} proc ::tcltest::RunTest}

test info-30.13 {bs+nl in literal words, uplevel script, with nested words} -body {
    uplevel #0 {
    subinterp ; set res [interp eval sub { uplevel #0 {
	if {1} \
	    {
		set ::res \
		    [reduce [info frame 0]];# line 1550
	    }
    }
    return $res
} -cleanup {unset res} -result {type source line 1550 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
    set res }] ; interp delete sub ; set res
} -cleanup {unset res} -result {type source line 1550 file info.test cmd {info frame 0} level 0}

test info-30.14 {bs+nl, literal word, uplevel through proc} {
    proc abra {script} {
    subinterp ; set res [interp eval sub { proc abra {script} {
	uplevel 1 $script
    }
    set res [abra {
	return "\
[reduce [info frame 0]]";# line 1562
    }]
    rename abra {}
    set res
    set res }] ; interp delete sub ; set res
} { type source line 1562 file info.test cmd {info frame 0} proc ::abra}

test info-30.15 {bs+nl in literal words, nested proc body, compiled} {
    proc a {} {
	proc b {} {
	    if {1} \
		{
︙
1874
1875
1876
1877
1878
1879
1880
1881













































































1882
1883
1884
1885
1886
1887

1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964









+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







    trace remove execution print_one enter get_frame_info
    rename get_frame_info {}
    rename test_info_frame {}
    rename print_one {}
} -result {type source line 1854 file info.test cmd print_one proc ::test_info_frame level 1
type source line 1859 file info.test cmd print_one proc ::test_info_frame level 1}

# -------------------------------------------------------------------------
# Tests moved to the end to not disturb other tests and their locations.

test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -setup {subinterp} -body {
    interp eval sub {
	proc etrace {} {
	    set res {}
	    set level [info frame]
	    while {$level} {
		lappend res [list $level [reduce [info frame $level]]]
		incr level -1
	    }
	    return $res
	}
	proc control {vv script} {
	    upvar 1 $vv var
	    return [uplevel 1 $script]
	}
	proc datal {} {
	    control y {
		set y PPL
		etrace
	    }
	}
	join [lrange [datal] 0 4] \n
    }
} -result {* {type source line 1890 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1902 file info.test cmd etrace proc ::control}
* {type source line 1897 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1900 file info.test cmd control proc ::datal level 1}
* {type source line 1905 file info.test cmd datal level 2}} -cleanup {interp delete sub}

test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -setup {subinterp} -body {
    interp eval sub {
	proc etrace {} {
	    set res {}
	    set level [info frame]
	    while {$level} {
		lappend res [list $level [reduce [info frame $level]]]
		incr level -1
	    }
	    return $res
	}
	proc control {vv script} {
	    upvar 1 $vv var
	    return [uplevel 1 $script]
	}
	join [lrange [control y {
	    set y DPL
	    etrace
	}] 0 3] \n
    }
} -result {* {type source line 1919 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1930 file info.test cmd etrace proc ::control}
* {type source line 1926 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1928 file info.test cmd control level 1}} -cleanup {interp delete sub}

test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -setup {subinterp} -body {
    interp eval sub {
	proc etrace {} {
	    set res {}
	    set level [info frame]
	    while {$level} {
		lappend res [list $level [reduce [info frame $level]]]
		incr level -1
	    }
	    return $res
	}
	join [lrange [uplevel \#0 {
	    set y DL.
	    etrace
	}] 0 2] \n
    }
} -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1951 file info.test cmd etrace level 1}
* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub}

# -------------------------------------------------------------------------
unset -nocomplain res

# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return
This page was created in about 0.025s by Fossil version [1205ec86cb] 2025-04-30 16:57:32