diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | generic/tclCompile.c | 33 | ||||
| -rw-r--r-- | generic/tclParse.c | 101 | ||||
| -rw-r--r-- | tests/basic.test | 8 | ||||
| -rw-r--r-- | tests/parse.test | 31 |
5 files changed, 77 insertions, 107 deletions
@@ -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 } |