From 370ba65ed8ff8a13efb636983f14408c92cad57d Mon Sep 17 00:00:00 2001
From: andreas_kupries <akupries@shaw.ca>
Date: Thu, 24 Jul 2008 21:05:12 +0000
Subject: 	* tests/info.test: Tests 38.* added, exactly testing the
 tracking 	of location for uplevel scripts.

---
 ChangeLog       |  5 ++++
 tests/info.test | 87 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 91 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 42a3272..355fdc6 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2008-07-24  Andreas Kupries  <andreask@activestate.com>
+
+	* tests/info.test: Tests 38.* added, exactly testing the tracking
+	of location for uplevel scripts.
+
 2008-07-23  Andreas Kupries  <andreask@activestate.com>
 
 	* generic/tclBasic.c: Modified TclArgumentGet to reject pure lists
diff --git a/tests/info.test b/tests/info.test
index e644158..7675d66 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -13,7 +13,7 @@
 # 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.8 2008/07/23 20:55:11 andreas_kupries Exp $
+# RCS: @(#) $Id: info.test,v 1.24.2.9 2008/07/24 21:05:14 andreas_kupries Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -1099,6 +1099,91 @@ test info-34.0 {eval pure list, single line} tip280 {
 
 # -------------------------------------------------------------------------
 
+# 6 cases.
+## DV. direct-var          - unchanged
+## DPV direct-proc-var     - ditto
+## PPV proc-proc-var       - ditto
+## DL. direct-literal      - now tracking absolute location
+## DPL direct-proc-literal - ditto
+## PPL proc-proc-literal   - ditto
+## ### ### ### ######### ######### #########"
+
+proc control {vv script} {
+    upvar 1 $vv var
+    return [uplevel 1 $script]
+}
+
+proc datal {} {
+    control y {
+	set y PPL
+	etrace
+    }
+}
+
+proc datav {} {
+    set script {
+	set y PPV
+	etrace
+    }
+    control y $script
+}
+
+test info-38.1 {location information for uplevel, dv, direct-var} tip280 {
+    set script {
+	set y DV.
+	etrace
+    }
+    join [lrange [uplevel \#0 $script] 0 2] \n
+} {9 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
+8 {type eval line 3 cmd etrace proc ::tcltest::RunTest}
+7 {type source line 1136 file info.test cmd {uplevel \#0 $script} proc ::tcltest::RunTest}}
+
+test info-38.2 {location information for uplevel, dl, direct-literal} tip280 {
+    join [lrange [uplevel \#0 {
+	set y DL.
+	etrace
+    }] 0 2] \n
+} {9 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
+8 {type source line 1144 file info.test cmd etrace proc ::tcltest::RunTest}
+7 {type source line 1142 file info.test cmd up proc ::tcltest::RunTest}}
+
+test info-38.3 {location information for uplevel, dpv, direct-proc-var} tip280 {
+    set script {
+	set y DPV
+	etrace
+    }
+    join [lrange [control y $script] 0 3] \n
+} {10 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
+9 {type eval line 3 cmd etrace proc ::control}
+8 {type source line 1113 file info.test cmd {uplevel 1 $script} proc ::control}
+7 {type source line 1155 file info.test cmd {control y $script} proc ::tcltest::RunTest}}
+
+test info-38.4 {location information for uplevel, dpv, direct-proc-literal} tip280 {
+    join [lrange [control y {
+	set y DPL
+	etrace
+    }] 0 3] \n
+} {10 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
+9 {type source line 1164 file info.test cmd etrace proc ::control}
+8 {type source line 1113 file info.test cmd {uplevel 1 $script} proc ::control}
+7 {type source line 1162 file info.test cmd control proc ::tcltest::RunTest}}
+
+test info-38.5 {location information for uplevel, ppv, proc-proc-var} tip280 {
+    join [lrange [datav] 0 4] \n
+} {11 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
+10 {type eval line 3 cmd etrace proc ::control}
+9 {type source line 1113 file info.test cmd {uplevel 1 $script} proc ::control}
+8 {type source line 1128 file info.test cmd {control y $script} proc ::datav level 1}
+7 {type source line 1172 file info.test cmd datav proc ::tcltest::RunTest}}
+
+test info-38.6 {location information for uplevel, ppl, proc-proc-literal} tip280 {
+    join [lrange [datal] 0 4] \n
+} {11 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
+10 {type source line 1119 file info.test cmd etrace proc ::control}
+9 {type source line 1113 file info.test cmd {uplevel 1 $script} proc ::control}
+8 {type source line 1117 file info.test cmd control proc ::datal level 1}
+7 {type source line 1180 file info.test cmd datal proc ::tcltest::RunTest}}
+
 # -------------------------------------------------------------------------
 
 # cleanup
-- 
cgit v0.12