summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authorandreas_kupries <akupries@shaw.ca>2006-11-28 22:19:57 (GMT)
committerandreas_kupries <akupries@shaw.ca>2006-11-28 22:19:57 (GMT)
commitbf08959966d3a565773dbddb52b0be2e0747ec3a (patch)
treedfdbbd337f6bf772d6f99a7a6ea50aaaab685d00 /tests
parent78afab8ec5cb163b94f8fed86fb67d9e339d9268 (diff)
downloadtcl-bf08959966d3a565773dbddb52b0be2e0747ec3a.zip
tcl-bf08959966d3a565773dbddb52b0be2e0747ec3a.tar.gz
tcl-bf08959966d3a565773dbddb52b0be2e0747ec3a.tar.bz2
* generic/tclBasic.c: TIP #280 implementation, conditional on the define TCL_TIP280.
* generic/tclCmdAH.c: * generic/tclCmdIL.c: * generic/tclCmdMZ.c: * generic/tclCompCmds.c: * generic/tclCompExpr.c: * generic/tclCompile.c: * generic/tclCompile.h: * generic/tclExecute.c: * generic/tclIOUtil.c: * generic/tclInt.h: * generic/tclInterp.c: * generic/tclNamesp.c: * generic/tclObj.c: * generic/tclProc.c: * tests/compile.test: * tests/info.test: * tests/platform.test: * tests/safe.test:
Diffstat (limited to 'tests')
-rw-r--r--tests/info.test421
-rw-r--r--tests/platform.test1
-rw-r--r--tests/safe.test6
3 files changed, 422 insertions, 6 deletions
diff --git a/tests/info.test b/tests/info.test
index 7a31b27..3c300dc 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -1,3 +1,4 @@
+# -*- tcl -*-
# Commands covered: info
#
# This file contains a collection of tests for one or more of the Tcl
@@ -7,11 +8,12 @@
# Copyright (c) 1991-1994 The Regents of the University of California.
# 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.24.2.4 2005/07/29 14:57:28 dkf Exp $
+# RCS: @(#) $Id: info.test,v 1.24.2.5 2006/11/28 22:20:02 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -29,6 +31,9 @@ namespace eval test_ns_info1 {
proc q {{y 27} {z {}}} {return "y=$y"}
}
+testConstraint tip280 [info exists tcl_platform(tip,280)]
+testConstraint !tip280 [expr {![info exists tcl_platform(tip,280)]}]
+
test info-1.1 {info args option} {
proc t1 {a bbb c} {return foo}
@@ -651,18 +656,424 @@ test info-20.5 {info functions option} {
test info-21.1 {miscellaneous error conditions} {
list [catch {info} msg] $msg
} {1 {wrong # args: should be "info option ?arg arg ...?"}}
-test info-21.2 {miscellaneous error conditions} {
+test info-21.2 {miscellaneous error conditions} !tip280 {
list [catch {info gorp} msg] $msg
} {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}}
-test info-21.3 {miscellaneous error conditions} {
+test info-21.2-280 {miscellaneous error conditions} tip280 {
+ list [catch {info gorp} msg] $msg
+} {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}}
+test info-21.3 {miscellaneous error conditions} !tip280 {
list [catch {info c} msg] $msg
} {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}}
-test info-21.4 {miscellaneous error conditions} {
+test info-21.3-280 {miscellaneous error conditions} tip280 {
+ list [catch {info c} msg] $msg
+} {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}}
+test info-21.4 {miscellaneous error conditions} !tip280 {
list [catch {info l} msg] $msg
} {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}}
-test info-21.5 {miscellaneous error conditions} {
+test info-21.4-280 {miscellaneous error conditions} tip280 {
+ list [catch {info l} msg] $msg
+} {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}}
+test info-21.5 {miscellaneous error conditions} !tip280 {
list [catch {info s} msg] $msg
} {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}}
+test info-21.5-280 {miscellaneous error conditions} tip280 {
+ list [catch {info s} msg] $msg
+} {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}}
+
+##
+# ### ### ### ######### ######### #########
+## 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-11]
+ 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
+}
+
+## 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 {} {
+ set res {}
+ set level [info frame]
+ while {$level} {
+ lappend res [list $level [reduce [info frame $level]]]
+ incr level -1
+ }
+ return $res
+}
+
+##
+
+test info-22.0 {info frame, levels} tip280 {
+ info frame
+} 7
+
+test info-22.1 {info frame, bad level relative} tip280 {
+ # catch is another level!, i.e. we have 8, not 7
+ catch {info frame -8} msg
+ set msg
+} {bad level "-8"}
+
+test info-22.2 {info frame, bad level absolute} tip280 {
+ # catch is another level!, i.e. we have 8, not 7
+ catch {info frame 9} msg
+ set msg
+} {bad level "9"}
+
+test info-22.3 {info frame, current, relative} tip280 {
+ info frame 0
+} {type eval line 2 cmd {info frame 0}}
+
+test info-22.4 {info frame, current, relative, nested} tip280 {
+ set res [info frame 0]
+} {type eval line 2 cmd {info frame 0}}
+
+test info-22.5 {info frame, current, absolute} tip280 {
+ reduce [info frame 7]
+} {type eval line 2 cmd {info frame 7}}
+
+test info-22.6 {info frame, global, relative} tip280 {
+ reduce [info frame -6]
+} {type source line 759 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relativ}
+
+test info-22.7 {info frame, global, absolute} tip280 {
+ reduce [info frame 1]
+} {type source line 763 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolut}
+
+test info-22.8 {info frame, basic trace} tip280 {
+ join [etrace] \n
+} {8 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
+7 {type eval line 2 cmd etrace}
+6 {type source line 2277 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest}
+5 {type eval line 1 cmd {::tcltest::RunTest }}
+4 {type source line 1619 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval}
+3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ }
+2 {type source line 1966 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test}
+1 {type source line 767 file info.test cmd test\ info-22.8\ \{info\ frame,\ basic\ trac}}
+## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0
+test info-23.0 {eval'd info frame} tip280 {
+ eval {info frame}
+} 8
+
+test info-23.1 {eval'd info frame, semi-dynamic} tip280 {
+ eval info frame
+} 8
+
+test info-23.2 {eval'd info frame, dynamic} tip280 {
+ set script {info frame}
+ eval $script
+} 8
+
+test info-23.3 {eval'd info frame, literal} tip280 {
+ eval {
+ info frame 0
+ }
+} {type eval line 2 cmd {info frame 0}}
+
+test info-23.4 {eval'd info frame, semi-dynamic} tip280 {
+ eval info frame 0
+} {type eval line 1 cmd {info frame 0}}
+
+test info-23.5 {eval'd info frame, dynamic} tip280 {
+ set script {info frame 0}
+ eval $script
+} {type eval line 1 cmd {info frame 0}}
+
+test info-23.6 {eval'd info frame, trace} tip280 {
+ set script {etrace}
+ join [eval $script] \n
+} {9 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
+8 {type eval line 1 cmd etrace}
+7 {type eval line 3 cmd {eval $script}}
+6 {type source line 2277 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest}
+5 {type eval line 1 cmd {::tcltest::RunTest }}
+4 {type source line 1619 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval}
+3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ }
+2 {type source line 1966 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test}
+1 {type source line 806 file info.test cmd test\ info-23.6\ \{eval'd\ info\ frame,\ trac}}
+## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0
+# -------------------------------------------------------------------------
+
+# Procedures defined in scripts which are arguments to control
+# structures (like 'namespace eval', 'interp eval', 'if', 'while',
+# 'switch', 'catch', 'for', 'foreach', etc.) have no absolute
+# location. The command implementations execute such scripts through
+# Tcl_EvalObjEx. Flag 0 causes it to use the bytecode compiler. This
+# causes the connection to the context to be lost. Currently only
+# procedure bodies are able to remember their context.
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {
+ proc bar {} {info frame 0}
+}
+
+test info-24.0 {info frame, interaction, namespace eval} tip280 {
+ reduce [foo::bar]
+} {type source line 832 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+set flag 1
+if {$flag} {
+ namespace eval foo {}
+ proc ::foo::bar {} {info frame 0}
+}
+
+test info-24.1 {info frame, interaction, if} tip280 {
+ reduce [foo::bar]
+} {type source line 846 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+set flag 1
+while {$flag} {
+ namespace eval foo {}
+ proc ::foo::bar {} {info frame 0}
+ set flag 0
+}
+
+test info-24.2 {info frame, interaction, while} tip280 {
+ reduce [foo::bar]
+} {type source line 860 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+catch {
+ namespace eval foo {}
+ proc ::foo::bar {} {info frame 0}
+}
+
+test info-24.3 {info frame, interaction, catch} tip280 {
+ reduce [foo::bar]
+} {type source line 874 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+foreach var val {
+ namespace eval foo {}
+ proc ::foo::bar {} {info frame 0}
+ break
+}
+
+test info-24.4 {info frame, interaction, foreach} tip280 {
+ reduce [foo::bar]
+} {type source line 887 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+for {} {1} {} {
+ namespace eval foo {}
+ proc ::foo::bar {} {info frame 0}
+ break
+}
+
+test info-24.5 {info frame, interaction, for} tip280 {
+ reduce [foo::bar]
+} {type source line 901 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
+
+eval {
+ proc bar {} {info frame 0}
+}
+
+test info-25.0 {info frame, proc in eval} tip280 {
+ reduce [bar]
+} {type source line 914 file info.test cmd {info frame 0} proc ::bar level 0}
+
+proc bar {} {info frame 0}
+test info-25.1 {info frame, regular proc} tip280 {
+ reduce [bar]
+} {type source line 921 file info.test cmd {info frame 0} proc ::bar level 0}
+rename bar {}
+
+
+
+test info-30.0 {bs+nl in literal words} {tip280 knownBug} {
+ if {1} {
+ set res \
+ [reduce [info frame 0]]
+ }
+ set res
+ # This is reporting line 3 instead of the correct 4 because the
+ # bs+nl combination is subst by the parser before the 'if'
+ # command, and the the bcc sees the word. To fix record the
+ # offsets of all bs+nl sequences in literal words, then use the
+ # information in the bcc to bump line numbers when parsing over
+ # the location. Also affected: testcases 22.8 and 23.6.
+} {type eval line 4 cmd {info frame 0} proc ::tcltest::RunTest}
+
+
+
+# -------------------------------------------------------------------------
+# See 24.0 - 24.5 for similar situations, using literal scripts.
+
+set body {set flag 0
+ set a c
+ set res [info frame 0]} ;# line 3!
+
+test info-31.0 {ns eval, script in variable} tip280 {
+ namespace eval foo $body
+ set res
+} {type eval line 3 cmd {info frame 0} level 0}
+catch {namespace delete foo}
+
+
+test info-31.1 {if, script in variable} tip280 {
+ if 1 $body
+ set res
+} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
+
+test info-31.1a {if, script in variable} tip280 {
+ if 1 then $body
+ set res
+} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
+
+
+
+test info-31.2 {while, script in variable} tip280 {
+ set flag 1
+ while {$flag} $body
+ set res
+} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
+
+# .3 - proc - scoping prevent return of result ...
+
+test info-31.4 {foreach, script in variable} tip280 {
+ foreach var val $body
+ set res
+} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
+
+test info-31.5 {for, script in variable} tip280 {
+ set flag 1
+ for {} {$flag} {} $body
+ set res
+} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
+
+test info-31.6 {eval, script in variable} tip280 {
+ eval $body
+ set res
+} {type eval line 3 cmd {info frame 0}}
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {}
+set x foo
+switch -exact -- $x {
+ foo {
+ proc ::foo::bar {} {info frame 0}
+ }
+}
+
+test info-24.6.0 {info frame, interaction, switch, list body} tip280 {
+ reduce [foo::bar]
+} {type source line 1001 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+unset x
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {}
+set x foo
+switch -exact -- $x foo {
+ proc ::foo::bar {} {info frame 0}
+}
+
+test info-24.6.1 {info frame, interaction, switch, multi-body} tip280 {
+ reduce [foo::bar]
+} {type source line 1017 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+unset x
+
+# -------------------------------------------------------------------------
+
+namespace eval foo {}
+set x foo
+switch -exact -- $x [list foo {
+ proc ::foo::bar {} {info frame 0}
+}]
+
+test info-24.6.2 {info frame, interaction, switch, list body, dynamic} tip280 {
+ reduce [foo::bar]
+} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+unset x
+
+# -------------------------------------------------------------------------
+
+set body {
+ foo {
+ proc ::foo::bar {} {info frame 0}
+ }
+}
+
+namespace eval foo {}
+set x foo
+switch -exact -- $x $body
+
+test info-31.7 {info frame, interaction, switch, dynamic} tip280 {
+ reduce [foo::bar]
+} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+unset x
+
+# -------------------------------------------------------------------------
+
+set body {
+ proc ::foo::bar {} {info frame 0}
+}
+
+namespace eval foo {}
+eval $body
+
+test info-32.0 {info frame, dynamic procedure} tip280 {
+ reduce [foo::bar]
+} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
+
+namespace delete foo
+
+# -------------------------------------------------------------------------
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
diff --git a/tests/platform.test b/tests/platform.test
index 01bf787..ce72211 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -23,6 +23,7 @@ test platform-1.1 {TclpSetVariables: tcl_platform} {
i eval {catch {unset tcl_platform(debug)}}
i eval {catch {unset tcl_platform(threaded)}}
i eval {catch {unset tcl_platform(tip,268)}}
+ i eval {catch {unset tcl_platform(tip,280)}}
set result [i eval {lsort [array names tcl_platform]}]
interp delete i
set result
diff --git a/tests/safe.test b/tests/safe.test
index 15dfa85..938e247 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: safe.test,v 1.13.2.2 2006/09/22 01:26:24 andreas_kupries Exp $
+# RCS: @(#) $Id: safe.test,v 1.13.2.3 2006/11/28 22:20:03 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -191,6 +191,10 @@ test safe-6.3 {test safe interpreters knowledge of the world} {
if {$tip != -1} {
set r [lreplace $r $tip $tip]
}
+ set tip [lsearch $r "tip,280"]
+ if {$tip != -1} {
+ set r [lreplace $r $tip $tip]
+ }
set r
} {byteOrder platform wordSize}