summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2009-09-17 17:58:09 (GMT)
committerdgp <dgp@users.sourceforge.net>2009-09-17 17:58:09 (GMT)
commit76a7b7436a2b6d136bd796fbc2dd53cd3f4385dc (patch)
treec8705818cc28b4867edbb3dd5e99ea4b1f2ae264
parentcfef008bffcfc7b272e5fd62ff6f62f333e0c4d3 (diff)
downloadtcl-76a7b7436a2b6d136bd796fbc2dd53cd3f4385dc.zip
tcl-76a7b7436a2b6d136bd796fbc2dd53cd3f4385dc.tar.gz
tcl-76a7b7436a2b6d136bd796fbc2dd53cd3f4385dc.tar.bz2
* generic/tclCompile.c: Re-implement Tcl_SubstObj() as a simple
* generic/tclParse.c: wrapper around TclNRSubstObj(). This has * tests/basic.test: the effect of caching compiled bytecode in * tests/parse.test: the value to be substituted. Note that Tcl_SubstObj() now exists only for extensions. Tcl itself no longer makes any use of it. Note also that TclSubstTokens() is now reachable only by Tcl_EvalEx() and Tcl_ParseVar() so tests aiming to test its functioning needed adjustment to still have the intended effect.
-rw-r--r--ChangeLog11
-rw-r--r--generic/tclCompile.c33
-rw-r--r--generic/tclParse.c101
-rw-r--r--tests/basic.test8
-rw-r--r--tests/parse.test31
5 files changed, 77 insertions, 107 deletions
diff --git a/ChangeLog b/ChangeLog
index af6e767..363e1a1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2009-09-17 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclCompile.c: Re-implement Tcl_SubstObj() as a simple
+ * generic/tclParse.c: wrapper around TclNRSubstObj(). This has
+ * tests/basic.test: the effect of caching compiled bytecode in
+ * tests/parse.test: the value to be substituted. Note that
+ Tcl_SubstObj() now exists only for extensions. Tcl itself no longer
+ makes any use of it. Note also that TclSubstTokens() is now reachable
+ only by Tcl_EvalEx() and Tcl_ParseVar() so tests aiming to test its
+ functioning needed adjustment to still have the intended effect.
+
2009-09-16 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
* generic/tclObj.c: Extended ::tcl::unsupported::representation.
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 9fa8f6a..36e24d2 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.c,v 1.175 2009/09/12 06:43:12 das Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.176 2009/09/17 17:58:10 dgp Exp $
*/
#include "tclInt.h"
@@ -875,6 +875,37 @@ TclCleanupByteCode(
/*
*----------------------------------------------------------------------
*
+ * Tcl_SubstObj --
+ *
+ * This function performs the substitutions specified on the given string
+ * as described in the user documentation for the "subst" Tcl command.
+ *
+ * Results:
+ * A Tcl_Obj* containing the substituted string, or NULL to indicate that
+ * an error occurred.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_SubstObj(
+ Tcl_Interp *interp, /* Interpreter in which substitution occurs */
+ Tcl_Obj *objPtr, /* The value to be substituted. */
+ int flags) /* What substitutions to do. */
+{
+ if (TclNRRunCallbacks(interp, TclNRSubstObj(interp, objPtr, flags),
+ TOP_CB(interp), 0) != TCL_OK) {
+ return NULL;
+ }
+ return Tcl_GetObjResult(interp);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclNRSubstObj --
*
* Request substitution of a Tcl value by the NR stack.
diff --git a/generic/tclParse.c b/generic/tclParse.c
index 939c5d1..b06b106 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -1865,17 +1865,26 @@ Tcl_ParseQuotedString(
/*
*----------------------------------------------------------------------
*
- * Tcl_SubstObj --
- *
- * This function performs the substitutions specified on the given string
- * as described in the user documentation for the "subst" Tcl command.
- *
+ * TclSubstParse --
+ *
+ * Token parser used by the [subst] command. Parses the string made
+ * up of 'numBytes' bytes starting at 'bytes'. Parsing is controlled
+ * by the flags argument to provide support for the -nobackslashes,
+ * -nocommands, and -novariables options, as represented by the flag
+ * values TCL_SUBST_BACKSLASHES, TCL_SUBST_COMMANDS, TCL_SUBST_VARIABLES.
+ *
* Results:
- * A Tcl_Obj* containing the substituted string, or NULL to indicate that
- * an error occurred.
+ * None.
*
* Side effects:
- * See the user documentation.
+ * The Tcl_Parse struct '*parsePtr' is filled with parse results.
+ * The caller is expected to eventually call Tcl_FreeParse() to
+ * properly cleanup the value written there.
+ * If a parse error occurs, the Tcl_InterpState value '*statePtr'
+ * is filled with the state created by that error. When *statePtr
+ * is written to, the caller is expected to make the required calls
+ * to either Tcl_RestoreInterpState() or Tcl_DiscardInterpState()
+ * to dispose of the value written there.
*
*----------------------------------------------------------------------
*/
@@ -1972,10 +1981,10 @@ TclSubstParse(
parsePtr->tokenPtr + parsePtr->numTokens - 2;
if (varTokenPtr->type != TCL_TOKEN_VARIABLE) {
- Tcl_Panic("Tcl_SubstObj: programming error");
+ Tcl_Panic("TclSubstParse: programming error");
}
if (varTokenPtr[1].type != TCL_TOKEN_TEXT) {
- Tcl_Panic("Tcl_SubstObj: programming error");
+ Tcl_Panic("TclSubstParse: programming error");
}
parsePtr->numTokens -= 2;
}
@@ -2049,78 +2058,8 @@ TclSubstParse(
break;
default:
- Tcl_Panic("bad parse in Tcl_SubstObj: %c", p[length]);
- }
- }
-}
-
-Tcl_Obj *
-Tcl_SubstObj(
- Tcl_Interp *interp, /* Interpreter in which substitution occurs */
- Tcl_Obj *objPtr, /* The value to be substituted. */
- int flags) /* What substitutions to do. */
-{
- int tokensLeft, code, numBytes;
- Tcl_Token *endTokenPtr;
- Tcl_Obj *result;
- Tcl_Parse *parsePtr = (Tcl_Parse *)
- TclStackAlloc(interp, sizeof(Tcl_Parse));
- Tcl_InterpState state = NULL;
- const char *bytes = TclGetStringFromObj(objPtr, &numBytes);
-
- TclSubstParse(interp, bytes, numBytes, flags, parsePtr, &state);
-
- /*
- * Next, substitute the parsed tokens just as in normal Tcl evaluation.
- */
-
- endTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
- tokensLeft = parsePtr->numTokens;
- code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft,
- &tokensLeft, 1, NULL, NULL);
- if (code == TCL_OK) {
- Tcl_FreeParse(parsePtr);
- TclStackFree(interp, parsePtr);
- if (state != NULL) {
- Tcl_RestoreInterpState(interp, state);
- return NULL;
- }
- return Tcl_GetObjResult(interp);
- }
-
- result = Tcl_NewObj();
- while (1) {
- switch (code) {
- case TCL_ERROR:
- Tcl_FreeParse(parsePtr);
- TclStackFree(interp, parsePtr);
- Tcl_DecrRefCount(result);
- if (state != NULL) {
- Tcl_DiscardInterpState(state);
- }
- return NULL;
- case TCL_BREAK:
- tokensLeft = 0; /* Halt substitution */
- default:
- Tcl_AppendObjToObj(result, Tcl_GetObjResult(interp));
+ Tcl_Panic("bad parse in TclSubstParse: %c", p[length]);
}
-
- if (tokensLeft == 0) {
- Tcl_FreeParse(parsePtr);
- TclStackFree(interp, parsePtr);
- if (state != NULL) {
- if (code != TCL_BREAK) {
- Tcl_DecrRefCount(result);
- Tcl_RestoreInterpState(interp, state);
- return NULL;
- }
- Tcl_DiscardInterpState(state);
- }
- return result;
- }
-
- code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft,
- &tokensLeft, 1, NULL, NULL);
}
}
diff --git a/tests/basic.test b/tests/basic.test
index 881b329..c07d805 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -15,7 +15,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: basic.test,v 1.45 2009/09/04 17:33:12 dgp Exp $
+# RCS: @(#) $Id: basic.test,v 1.46 2009/09/17 17:58:10 dgp Exp $
#
package require tcltest 2
@@ -631,8 +631,10 @@ test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} -setup {
"return -code return"
(file "*BREAKtest" line 2)}
-test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -body {
- set subst subst; $subst {a[set b [format cd]}
+test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -constraints {
+ testevalex
+} -body {
+ testevalex {a[set b [format cd]}
} -returnCodes error -result {missing close-bracket}
# Some lists for expansion tests to work with
diff --git a/tests/parse.test b/tests/parse.test
index 482c3b8..b83d20e 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -8,7 +8,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: parse.test,v 1.38 2009/09/11 20:13:27 dgp Exp $
+# RCS: @(#) $Id: parse.test,v 1.39 2009/09/17 17:58:10 dgp Exp $
if {[catch {package require tcltest 2.0.2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
@@ -895,8 +895,8 @@ test parse-15.60 {CommandComplete procedure} {
info complete \\\n
} 0
-test parse-16.1 {Tcl_EvalEx, check termOffset is set correctly for non TCL_OK cases, bug 2535} {
- set subst subst; $subst {[eval {return foo}]bar}
+test parse-16.1 {Bug 218885 (Scriptics bug 2535)} {
+ subst {[eval {return foo}]bar}
} foobar
test parse-17.1 {Correct return codes from errors during substitution} {
@@ -1038,25 +1038,12 @@ test parse-19.2 {Bug 1115904: recursion limit in Tcl_EvalEx} -constraints {
interp delete i
} -returnCodes error -match glob -result {too many nested*}
-test parse-19.3 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup {
- interp create i
- i eval {proc {} args {}}
- interp recursionlimit i 3
-} -body {
- i eval {set subst subst; $subst {[]}}
-} -cleanup {
- interp delete i
-}
-
-test parse-19.4 {Bug 1115904: recursion limit in Tcl_EvalEx} -constraints knownBug -setup {
- interp create i
- i eval {proc {} args {}}
- interp recursionlimit i 2
-} -body {
- i eval {set subst subst; $subst {[[]]}}
-} -cleanup {
- interp delete i
-} -returnCodes error -match glob -result {too many nested*}
+test parse-19.3 {Bug 1115904: recursion limit in Tcl_EvalEx} emptyTest {
+ # Test no longer valid in Tcl 8.6
+} {}
+test parse-19.4 {Bug 1115904: recursion limit in Tcl_EvalEx} emptyTest {
+ # Test no longer valid in Tcl 8.6
+} {}
cleanupTests
}