diff options
author | dgp <dgp@users.sourceforge.net> | 2003-11-14 20:44:43 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2003-11-14 20:44:43 (GMT) |
commit | 17f540b256d78b8a6fc8bd9121a633dac6c23b19 (patch) | |
tree | 1abdc7a020d4095171e8cb7f16def9be025cb664 | |
parent | f745c9aa31bbdf8f71589fa25d30ce50cad94652 (diff) | |
download | tcl-17f540b256d78b8a6fc8bd9121a633dac6c23b19.zip tcl-17f540b256d78b8a6fc8bd9121a633dac6c23b19.tar.gz tcl-17f540b256d78b8a6fc8bd9121a633dac6c23b19.tar.bz2 |
* doc/ParseCmd.3: Implementation of TIP 157. Adds recognition
* doc/Tcl.n: of the new leading {expand} syntax on words.
* generic/tcl.h: Parses such words as the new Tcl_Token type
* generic/tclBasic.c: TCL_TOKEN_EXPAND_WORD. Updated Tcl_EvalEx
* generic/tclCompile.c: and the bytecode compiler/execution engine
* generic/tclCompile.h: to recognize the new token type. New opcodes
* generic/tclExecute.c: INST_LIST_VERIFY and INST_INVOKE_EXP and a new
* generic/tclParse.c: operand type OPERAND_ULIST1 are defined. Docs
* generic/tclTest.c: and tests are included.
* tests/basic.test:
* tests/compile.test:
* tests/parse.test:
* library/auto.tcl: Replaced several [eval]s used to perform
* library/package.tcl: argument expansion with the new syntax.
* library/safe.tcl: In the test files lindex.test and lset.test,
* tests/cmdInfo.test: replaced use of [eval] to force direct
* tests/encoding.test: string evaluation with use of [testevalex]
* tests/execute.test: which more directly and robustly serves the
* tests/fCmd.test: same purpose.
* tests/http.test:
* tests/init.test:
* tests/interp.test:
* tests/io.test:
* tests/ioUtil.test:
* tests/iogt.test:
* tests/lindex.test:
* tests/lset.test:
* tests/namespace-old.test:
* tests/namespace.test:
* tests/pkg.test:
* tests/pkgMkIndex.test:
* tests/proc.test:
* tests/reg.test:
* tests/trace.test:
* tests/upvar.test:
* tests/winConsole.test:
* tests/winFCmd.test:
38 files changed, 1540 insertions, 641 deletions
@@ -1,3 +1,44 @@ +2003-11-14 Don Porter <dgp@users.sourceforge.net> + + * doc/ParseCmd.3: Implementation of TIP 157. Adds recognition + * doc/Tcl.n: of the new leading {expand} syntax on words. + * generic/tcl.h: Parses such words as the new Tcl_Token type + * generic/tclBasic.c: TCL_TOKEN_EXPAND_WORD. Updated Tcl_EvalEx + * generic/tclCompile.c: and the bytecode compiler/execution engine + * generic/tclCompile.h: to recognize the new token type. New opcodes + * generic/tclExecute.c: INST_LIST_VERIFY and INST_INVOKE_EXP and a new + * generic/tclParse.c: operand type OPERAND_ULIST1 are defined. Docs + * generic/tclTest.c: and tests are included. + * tests/basic.test: + * tests/compile.test: + * tests/parse.test: + + * library/auto.tcl: Replaced several [eval]s used to perform + * library/package.tcl: argument expansion with the new syntax. + * library/safe.tcl: In the test files lindex.test and lset.test, + * tests/cmdInfo.test: replaced use of [eval] to force direct + * tests/encoding.test: string evaluation with use of [testevalex] + * tests/execute.test: which more directly and robustly serves the + * tests/fCmd.test: same purpose. + * tests/http.test: + * tests/init.test: + * tests/interp.test: + * tests/io.test: + * tests/ioUtil.test: + * tests/iogt.test: + * tests/lindex.test: + * tests/lset.test: + * tests/namespace-old.test: + * tests/namespace.test: + * tests/pkg.test: + * tests/pkgMkIndex.test: + * tests/proc.test: + * tests/reg.test: + * tests/trace.test: + * tests/upvar.test: + * tests/winConsole.test: + * tests/winFCmd.test: + 2003-11-12 Jeff Hobbs <jeffh@ActiveState.com> * tests/cmdMZ.test (cmdMZ-1.4): change to nonPortable as more diff --git a/doc/ParseCmd.3 b/doc/ParseCmd.3 index 34826d9..aa243d2 100644 --- a/doc/ParseCmd.3 +++ b/doc/ParseCmd.3 @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: ParseCmd.3,v 1.11 2003/03/19 20:07:17 dgp Exp $ +'\" RCS: @(#) $Id: ParseCmd.3,v 1.12 2003/11/14 20:44:43 dgp Exp $ '\" .so man.macros .TH Tcl_ParseCommand 3 8.3 Tcl "Tcl Library Procedures" @@ -286,6 +286,16 @@ of \fBTCL_TOKEN_VARIABLE\fR and \fBTCL_TOKEN_BS\fR tokens. This token has the same meaning as \fBTCL_TOKEN_WORD\fR, except that the word is guaranteed to consist of a single \fBTCL_TOKEN_TEXT\fR sub-token. The \fInumComponents\fR field is always 1. +.VS 8.5 +.TP +\fBTCL_TOKEN_EXPAND_WORD\fR +This token has the same meaning as \fBTCL_TOKEN_WORD\fR, except that +the command parser notes this word began with the expansion +prefix \fB{expand}\fR, indicating that after substitution, +the list value of this word should be expanded to form multiple +arguments in command evaluation. This +token type can only be created by Tcl_ParseCommand. +.VE .TP \fBTCL_TOKEN_TEXT\fR The token describes a range of literal text that is part of a word. @@ -375,12 +385,16 @@ is always 0. After \fBTcl_ParseCommand\fR returns, the first token pointed to by the \fItokenPtr\fR field of the Tcl_Parse structure always has type \fBTCL_TOKEN_WORD\fR or -\fBTCL_TOKEN_SIMPLE_WORD\fR. It is followed by the sub-tokens +.VS 8.5 +\fBTCL_TOKEN_SIMPLE_WORD\fR or \fBTCL_TOKEN_EXPAND_WORD\fR. +It is followed by the sub-tokens that must be concatenated to produce the value of that word. The next token is the \fBTCL_TOKEN_WORD\fR or \fBTCL_TOKEN_SIMPLE_WORD\fR -token for the second word, followed by sub-tokens for that +of \fBTCL_TOKEN_EXPAND_WORD\fR token for the second word, +followed by sub-tokens for that word, and so on until all \fInumWords\fR have been accounted for. +.VE 8.5 .PP After \fBTcl_ParseExpr\fR returns, the first token pointed to by the \fItokenPtr\fR field of the @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Tcl.n,v 1.9 2003/02/01 19:48:23 kennykb Exp $ +'\" RCS: @(#) $Id: Tcl.n,v 1.10 2003/11/14 20:44:43 dgp Exp $ '\" .so man.macros .TH Tcl n "8.1" Tcl "Tcl Built-In Commands" @@ -49,8 +49,17 @@ as ordinary characters and included in the word. Command substitution, variable substitution, and backslash substitution are performed on the characters between the quotes as described below. The double-quotes are not retained as part of the word. -.IP "[5] \fBBraces.\fR" -If the first character of a word is an open brace (``{'') then +.IP "[5] \fBArgument expansion.\fR" +If a word starts with the string ``{expand}'' followed by a +non-whitespace character, then the leading ``{expand}'' is removed +and the rest of the word is parsed and substituted as any other other +word. After substitution, the word is parsed again without +substitutions, and its words are added to the command being +substituted. For instance, ``cmd a {expand}{b c} d {expand}{e f}'' is +equivalent to ``cmd a b c d e f''. +.IP "[6] \fBBraces.\fR" +If the first character of a word is an open brace (``{'') and +rule [5] does not apply, then the word is terminated by the matching close brace (``}''). Braces nest within the word: for each additional open brace there must be an additional close brace (however, @@ -63,7 +72,7 @@ below, nor do semi-colons, newlines, close brackets, or white space receive any special interpretation. The word will consist of exactly the characters between the outer braces, not including the braces themselves. -.IP "[6] \fBCommand substitution.\fR" +.IP "[7] \fBCommand substitution.\fR" If a word contains an open bracket (``['') then Tcl performs \fIcommand substitution\fR. To do this it invokes the Tcl interpreter recursively to process @@ -75,7 +84,7 @@ substituted into the word in place of the brackets and all of the characters between them. There may be any number of command substitutions in a single word. Command substitution is not performed on words enclosed in braces. -.IP "[7] \fBVariable substitution.\fR" +.IP "[8] \fBVariable substitution.\fR" If a word contains a dollar-sign (``$'') then Tcl performs \fIvariable substitution\fR: the dollar-sign and the following characters are replaced in the word by the value of a variable. @@ -102,7 +111,7 @@ characters whatsoever except for close braces. There may be any number of variable substitutions in a single word. Variable substitution is not performed on words enclosed in braces. .RE -.IP "[8] \fBBackslash substitution.\fR" +.IP "[9] \fBBackslash substitution.\fR" If a backslash (``\e'') appears within a word then \fIbackslash substitution\fR occurs. In all cases but those described below the backslash is dropped and @@ -173,14 +182,14 @@ inserted. Backslash substitution is not performed on words enclosed in braces, except for backslash-newline as described above. .RE -.IP "[9] \fBComments.\fR" +.IP "[10] \fBComments.\fR" If a hash character (``#'') appears at a point where Tcl is expecting the first character of the first word of a command, then the hash character and the characters that follow it, up through the next newline, are treated as a comment and ignored. The comment character only has significance when it appears at the beginning of a command. -.IP "[10] \fBOrder of substitution.\fR" +.IP "[11] \fBOrder of substitution.\fR" Each character is processed exactly once by the Tcl interpreter as part of creating the words of a command. For example, if variable substitution occurs then no further @@ -201,8 +210,9 @@ set y [set x 0][incr x][incr x] .CE will always set the variable \fIy\fR to the value, \fI012\fR. .RE -.IP "[11] \fBSubstitution and word boundaries.\fR" -Substitutions do not affect the word boundaries of a command. +.IP "[12] \fBSubstitution and word boundaries.\fR" +Substitutions do not affect the word boundaries of a command, +except for argument expansion as specified in rule [5]. For example, during variable substitution the entire value of the variable becomes part of a single word, even if the variable's value contains spaces. diff --git a/generic/tcl.h b/generic/tcl.h index e89690d..7a9a7dd 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -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: tcl.h,v 1.166 2003/10/13 16:48:06 vincentdarley Exp $ + * RCS: @(#) $Id: tcl.h,v 1.167 2003/11/14 20:44:44 dgp Exp $ */ #ifndef _TCL @@ -2078,6 +2078,7 @@ typedef struct Tcl_Token { #define TCL_TOKEN_VARIABLE 32 #define TCL_TOKEN_SUB_EXPR 64 #define TCL_TOKEN_OPERATOR 128 +#define TCL_TOKEN_EXPAND_WORD 256 /* * Parsing error types. On any parsing error, one of these values diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 7f89d7e..ec4bb19 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -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: tclBasic.c,v 1.92 2003/10/14 15:44:52 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.93 2003/11/14 20:44:44 dgp Exp $ */ #include "tclInt.h" @@ -3499,9 +3499,10 @@ Tcl_EvalEx(interp, script, numBytes, flags) CONST char *p, *next; Tcl_Parse parse; #define NUM_STATIC_OBJS 20 - Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv; + Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv, **objvSpace; + int expandStatic[NUM_STATIC_OBJS], *expand; Tcl_Token *tokenPtr; - int i, code, commandLength, bytesLeft; + int i, code, commandLength, bytesLeft, expandRequested; CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr * in case TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); @@ -3529,7 +3530,8 @@ Tcl_EvalEx(interp, script, numBytes, flags) * command from the script and then executes it. */ - objv = staticObjArray; + objv = objvSpace = staticObjArray; + expand = expandStatic; p = script; bytesLeft = numBytes; iPtr->evalFlags = 0; @@ -3544,24 +3546,88 @@ Tcl_EvalEx(interp, script, numBytes, flags) /* * Generate an array of objects for the words of the command. */ + int objectsNeeded = 0; - if (parse.numWords <= NUM_STATIC_OBJS) { - objv = staticObjArray; - } else { - objv = (Tcl_Obj **) ckalloc((unsigned) + if (parse.numWords > NUM_STATIC_OBJS) { + expand = (int *) ckalloc((unsigned) + (parse.numWords * sizeof (int))); + objvSpace = (Tcl_Obj **) ckalloc((unsigned) (parse.numWords * sizeof (Tcl_Obj *))); } + expandRequested = 0; + objv = objvSpace; for (objectsUsed = 0, tokenPtr = parse.tokenPtr; objectsUsed < parse.numWords; objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { code = TclSubstTokens(interp, tokenPtr+1, tokenPtr->numComponents, NULL); - if (code == TCL_OK) { - objv[objectsUsed] = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(objv[objectsUsed]); - } else { + if (code != TCL_OK) { goto error; } + objv[objectsUsed] = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(objv[objectsUsed]); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + int numElements; + + code = Tcl_ListObjLength(interp, + objv[objectsUsed], &numElements); + if (code == TCL_ERROR) { + /* Attempt to expand a non-list */ + Tcl_Obj *msg = + Tcl_NewStringObj("\n (expanding word ", -1); + Tcl_Obj *wordNum = Tcl_NewIntObj(objectsUsed); + Tcl_IncrRefCount(wordNum); + Tcl_IncrRefCount(msg); + Tcl_AppendObjToObj(msg, wordNum); + Tcl_DecrRefCount(wordNum); + Tcl_AppendToObj(msg, ")", -1); + TclAppendObjToErrorInfo(interp, msg); + Tcl_DecrRefCount(msg); + goto error; + } + expandRequested = 1; + expand[objectsUsed] = 1; + objectsNeeded += (numElements ? numElements : 1); + } else { + expand[objectsUsed] = 0; + objectsNeeded++; + } + } + if (expandRequested) { + /* Some word expansion was requested. Check for objv resize */ + Tcl_Obj **copy = objvSpace; + int wordIdx = parse.numWords; + int objIdx = objectsNeeded - 1; + + if ((parse.numWords > NUM_STATIC_OBJS) + || (objectsNeeded > NUM_STATIC_OBJS)) { + objv = objvSpace = (Tcl_Obj **) ckalloc((unsigned) + (objectsNeeded * sizeof (Tcl_Obj *))); + } + + objectsUsed = 0; + while (wordIdx--) { + if (expand[wordIdx]) { + int numElements; + Tcl_Obj **elements, *temp = copy[wordIdx]; + Tcl_ListObjGetElements(NULL, temp, + &numElements, &elements); + objectsUsed += numElements; + while (numElements--) { + objv[objIdx--] = elements[numElements]; + Tcl_IncrRefCount(elements[numElements]); + } + Tcl_DecrRefCount(temp); + } else { + objv[objIdx--] = copy[wordIdx]; + objectsUsed++; + } + } + objv += objIdx+1; + + if (copy != staticObjArray) { + ckfree((char *) copy); + } } /* @@ -3589,9 +3655,17 @@ Tcl_EvalEx(interp, script, numBytes, flags) Tcl_DecrRefCount(objv[i]); } objectsUsed = 0; - if (objv != staticObjArray) { - ckfree((char *) objv); - objv = staticObjArray; + if (objvSpace != staticObjArray) { + ckfree((char *) objvSpace); + objvSpace = staticObjArray; + } + /* + * Free expand separately since objvSpace could have been + * reallocated above. + */ + if (expand != expandStatic) { + ckfree((char *) expand); + expand = expandStatic; } } @@ -3637,8 +3711,11 @@ Tcl_EvalEx(interp, script, numBytes, flags) if (gotParse) { Tcl_FreeParse(&parse); } - if (objv != staticObjArray) { - ckfree((char *) objv); + if (objvSpace != staticObjArray) { + ckfree((char *) objvSpace); + } + if (expand != expandStatic) { + ckfree((char *) expand); } iPtr->varFramePtr = savedVarFramePtr; return code; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 66d4bea..ee1a8a9 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.51 2003/10/14 15:44:52 dgp Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.52 2003/11/14 20:44:44 dgp Exp $ */ #include "tclInt.h" @@ -273,6 +273,10 @@ InstructionDesc tclInstructionTable[] = { /* return TCL_RETURN code. */ {"expon", 1, -1, 0, {OPERAND_NONE}}, /* Binary exponentiation operator: push (stknext ** stktop) */ + {"listverify", 1, 0, 0, {OPERAND_NONE}}, + /* Test that top of stack is a valid list; error if not */ + {"invokeExp", INT_MIN, INT_MIN, 2, {OPERAND_UINT4, OPERAND_ULIST1}}, + /* Invoke with expansion: <objc,objv> = expanded <op1,top op1> */ {0} }; @@ -843,6 +847,10 @@ TclCompileScript(interp, script, numBytes, envPtr) } gotParse = 1; if (parse.numWords > 0) { + int expand = 0; + unsigned char delta = 1; + Tcl_DString deltaList; + /* * If not the first command, pop the previous command's result * and, if we're compiling a top level command, update the last @@ -883,28 +891,57 @@ TclCompileScript(interp, script, numBytes, envPtr) fprintf(stdout, "\n"); } #endif + /* - * Each iteration of the following loop compiles one word - * from the command. + * Check whether expansion has been requested for any of + * the words */ - + + for (wordIdx = 0, tokenPtr = parse.tokenPtr; + wordIdx < parse.numWords; + wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + expand = 1; + Tcl_DStringInit(&deltaList); + break; + } + } + envPtr->numCommands++; currCmdIndex = (envPtr->numCommands - 1); lastTopLevelCmdIndex = currCmdIndex; startCodeOffset = (envPtr->codeNext - envPtr->codeStart); EnterCmdStartData(envPtr, currCmdIndex, (parse.commandStart - envPtr->source), startCodeOffset); + + /* + * Each iteration of the following loop compiles one word + * from the command. + */ for (wordIdx = 0, tokenPtr = parse.tokenPtr; - wordIdx < parse.numWords; - wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { + wordIdx < parse.numWords; delta++, wordIdx++, + tokenPtr += (tokenPtr->numComponents + 1)) { + + if ((delta == 255) + && (tokenPtr->type != TCL_TOKEN_EXPAND_WORD)) { + /* + * Push an empty list for expansion so our delta + * between expanded words doesn't overflow a byte + */ + objIndex = TclRegisterNewLiteral(envPtr, "", 0); + TclEmitPush(objIndex, envPtr); + Tcl_DStringAppend(&deltaList, &delta, 1); + delta = 1; + } + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { /* * If this is the first word and the command has a * compile procedure, let it compile the command. */ - if (wordIdx == 0) { + if ((wordIdx == 0) && !expand) { if (envPtr->procPtr != NULL) { cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; } else { @@ -987,20 +1024,55 @@ TclCompileScript(interp, script, numBytes, envPtr) goto log; } } + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + + if ((tokenPtr->numComponents == 1) + && (tokenPtr[1].type == TCL_TOKEN_TEXT)) { + /* + * The value to be expanded is fully known + * now at compile time. We can check list + * validity, so we do not have to do so at + * runtime + */ + int length; + Tcl_Obj *testObj = Tcl_NewStringObj(tokenPtr[1].start, + tokenPtr[1].size); + if (TCL_OK != + Tcl_ListObjLength(NULL, testObj, &length)) { + /* + * Not a valid list, so emit instructions to + * test list validity (and fail) at runtime + */ + TclEmitOpcode(INST_LIST_VERIFY, envPtr); + } + } else { + /* + * Value to expand unknown until runtime, so + * include a runtime check for valid list + */ + TclEmitOpcode(INST_LIST_VERIFY, envPtr); + } + Tcl_DStringAppend(&deltaList, (char *)&delta, 1); + delta = 0; + } } /* * Emit an invoke instruction for the command. We skip this * if a compile procedure was found for the command. */ - - if (wordIdx > 0) { + + if (expand) { + TclEmitInstInt4(INST_INVOKE_EXP, wordIdx, envPtr); + TclEmitImmDeltaList1(&deltaList, envPtr); + Tcl_DStringFree(&deltaList); + } else if (wordIdx > 0) { if (wordIdx <= 255) { TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); } else { TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); } - } + } /* * Update the compilation environment structure and record the @@ -3146,13 +3218,13 @@ TclPrintInstruction(codePtr, pc) register InstructionDesc *instDesc = &tclInstructionTable[opCode]; unsigned char *codeStart = codePtr->codeStart; unsigned int pcOffset = (pc - codeStart); - int opnd, i, j; + int opnd, i, j, numBytes = 1; fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name); for (i = 0; i < instDesc->numOperands; i++) { switch (instDesc->opTypes[i]) { case OPERAND_INT1: - opnd = TclGetInt1AtPtr(pc+1+i); + opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; if ((i == 0) && ((opCode == INST_JUMP1) || (opCode == INST_JUMP_TRUE1) || (opCode == INST_JUMP_FALSE1))) { @@ -3162,7 +3234,7 @@ TclPrintInstruction(codePtr, pc) } break; case OPERAND_INT4: - opnd = TclGetInt4AtPtr(pc+1+i); + opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; if ((i == 0) && ((opCode == INST_JUMP4) || (opCode == INST_JUMP_TRUE4) || (opCode == INST_JUMP_FALSE4))) { @@ -3172,7 +3244,7 @@ TclPrintInstruction(codePtr, pc) } break; case OPERAND_UINT1: - opnd = TclGetUInt1AtPtr(pc+1+i); + opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; if ((i == 0) && (opCode == INST_PUSH1)) { fprintf(stdout, "%u # ", (unsigned int) opnd); TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); @@ -3185,7 +3257,6 @@ TclPrintInstruction(codePtr, pc) if (opnd >= localCt) { panic("TclPrintInstruction: bad local var index %u (%u locals)\n", (unsigned int) opnd, localCt); - return instDesc->numBytes; } for (j = 0; j < opnd; j++) { localPtr = localPtr->nextPtr; @@ -3202,7 +3273,7 @@ TclPrintInstruction(codePtr, pc) } break; case OPERAND_UINT4: - opnd = TclGetUInt4AtPtr(pc+1+i); + opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; if (opCode == INST_PUSH4) { fprintf(stdout, "%u # ", opnd); TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); @@ -3215,7 +3286,6 @@ TclPrintInstruction(codePtr, pc) if (opnd >= localCt) { panic("TclPrintInstruction: bad local var index %u (%u locals)\n", (unsigned int) opnd, localCt); - return instDesc->numBytes; } for (j = 0; j < opnd; j++) { localPtr = localPtr->nextPtr; @@ -3231,13 +3301,24 @@ TclPrintInstruction(codePtr, pc) fprintf(stdout, "%u ", (unsigned int) opnd); } break; + + case OPERAND_ULIST1: + opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + fprintf(stdout, "{"); + while (opnd) { + fprintf(stdout, "%u ", opnd); + opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + } + fprintf(stdout, "0}"); + break; + case OPERAND_NONE: default: break; } } fprintf(stdout, "\n"); - return instDesc->numBytes; + return numBytes; } /* diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 89f27a5..869c7ad 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -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: tclCompile.h,v 1.38 2003/09/15 09:46:22 dkf Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.39 2003/11/14 20:44:44 dgp Exp $ */ #ifndef _TCLCOMPILATION @@ -526,8 +526,11 @@ typedef struct ByteCode { #define INST_EXPON 99 /* TIP#123 - exponentiation */ +#define INST_LIST_VERIFY 100 +#define INST_INVOKE_EXP 101 + /* The last opcode */ -#define LAST_INST_OPCODE 99 +#define LAST_INST_OPCODE 101 /* * Table describing the Tcl bytecode instructions: their name (for @@ -545,7 +548,8 @@ typedef enum InstOperandType { OPERAND_INT1, /* One byte signed integer. */ OPERAND_INT4, /* Four byte signed integer. */ OPERAND_UINT1, /* One byte unsigned integer. */ - OPERAND_UINT4 /* Four byte unsigned integer. */ + OPERAND_UINT4, /* Four byte unsigned integer. */ + OPERAND_ULIST1 /* List of one byte unsigned integers. */ } InstOperandType; typedef struct InstructionDesc { @@ -927,6 +931,25 @@ EXTERN int TclCompileVariableCmd _ANSI_ARGS_(( *(envPtr)->codeNext++ = \ (unsigned char) ((unsigned int) (i) );\ TclUpdateStackReqs(op, i, envPtr) + +/* + * Macro to emit an immediate list of index deltas in the code stream. + * The ANSI C "prototypes" for this macro is: + * + * EXTERN void TclEmitImmList1 _ANSI_ARGS_((Tcl_Obj *listPtr, + * CompileEnv *envPtr)); + */ + +#define TclEmitImmDeltaList1(listPtr, envPtr) \ + { \ + int numBytes = Tcl_DStringLength(listPtr) + 1; \ + while (((envPtr)->codeNext + numBytes) > (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ + memcpy((VOID *) (envPtr)->codeNext, \ + (VOID *)Tcl_DStringValue(listPtr), (size_t) numBytes); \ + (envPtr)->codeNext += numBytes; \ + } /* * Macro to push a Tcl object onto the Tcl evaluation stack. It emits the diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 25a5cdc..c642112 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.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: tclExecute.c,v 1.113 2003/10/28 22:06:14 msofer Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.114 2003/11/14 20:44:44 dgp Exp $ */ #include "tclInt.h" @@ -1078,7 +1078,9 @@ TclExecuteByteCode(interp, codePtr) Tcl_WideInt w; int isWide; register int cleanup; + int objc = 0; Tcl_Obj *objResultPtr; + Tcl_Obj **objv = NULL, **stackObjArray = NULL; char *part1, *part2; Var *varPtr, *arrayPtr; CallFrame *varFramePtr = iPtr->varFramePtr; @@ -1304,21 +1306,121 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, opnd, 1); } - + + case INST_LIST_VERIFY: + { + int numElements = 0; + valuePtr = *tosPtr; + + result = Tcl_ListObjLength(interp, valuePtr, &numElements); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), + Tcl_GetObjResult(interp)); + goto checkForCatch; + } + NEXT_INST_F(1, 0, 0); + } + + case INST_INVOKE_EXP: + { + int numWords = TclGetUInt4AtPtr(pc+1); + int spaceAvailable = eePtr->endPtr - tosPtr; + unsigned char *deltaPtr, *deltaPtrStart = pc+5; + Tcl_Obj **wordv = tosPtr - (numWords - 1); + int objIdx, wordIdx, wordToExpand = -1; + + /* + * Compute number of objects needed to store the + * command after expansion is complete. + */ + + opnd = objc = numWords; + for (deltaPtr = deltaPtrStart; *deltaPtr; deltaPtr++) { + int numElements; + wordToExpand += TclGetUInt1AtPtr(deltaPtr); + Tcl_ListObjLength(NULL, wordv[wordToExpand], &numElements); + objc += numElements - 1; + } + + /* + * We'll store the expanded command in the stack expansion + * space just above tosPtr, assuming there is room. Otherwise, + * allocate enough heap storage to store the expanded command. + */ + + objv = stackObjArray = tosPtr + 1; + if (objc > spaceAvailable) { + objv = (Tcl_Obj **) ckalloc((unsigned) + (objc * sizeof(Tcl_Obj *))); + } else { + tosPtr += objc; + } + + objIdx = 0; + deltaPtr = deltaPtrStart; + wordToExpand = TclGetUInt1AtPtr(deltaPtr) - 1; + for (wordIdx = 0; wordIdx < numWords; wordIdx++) { + + /* + * Copy words (expanding some) from wordv to objv. + * Note that we do not increment refCounts. We + * rely on the references in wordv (on the execution + * stack) to be sufficient to keep the values around + * as long as we need them. + */ + + if (wordIdx == wordToExpand) { + int i, numElements; + Tcl_Obj **elements, *temp = wordv[wordIdx]; + + /* + * Make sure the list we expand is unshared. + * If it is not shared, then the stack holds the + * only reference to it, and there is no danger + * the list will shimmer to another type (and + * possibly free the elements of the list) before + * we are done with the command evaluation. + */ + + if (Tcl_IsShared(temp)) { + Tcl_DecrRefCount(temp); + temp = Tcl_DuplicateObj(temp); + Tcl_IncrRefCount(temp); + wordv[wordIdx] = temp; + } + Tcl_ListObjGetElements(NULL, temp, &numElements, &elements); + for (i=0; i<numElements; i++) { + objv[objIdx++] = elements[i]; + } + ++deltaPtr; + if (*deltaPtr) { + wordToExpand += TclGetUInt1AtPtr(deltaPtr); + } else { + wordToExpand = -1; + } + } else { + objv[objIdx++] = wordv[wordIdx]; + } + } + pcAdjustment = (deltaPtr - pc) + 1; + goto doInvocation; + } + case INST_INVOKE_STK4: opnd = TclGetUInt4AtPtr(pc+1); + objc = opnd; + objv = stackObjArray = (tosPtr - (objc-1)); pcAdjustment = 5; goto doInvocation; case INST_INVOKE_STK1: opnd = TclGetUInt1AtPtr(pc+1); + objc = opnd; + objv = stackObjArray = (tosPtr - (objc-1)); pcAdjustment = 2; doInvocation: { - int objc = opnd; /* The number of arguments. */ - Tcl_Obj **objv; /* The array of argument objects. */ - /* * We keep the stack reference count as a (char *), as that * works nicely as a portable pointer-sized counter. @@ -1326,14 +1428,6 @@ TclExecuteByteCode(interp, codePtr) char **preservedStackRefCountPtr; - /* - * Reference to memory block containing - * objv array (must be kept live throughout - * trace and command invokations.) - */ - - objv = (tosPtr - (objc-1)); - #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { if (traceInstructions) { @@ -1418,6 +1512,12 @@ TclExecuteByteCode(interp, codePtr) ckfree((VOID *) preservedStackRefCountPtr); } + if (objv != stackObjArray) { + ckfree((char *) objv); + } else if (*pc == INST_INVOKE_EXP) { + tosPtr -= objc; + } + if (result == TCL_OK) { /* * Push the call's object result and continue execution diff --git a/generic/tclParse.c b/generic/tclParse.c index 4dd2fcb..475f1e9 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -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: tclParse.c,v 1.28 2003/11/02 18:57:35 dkf Exp $ + * RCS: @(#) $Id: tclParse.c,v 1.29 2003/11/14 20:44:45 dgp Exp $ */ #include "tclInt.h" @@ -287,6 +287,8 @@ Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr) parsePtr->commandStart = src; while (1) { + int expandWord = 0; + /* * Create the token for the word. */ @@ -319,11 +321,12 @@ Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr) parsePtr->numWords++; /* - * At this point the word can have one of three forms: something - * enclosed in quotes, something enclosed in braces, or an - * unquoted word (anything else). + * At this point the word can have one of four forms: something + * enclosed in quotes, something enclosed in braces, and + * expanding word, or an unquoted word (anything else). */ +parseWord: if (*src == '"') { if (Tcl_ParseQuotedString(interp, src, numBytes, parsePtr, 1, &termPtr) != TCL_OK) { @@ -331,11 +334,39 @@ Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr) } src = termPtr; numBytes = parsePtr->end - src; } else if (*src == '{') { + static char expPfx[] = "expand"; + CONST size_t expPfxLen = sizeof(expPfx) - 1; + int expIdx = wordIndex + 1; + Tcl_Token *expPtr; + if (Tcl_ParseBraces(interp, src, numBytes, parsePtr, 1, &termPtr) != TCL_OK) { goto error; } src = termPtr; numBytes = parsePtr->end - src; + + /* + * Check whether the braces contained + * the word expansion prefix. + */ + + expPtr = &parsePtr->tokenPtr[expIdx]; + if ( (expPfxLen == expPtr->size) + /* Same length as prefix */ + && (0 == expandWord) + /* Haven't seen prefix already */ + && (1 == parsePtr->numTokens - expIdx) + /* Only one token */ + && (0 == strncmp(expPfx,expPtr->start,expPfxLen)) + /* Is the prefix */ + && (numBytes > 0) + && (0 == TclParseWhiteSpace(termPtr, 1, parsePtr, &type)) + /* Non-whitespace follows */ + ) { + expandWord = 1; + parsePtr->numTokens--; + goto parseWord; + } } else { /* * This is an unquoted word. Call ParseTokens and let it do @@ -362,6 +393,9 @@ Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr) && (tokenPtr[1].type == TCL_TOKEN_TEXT)) { tokenPtr->type = TCL_TOKEN_SIMPLE_WORD; } + if (expandWord) { + tokenPtr->type = TCL_TOKEN_EXPAND_WORD; + } /* * Do two additional checks: (a) make sure we're really at the diff --git a/generic/tclTest.c b/generic/tclTest.c index effa8a3..c9ff8cb 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.69 2003/10/13 16:48:06 vincentdarley Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.70 2003/11/14 20:44:45 dgp Exp $ */ #define TCL_TEST @@ -3045,6 +3045,9 @@ PrintParse(interp, parsePtr) for (i = 0; i < parsePtr->numTokens; i++) { tokenPtr = &parsePtr->tokenPtr[i]; switch (tokenPtr->type) { + case TCL_TOKEN_EXPAND_WORD: + typeString = "expand"; + break; case TCL_TOKEN_WORD: typeString = "word"; break; diff --git a/library/auto.tcl b/library/auto.tcl index 217d1c4..236af39 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -3,7 +3,7 @@ # utility procs formerly in init.tcl dealing with auto execution # of commands and can be auto loaded themselves. # -# RCS: @(#) $Id: auto.tcl,v 1.13 2003/03/19 21:57:40 dgp Exp $ +# RCS: @(#) $Id: auto.tcl,v 1.14 2003/11/14 20:44:45 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. @@ -178,12 +178,12 @@ proc auto_mkindex {dir args} { append index "# sets an element in the auto_index array, where the\n" append index "# element name is the name of a command and the value is\n" append index "# a script that loads the command.\n\n" - if {$args == ""} { + if {[llength $args] == 0} { set args *.tcl } auto_mkindex_parser::init - foreach file [eval glob $args] { + foreach file [glob {expand}$args] { if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} { append index $msg } else { @@ -216,10 +216,10 @@ proc auto_mkindex_old {dir args} { append index "# sets an element in the auto_index array, where the\n" append index "# element name is the name of a command and the value is\n" append index "# a script that loads the command.\n\n" - if {[string equal $args ""]} { + if {[llength $args] == 0} { set args *.tcl } - foreach file [eval glob $args] { + foreach file [glob {expand}$args] { set f "" set error [catch { set f [open $file] diff --git a/library/package.tcl b/library/package.tcl index 77812f3..21fadd1 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -3,7 +3,7 @@ # utility procs formerly in init.tcl which can be loaded on demand # for package management. # -# RCS: @(#) $Id: package.tcl,v 1.26 2003/09/24 18:07:45 vincentdarley Exp $ +# RCS: @(#) $Id: package.tcl,v 1.27 2003/11/14 20:44:45 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. @@ -140,7 +140,7 @@ proc pkg_mkIndex {args} { set oldDir [pwd] cd $dir - if {[catch {eval glob $patternList} fileList]} { + if {[catch {glob {expand}$patternList} fileList]} { global errorCode errorInfo cd $oldDir return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList @@ -206,7 +206,7 @@ proc pkg_mkIndex {args} { proc package {what args} { switch -- $what { require { return ; # ignore transitive requires } - default { eval __package_orig {$what} $args } + default { __package_orig $what {expand}$args } } } proc tclPkgUnknown args {} @@ -261,7 +261,7 @@ proc pkg_mkIndex {args} { proc ::tcl::GetAllNamespaces {{root ::}} { set list $root foreach ns [namespace children $root] { - eval lappend list [::tcl::GetAllNamespaces $ns] + lappend list {expand}[::tcl::GetAllNamespaces $ns] } return $list } diff --git a/library/safe.tcl b/library/safe.tcl index 541bdec..9420186 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -12,7 +12,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.tcl,v 1.11 2003/07/16 22:49:12 hobbs Exp $ +# RCS: @(#) $Id: safe.tcl,v 1.12 2003/11/14 20:44:45 dgp Exp $ # # The implementation is based on namespaces. These naming conventions @@ -525,7 +525,7 @@ proc ::safe::interpDelete {slave} { # remove the hook now, otherwise if the hook # calls us somehow, we'll loop Unset $hookname - if {[catch {eval $hook [list $slave]} err]} { + if {[catch {{expand}$hook $slave} err]} { Log $slave "Delete hook error ($err)" } } @@ -636,15 +636,15 @@ proc ::safe::setLogCmd {args} { } # set/get values proc Set {args} { - eval [list Toplevel set] $args + Toplevel set {expand}$args } # lappend on toplevel vars proc Lappend {args} { - eval [list Toplevel lappend] $args + Toplevel lappend {expand}$args } # unset a var/token (currently just an global level eval) proc Unset {args} { - eval [list Toplevel unset] $args + Toplevel unset {expand}$args } # test existance proc Exists {varname} { @@ -691,7 +691,7 @@ proc ::safe::setLogCmd {args} { proc Log {slave msg {type ERROR}} { variable Log if {[info exists Log] && [llength $Log]} { - eval $Log [list "$type for slave $slave : $msg"] + {expand}$Log "$type for slave $slave : $msg" } } @@ -856,7 +856,7 @@ proc ::safe::setLogCmd {args} { proc Subset {slave command okpat args} { set subcommand [lindex $args 0] if {[regexp $okpat $subcommand]} { - return [eval [list $command $subcommand] [lrange $args 1 end]] + return [$command $subcommand {expand}[lrange $args 1 end]] } set msg "not allowed to invoke subcommand $subcommand of $command" Log $slave $msg @@ -891,8 +891,8 @@ proc ::safe::setLogCmd {args} { set subcommand [lindex $args 0] if {[regexp $okpat $subcommand]} { - return [eval ::interp invokehidden $slave encoding $subcommand \ - [lrange $args 1 end]] + return [::interp invokehidden $slave encoding $subcommand \ + {expand}[lrange $args 1 end]] } if {[string match $subcommand system]} { diff --git a/tests/basic.test b/tests/basic.test index a16220c..fe616b5 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -15,12 +15,13 @@ # 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.29 2003/07/24 16:05:24 dgp Exp $ +# RCS: @(#) $Id: basic.test,v 1.30 2003/11/14 20:44:45 dgp Exp $ # package require tcltest 2 namespace import -force ::tcltest::* +testConstraint testevalex [llength [info commands testevalex]] testConstraint testcmdtoken [llength [info commands testcmdtoken]] testConstraint testcreatecommand [llength [info commands testcreatecommand]] testConstraint exec [llength [info commands exec]] @@ -201,13 +202,13 @@ test basic-13.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being expo } {42 {} {} Hello {} {} 42} test basic-14.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {testcreatecommand} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [testcreatecommand create] \ [test_ns_basic::createdcommand] \ [testcreatecommand delete] } {{} {CreatedCommandProc in ::test_ns_basic} {}} test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} {testcreatecommand} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename value:at: ""} list [testcreatecommand create2] \ [value:at:] \ @@ -215,7 +216,7 @@ test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle } {{} {CreatedCommandProc2 in ::} {}} test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_basic {} proc test_ns_basic::cmd {} { ;# proc requires that ns already exist return [namespace current] @@ -231,7 +232,7 @@ test basic-17.1 {TclInvokeObjCommand} {emptyTest} { } {} test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename cmd ""} namespace eval test_ns_basic { proc p {} { @@ -243,11 +244,11 @@ test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace quali [test_ns_basic::q] } {{p in ::test_ns_basic} {} {p in ::test_ns_basic}} test basic-18.2 {TclRenameCommand, existing cmd must be found} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg } {1 {can't rename "test_ns_basic::p": command doesn't exist}} test basic-18.3 {TclRenameCommand, delete cmd if new name is empty} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_basic { proc p {} { return "p in [namespace current]" @@ -258,7 +259,7 @@ test basic-18.3 {TclRenameCommand, delete cmd if new name is empty} { [info commands test_ns_basic::*] } {::test_ns_basic::p {} {}} test basic-18.4 {TclRenameCommand, bad new name} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_basic { proc p {} { return "p in [namespace current]" @@ -275,7 +276,7 @@ test basic-18.5 {TclRenameCommand, new name must not already exist} { list [catch {rename test_ns_basic::q :::george::martha} msg] $msg } {1 {can't rename to ":::george::martha": command already exists}} test basic-18.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename q ""} proc p {} { @@ -298,7 +299,7 @@ test basic-19.1 {Tcl_SetCommandInfo} {emptyTest} { } {} test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {testcmdtoken} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename q ""} catch {unset x} @@ -317,7 +318,7 @@ test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespac [rename test_ns_basic::test_ns_basic2::p q] \ [testcmdtoken name $x] } {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}} -test basic-20.3 {Tcl_GetCommandInfo, #-quoting} { +test basic-20.3 {Tcl_GetCommandInfo, #-quoting} testcmdtoken { catch {rename \# ""} set x [testcmdtoken create \#] testcmdtoken name $x @@ -327,7 +328,7 @@ test basic-21.1 {Tcl_GetCommandName} {emptyTest} { } {} test basic-22.1 {Tcl_GetCommandFullName} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_basic1 { namespace export cmd* proc cmd1 {} {} @@ -373,7 +374,7 @@ test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd [interp delete test_interp] } {123 {set called with a 123} {}} test basic-24.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename p ""} proc p {} { return "global p" @@ -391,7 +392,7 @@ test basic-24.2 {Tcl_DeleteCommandFromToken, deleting commands changes command e [test_ns_basic::callP] } {{namespace p} {} {global p}} test basic-24.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename p ""} namespace eval test_ns_basic { namespace export p @@ -459,7 +460,7 @@ test basic-35.1 {TclObjInvokeGlobal} {emptyTest} { } {} test basic-36.1 {TclObjInvoke, lookup of "unknown" command} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {interp delete test_interp} interp create test_interp interp eval test_interp { @@ -587,9 +588,315 @@ test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -body { subst {a[set b [format cd]} } -returnCodes error -result {missing close-bracket} +# Some lists for expansion tests to work with +set l1 [list a {b b} c d] +set l2 [list e f {g g} h] +proc l3 {} { + list i j k {l l} +} + +# Do all tests once byte compiled and once with direct string evaluation +for {set noComp 0} {$noComp <= 1} {incr noComp} { + +if $noComp { + interp alias {} run {} testevalex + set constraints testevalex +} else { + interp alias {} run {} if 1 + set constraints {} +} + +test basic-47.2.$noComp {Tcl_EvalEx: error during word expansion} -body { + run {{expand}\{} +} -constraints $constraints -returnCodes error -result {unmatched open brace in list} + +test basic-47.3.$noComp {Tcl_EvalEx, error during substitution} -body { + run {{expand}[error foo]} +} -constraints $constraints -returnCodes error -result foo + +test basic-47.4.$noComp {Tcl_EvalEx: no expansion} $constraints { + run {list {expand} {expand} {expand}} +} {expand expand expand} + +test basic-47.5.$noComp {Tcl_EvalEx: expansion} $constraints { + run {list {expand}{} {expand} {expand}x {expand}"y z"} +} {expand x y z} + +test basic-47.6.$noComp {Tcl_EvalEx: expansion to zero args} $constraints { + run {list {expand}{}} +} {} + +test basic-47.7.$noComp {Tcl_EvalEx: expansion to one arg} $constraints { + run {list {expand}x} +} x + +test basic-47.8.$noComp {Tcl_EvalEx: expansion to many args} $constraints { + run {list {expand}"y z"} +} {y z} + +test basic-47.9.$noComp {Tcl_EvalEx: expansion and subst order} $constraints { + set x 0 + run {list [incr x] {expand}[incr x] [incr x] \ + {expand}[list [incr x] [incr x]] [incr x]} +} {1 2 3 4 5 6} + +test basic-47.10.$noComp {Tcl_EvalEx: expand and memory management} $constraints { + run {concat {expand}{} a b c d e f g h i j k l m n o p q r} +} {a b c d e f g h i j k l m n o p q r} + +test basic-47.11.$noComp {Tcl_EvalEx: expand and memory management} $constraints { + run {concat {expand}1 a b c d e f g h i j k l m n o p q r} +} {1 a b c d e f g h i j k l m n o p q r} + +test basic-47.12.$noComp {Tcl_EvalEx: expand and memory management} $constraints { + run {concat {expand}{1 2} a b c d e f g h i j k l m n o p q r} +} {1 2 a b c d e f g h i j k l m n o p q r} + +test basic-47.13.$noComp {Tcl_EvalEx: expand and memory management} $constraints { + run {concat {expand}{} {expand}{1 2} a b c d e f g h i j k l m n o p q} +} {1 2 a b c d e f g h i j k l m n o p q} + +test basic-47.14.$noComp {Tcl_EvalEx: expand and memory management} $constraints { + run {concat {expand}{} a b c d e f g h i j k l m n o p q r s} +} {a b c d e f g h i j k l m n o p q r s} + +test basic-47.15.$noComp {Tcl_EvalEx: expand and memory management} $constraints { + run {concat {expand}1 a b c d e f g h i j k l m n o p q r s} +} {1 a b c d e f g h i j k l m n o p q r s} + +test basic-47.16.$noComp {Tcl_EvalEx: expand and memory management} $constraints { + run {concat {expand}{1 2} a b c d e f g h i j k l m n o p q r s} +} {1 2 a b c d e f g h i j k l m n o p q r s} + +test basic-47.17.$noComp {Tcl_EvalEx: expand and memory management} $constraints { + run {concat {expand}{} {expand}{1 2} a b c d e f g h i j k l m n o p q r} +} {1 2 a b c d e f g h i j k l m n o p q r} + +test basic-48.1.$noComp {expansion: parsing} $constraints { + run { # A comment + + # Another comment + list 1 2\ + 3 {expand}$::l1 + + # Comment again + } +} {1 2 3 a {b b} c d} + +test basic-48.2.$noComp {no expansion} $constraints { + run {list $::l1 $::l2 [l3]} +} {{a {b b} c d} {e f {g g} h} {i j k {l l}}} + +test basic-48.3.$noComp {expansion} $constraints { + run {list {expand}$::l1 $::l2 {expand}[l3]} +} {a {b b} c d {e f {g g} h} i j k {l l}} + +test basic-48.4.$noComp {expansion: really long cmd} $constraints { + set cmd [list list] + for {set t 0} {$t < 500} {incr t} { + lappend cmd {{expand}$::l1} + } + llength [run [join $cmd]] +} 2000 + +test basic-48.5.$noComp {expansion: error detection} -setup { + set l "a {a b}x y" +} -constraints $constraints -body { + run {list $::l1 {expand}$l} +} -cleanup { + unset l +} -returnCodes 1 -result {list element in braces followed by "x" instead of space} + +test basic-48.6.$noComp {expansion: odd usage} $constraints { + run {list {expand}$::l1$::l2} +} {a {b b} c de f {g g} h} + +test basic-48.7.$noComp {expansion: odd usage} -constraints $constraints -body { + run {list {expand}[l3]$::l1} +} -returnCodes 1 -result {list element in braces followed by "a" instead of space} + +test basic-48.8.$noComp {expansion: odd usage} $constraints { + run {list {expand}hej$::l1} +} {heja {b b} c d} + +test basic-48.9.$noComp {expansion: Not all {expand} should trigger} $constraints { + run {list {expand}$::l1 \{expand\}$::l2 "{expand}$::l1" {{expand} i j k}} +} {a {b b} c d {{expand}e f {g g} h} {{expand}a {b b} c d} {{expand} i j k}} + +test basic-48.10.$noComp {expansion: expansion of command word} -setup { + set cmd [list string range jultomte] +} -constraints $constraints -body { + run {{expand}$cmd 2 6} +} -cleanup { + unset cmd +} -result ltomt + +test basic-48.11.$noComp {expansion: expansion into nothing} -setup { + set cmd {} + set bar {} +} -constraints $constraints -body { + run {{expand}$cmd {expand}$bar} +} -cleanup { + unset cmd bar +} -result {} + +test basic-48.12.$noComp {expansion: odd usage} $constraints { + run {list {expand}$::l1 {expand}"hej hopp" {expand}$::l2} +} {a {b b} c d hej hopp e f {g g} h} + +test basic-48.13.$noComp {expansion: odd usage} $constraints { + run {list {expand}$::l1 {expand}{hej hopp} {expand}$::l2} +} {a {b b} c d hej hopp e f {g g} h} + +test basic-48.14.$noComp {expansion: hash command} -setup { + catch {rename \# ""} + set cmd "#" + } -constraints $constraints -body { + run { {expand}$cmd apa bepa } + } -cleanup { + unset cmd +} -returnCodes 1 -result {invalid command name "#"} + +test basic-48.15.$noComp {expansion: complex words} -setup { + set a(x) [list a {b c} d e] + set b x + set c [list {f\ g h\ i j k} x y] + set d {0\ 1 2 3} + } -constraints $constraints -body { + run { lappend d {expand}$a($b) {expand}[lindex $c 0] } + } -cleanup { + unset a b c d +} -result {{0 1} 2 3 a {b c} d e {f g} {h i} j k} + +testConstraint memory [llength [info commands memory]] +test basic-48.16.$noComp {expansion: testing for leaks} -setup { + proc getbytes {} { + set lines [split [memory info] "\n"] + lindex [lindex $lines 3] 3 + } + # This test is made to stress the allocation, reallocation and + # object reference management in Tcl_EvalEx. + proc stress {} { + set a x + # Create free objects that should disappear + set l [list 1$a 2$a 3$a 4$a 5$a 6$a 7$a] + # A short number of words and a short result (8) + set l [run {list {expand}$l $a$a}] + # A short number of words and a longer result (27) + set l [run {list {expand}$l $a$a {expand}$l $a$a {expand}$l $a$a}] + # A short number of words and a longer result, with an error + # This is to stress the cleanup in the error case + if {![catch {run {_moo_ {expand}$l $a$a {expand}$l $a$a {expand}$l}}]} { + error "An error was expected in the previous statement" + } + # Many words + set l [run {list {expand}$l $a$a {expand}$l $a$a \ + {expand}$l $a$a {expand}$l $a$a \ + {expand}$l $a$a {expand}$l $a$a \ + {expand}$l $a$a {expand}$l $a$a \ + {expand}$l $a$a {expand}$l $a$a \ + {expand}$l $a$a {expand}$l $a$a \ + {expand}$l $a$a {expand}$l $a$a \ + {expand}$l $a$a {expand}$l $a$a \ + {expand}$l $a$a {expand}$l $a$a \ + {expand}$l $a$a}] + + if {[llength $l] != 19*28} { + error "Bad Length: [llength $l] should be [expr {19*28}]" + } + } + } -constraints [linsert $constraints 0 memory] -body { + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + stress + set tmp $end + set end [getbytes] + } + set leak [expr {$end - $tmp}] + } -cleanup { + unset end i tmp + rename getbytes {} + rename stress {} +} -result 0 + +test basic-48.17.$noComp {expansion: object safety} -setup { + set old_precision $::tcl_precision + set ::tcl_precision 4 + } -constraints $constraints -body { + set third [expr {1.0/3.0}] + set l [list $third $third] + set x [run {list $third {expand}$l $third}] + set res [list] + foreach t $x { + lappend res [expr {$t * 3.0}] + } + set res + } -cleanup { + set ::tcl_precision $old_precision + unset old_precision res t l x third +} -result {1.0 1.0 1.0 1.0} + +test basic-48.18.$noComp {expansion: list semantics} -constraints $constraints -body { + set badcmd { + list a b + set apa 10 + } + set apa 0 + list [llength [run { {expand}$badcmd }]] $apa + } -cleanup { + unset apa badcmd +} -result {5 0} + +test basic-48.19.$noComp {expansion: error checking order} -body { + set badlist "a {}x y" + set a 0 + set b 0 + catch {run {list [incr a] {expand}$badlist [incr b]}} + list $a $b + } -constraints $constraints -cleanup { + unset badlist a b +} -result {1 0} + +test basic-48.20.$noComp {expansion: odd case with word boundaries} $constraints { + run {list {expand}$::l1 {expand}"hej hopp" {expand}$::l2} +} {a {b b} c d hej hopp e f {g g} h} + +test basic-48.21.$noComp {expansion: odd case with word boundaries} $constraints { + run {list {expand}$::l1 {expand}{hej hopp} {expand}$::l2} +} {a {b b} c d hej hopp e f {g g} h} + +test basic-48.22.$noComp {expansion: odd case with word boundaries} -body { + run {list {expand}$::l1 {expand}"hej hopp {expand}$::l2} +} -constraints $constraints -returnCodes error -result {missing "} + +test basic-48.23.$noComp {expansion: handle return codes} -constraints $constraints -body { + set res {} + for {set t 0} {$t < 10} {incr t} { + run { {expand}break } + } + lappend res $t + + for {set t 0} {$t < 10} {incr t} { + run { {expand}continue } + set t 20 + } + lappend res $t + + lappend res [catch { run { {expand}{error Hejsan} } } err] + lappend res $err + } -cleanup { + unset res t +} -result {0 10 1 Hejsan} + +} ;# End of noComp loop + +# Clean up after expand tests +unset noComp l1 l2 constraints +rename l3 {} +rename run {} -# cleanup -catch {eval namespace delete [namespace children :: test_ns_*]} + #cleanup +catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {namespace delete george} catch {interp delete test_interp} catch {rename p ""} diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test index 5f62444..b4022af 100644 --- a/tests/cmdInfo.test +++ b/tests/cmdInfo.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: cmdInfo.test,v 1.7 2002/06/22 04:19:47 dgp Exp $ +# RCS: @(#) $Id: cmdInfo.test,v 1.8 2003/11/14 20:44:46 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -71,7 +71,7 @@ test cmdinfo-4.1 {Tcl_GetCommandName/Tcl_GetCommandFullName procedures} \ rename x1 newName set y [testcmdtoken name $x] rename newName x1 - eval lappend y [testcmdtoken name $x] + lappend y {expand}[testcmdtoken name $x] } {newName ::newName x1 ::x1} catch {rename newTestCmd {}} @@ -88,7 +88,7 @@ test cmdinfo-5.1 {Names for commands created when inside namespaces} \ }] set y [testcmdtoken name $x] rename ::testCmd newTestCmd - eval lappend y [testcmdtoken name $x] + lappend y {expand}[testcmdtoken name $x] } {testCmd ::testCmd newTestCmd ::newTestCmd} test cmdinfo-6.1 {Names for commands created when outside namespaces} \ @@ -96,7 +96,7 @@ test cmdinfo-6.1 {Names for commands created when outside namespaces} \ set x [testcmdtoken create cmdInfoNs1::cmdInfoNs2::testCmd] set y [testcmdtoken name $x] rename cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 - eval lappend y [testcmdtoken name $x] + lappend y {expand}[testcmdtoken name $x] } {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2} # cleanup diff --git a/tests/compile.test b/tests/compile.test index 8559b24..1fb445c 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -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: compile.test,v 1.27 2003/05/09 13:42:40 msofer Exp $ +# RCS: @(#) $Id: compile.test,v 1.28 2003/11/14 20:44:46 dgp Exp $ package require tcltest 2 namespace import -force ::tcltest::* @@ -274,9 +274,9 @@ test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { # # Special test for leak on interp delete [Bug 467523]. ::tcltest::testConstraint exec [llength [info commands exec]] -::tcltest::testConstraint memDebug [llength [info commands memory]] +::tcltest::testConstraint memory [llength [info commands memory]] -test compile-12.1 {testing literal leak on interp delete} {memDebug} { +test compile-12.1 {testing literal leak on interp delete} {memory} { proc getbytes {} { set lines [split [memory info] "\n"] lindex [lindex $lines 3] 3 @@ -298,7 +298,7 @@ test compile-12.1 {testing literal leak on interp delete} {memDebug} { # Special test for a memory error in a preliminary fix of [Bug 467523]. # It requires executing a helpfile. Presumably the child process is # used because when this test fails, it crashes. -test compile-12.2 {testing error on literal deletion} {memDebug exec} { +test compile-12.2 {testing error on literal deletion} {memory exec} { makeFile { for {set i 0} {$i < 5} {incr i} { namespace eval bar {} @@ -373,6 +373,137 @@ test compile-15.5 {proper TCL_RETURN code from [return]} { set result } "" +testConstraint testevalex [llength [info commands testevalex]] +for {set noComp 1} {$noComp <= 1} {incr noComp} { + +if $noComp { + interp alias {} run {} testevalex + set constraints testevalex +} else { + interp alias {} run {} if 1 + set constraints {} +} + +test compile-16.1.$noComp {TclCompileScript: word expansion} $constraints { + run "list [string repeat {{expand}a } 255]" +} [lrepeat 255 a] + +test compile-16.2.$noComp {TclCompileScript: word expansion} $constraints { + run "list [string repeat {{expand}a } 256]" +} [lrepeat 256 a] + +test compile-16.3.$noComp {TclCompileScript: word expansion} $constraints { + run "list [string repeat {{expand}a } 257]" +} [lrepeat 257 a] + +test compile-16.4.$noComp {TclCompileScript: word expansion} $constraints { + run {{expand}list} +} {} + +test compile-16.5.$noComp {TclCompileScript: word expansion} $constraints { + run {{expand}list {expand}{x y z}} +} {x y z} + +test compile-16.6.$noComp {TclCompileScript: word expansion} $constraints { + run {{expand}list {expand}[list x y z]} +} {x y z} + +test compile-16.7.$noComp {TclCompileScript: word expansion} $constraints { + run {{expand}list {expand}[list x y z][list x y z]} +} {x y zx y z} + +test compile-16.8.$noComp {TclCompileScript: word expansion} -body { + set l {x y z} + run {{expand}list {expand}$l} +} -constraints $constraints -cleanup { + unset l +} -result {x y z} + +test compile-16.9.$noComp {TclCompileScript: word expansion} -body { + set l {x y z} + run {{expand}list {expand}$l$l} +} -constraints $constraints -cleanup { + unset l +} -result {x y zx y z} + +test compile-16.10.$noComp {TclCompileScript: word expansion} -body { + run {{expand}\{} +} -constraints $constraints -returnCodes error \ +-result {unmatched open brace in list} + +test compile-16.11.$noComp {TclCompileScript: word expansion} -body { + proc badList {} {return \{} + run {{expand}[badList]} +} -constraints $constraints -cleanup { + rename badList {} +} -returnCodes error -result {unmatched open brace in list} + +test compile-16.12.$noComp {TclCompileScript: word expansion} $constraints { + run {{expand}list x y z} +} {x y z} + +test compile-16.13.$noComp {TclCompileScript: word expansion} $constraints { + run {{expand}list x y {expand}z} +} {x y z} + +test compile-16.14.$noComp {TclCompileScript: word expansion} $constraints { + run {{expand}list x {expand}y z} +} {x y z} + +test compile-16.15.$noComp {TclCompileScript: word expansion} $constraints { + run {list x y {expand}z} +} {x y z} + +test compile-16.16.$noComp {TclCompileScript: word expansion} $constraints { + run {list x {expand}y z} +} {x y z} + +test compile-16.17.$noComp {TclCompileScript: word expansion} $constraints { + run {list {expand}x y z} +} {x y z} + +# These tests note that expansion can in theory cause the number of +# arguments to a command to exceed INT_MAX, which is as big as objc +# is allowed to get. +# +# In practice, it seems we will run out of memory before we confront +# this issue. Note that compiled operations run out of memory at +# smaller objc values than direct string evaluation. +# +# These tests are constrained as knownBug because they are likely +# to cause memory allocation panics somewhere, and we don't want +# panics in the test suite. +# +test compile-16.18.$noComp {TclCompileScript: word expansion} -body { + proc LongList {} {return [lrepeat [expr {1<<10}] x]} + llength [run "list [string repeat {{expand}[LongList] } [expr {1<<10}]]"] +} -constraints [linsert $constraints 0 knownBug] -cleanup { + rename LongList {} +} -returnCodes ok -result [expr {1<<20}] + +test compile-16.19.$noComp {TclCompileScript: word expansion} -body { + proc LongList {} {return [lrepeat [expr {1<<11}] x]} + llength [run "list [string repeat {{expand}[LongList] } [expr {1<<11}]]"] +} -constraints [linsert $constraints 0 knownBug] -cleanup { + rename LongList {} +} -returnCodes ok -result [expr {1<<22}] + +test compile-16.20.$noComp {TclCompileScript: word expansion} -body { + proc LongList {} {return [lrepeat [expr {1<<12}] x]} + llength [run "list [string repeat {{expand}[LongList] } [expr {1<<12}]]"] +} -constraints [linsert $constraints 0 knownBug] -cleanup { + rename LongList {} +} -returnCodes ok -result [expr {1<<24}] + +# This is the one that should cause overflow +test compile-16.21.$noComp {TclCompileScript: word expansion} -body { + proc LongList {} {return [lrepeat [expr {1<<16}] x]} + llength [run "list [string repeat {{expand}[LongList] } [expr {1<<16}]]"] +} -constraints [linsert $constraints 0 knownBug] -cleanup { + rename LongList {} +} -returnCodes ok -result [expr {wide(1)<<32}] + +} ;# End of noComp loop # cleanup catch {rename p ""} diff --git a/tests/encoding.test b/tests/encoding.test index 576d078..b955238 100644 --- a/tests/encoding.test +++ b/tests/encoding.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: encoding.test,v 1.18 2003/03/27 21:44:05 msofer Exp $ +# RCS: @(#) $Id: encoding.test,v 1.19 2003/11/14 20:44:46 dgp Exp $ package require tcltest 2 namespace import -force ::tcltest::* @@ -541,7 +541,7 @@ foreach from {cp932 shiftjis euc-jp iso2022-jp} { } } -eval [list file delete] [glob -directory [temporaryDirectory] *.chars *.tcltestout] +file delete {expand}[glob -directory [temporaryDirectory] *.chars *.tcltestout] # ===> Cut here <=== # EscapeFreeProc, GetTableEncoding, unilen diff --git a/tests/execute.test b/tests/execute.test index 66e96a9..597832e 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -14,14 +14,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: execute.test,v 1.15 2003/10/04 16:12:12 msofer Exp $ +# RCS: @(#) $Id: execute.test,v 1.16 2003/11/14 20:44:46 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } -catch {eval namespace delete [namespace children :: test_ns_*]} +catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename foo ""} catch {unset x} catch {unset y} @@ -507,7 +507,7 @@ test execute-3.77 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is non-numeri # INST_PUSH_RETURN_CODE not tested test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {unset x} catch {unset y} namespace eval test_ns_1 { @@ -525,7 +525,7 @@ test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} { [catch {namespace which -command ${x}${y}:cmd2} msg] $msg } {::test_ns_1::test_ns_2::cmd1 0 {} 0 {}} test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename foo ""} catch {unset l} proc foo {} { @@ -547,7 +547,7 @@ test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is inval set l } {::foo ::test_ns_1::foo} test execute-4.3 {Tcl_GetCommandFromObj, command never found} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename foo ""} namespace eval test_ns_1 { proc foo {} { @@ -565,7 +565,7 @@ test execute-4.3 {Tcl_GetCommandFromObj, command never found} { } {::test_ns_1::foo {} 0 {}} test execute-5.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {unset l} proc {} {} {return {}} {} @@ -734,7 +734,7 @@ test execute-8.2 {Stack restoration} { if {[info commands testobj] != {}} { testobj freeallvars } -catch {eval namespace delete [namespace children :: test_ns_*]} +catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename foo ""} catch {rename p ""} catch {rename {} ""} diff --git a/tests/fCmd.test b/tests/fCmd.test index 38bfcd4..a712df5 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.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: fCmd.test,v 1.32 2003/11/10 17:57:21 vincentdarley Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.33 2003/11/14 20:44:46 dgp Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -2194,7 +2194,7 @@ test fCmd-27.4 {TclFileAttrsCmd - getting one option} { catch {file delete -force -- foo.tmp} createfile foo.tmp set attrs [file attributes foo.tmp] - list [catch {eval file attributes foo.tmp [lindex $attrs 0]}] [file delete -force -- foo.tmp] + list [catch {file attributes foo.tmp {expand}[lindex $attrs 0]}] [file delete -force -- foo.tmp] } {0 {}} # Find a group that exists on this Unix system, or else skip tests that @@ -2214,13 +2214,13 @@ test fCmd-27.5 {TclFileAttrsCmd - setting one option} {foundGroup} { catch {file delete -force -- foo.tmp} createfile foo.tmp set attrs [file attributes foo.tmp] - list [catch {eval file attributes foo.tmp [lrange $attrs 0 1]} msg] $msg [file delete -force -- foo.tmp] + list [catch {file attributes foo.tmp {expand}[lrange $attrs 0 1]} msg] $msg [file delete -force -- foo.tmp] } {0 {} {}} test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {foundGroup} { catch {file delete -force -- foo.tmp} createfile foo.tmp set attrs [file attributes foo.tmp] - list [catch {eval file attributes foo.tmp [lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp] + list [catch {file attributes foo.tmp {expand}[lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp] } {0 {} {}} if {[string equal $tcl_platform(platform) "windows"]} { diff --git a/tests/http.test b/tests/http.test index 905abdd..9b38bb2 100644 --- a/tests/http.test +++ b/tests/http.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # -# RCS: @(#) $Id: http.test,v 1.35 2003/07/18 19:36:40 hobbs Exp $ +# RCS: @(#) $Id: http.test,v 1.36 2003/11/14 20:44:46 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -100,7 +100,7 @@ test http-1.4 {http::config} { set savedconf [http::config] http::config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite" set x [http::config] - eval http::config $savedconf + http::config {expand}$savedconf set x } {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}} diff --git a/tests/init.test b/tests/init.test index 6855098..e8da0eb 100644 --- a/tests/init.test +++ b/tests/init.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: init.test,v 1.11 2003/06/27 17:22:41 dgp Exp $ +# RCS: @(#) $Id: init.test,v 1.12 2003/11/14 20:44:46 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -18,7 +18,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } # Clear out any namespaces called test_ns_* -catch {eval namespace delete [namespace children :: test_ns_*]} +catch {namespace delete {expand}[namespace children :: test_ns_*]} # Six cases - white box testing diff --git a/tests/interp.test b/tests/interp.test index b3f2e10..9cace24 100644 --- a/tests/interp.test +++ b/tests/interp.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: interp.test,v 1.24 2003/09/04 17:36:56 dgp Exp $ +# RCS: @(#) $Id: interp.test,v 1.25 2003/11/14 20:44:46 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -2084,7 +2084,7 @@ test interp-26.6 {result code transmission: all combined--bug 1637} \ proc MyTestAlias {interp args} { global aliasTrace; lappend aliasTrace $args; - eval interp invokehidden [list $interp] $args + interp invokehidden $interp {expand}$args } foreach c {return} { interp hide $interp $c; diff --git a/tests/io.test b/tests/io.test index 53086da..fcecb26 100644 --- a/tests/io.test +++ b/tests/io.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: io.test,v 1.47 2003/10/07 21:45:39 dgp Exp $ +# RCS: @(#) $Id: io.test,v 1.48 2003/11/14 20:44:46 dgp Exp $ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." @@ -2147,7 +2147,7 @@ test io-28.4 {Tcl_Close} {testchannel} { close $f lappend l [lsort [testchannel open]] set x [list $consoleFileNames \ - [lsort [eval list $consoleFileNames $f]] \ + [lsort [list {expand}$consoleFileNames $f]] \ $consoleFileNames] string compare $l $x } 0 diff --git a/tests/ioUtil.test b/tests/ioUtil.test index 273f47e..1671572 100644 --- a/tests/ioUtil.test +++ b/tests/ioUtil.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: ioUtil.test,v 1.14 2003/04/11 16:00:00 vincentdarley Exp $ +# RCS: @(#) $Id: ioUtil.test,v 1.15 2003/11/14 20:44:46 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -191,7 +191,7 @@ set oldpwd [pwd] cd [temporaryDirectory] test ioUtil-3.1 {TclOpenFileChannel: Check that none of the test procs are there.} {testopenfilechannelproc} { - catch {eval [list file delete -force] [glob *testOpenFileChannel*]} + catch {file delete -force {expand}[glob *testOpenFileChannel*]} catch {file exists testOpenFileChannel1%.fil} err1 catch {file exists testOpenFileChannel2%.fil} err2 catch {file exists testOpenFileChannel3%.fil} err3 diff --git a/tests/iogt.test b/tests/iogt.test index 2494b91..8b75442 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -10,7 +10,7 @@ # Copyright (c) 2000 Andreas Kupries. # All rights reserved. # -# RCS: @(#) $Id: iogt.test,v 1.7 2002/07/04 15:46:55 andreas_kupries Exp $ +# RCS: @(#) $Id: iogt.test,v 1.8 2003/11/14 20:44:46 dgp Exp $ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." @@ -147,8 +147,8 @@ proc fevent {fdelay idelay blocks script data} { # fixed port, not so good. lets hope for the best, for now. set port 4000 - eval exec tclsh __echo_srv__.tcl \ - $port $fdelay $idelay $blocks >@stdout & + exec tclsh __echo_srv__.tcl \ + $port $fdelay $idelay {expand}$blocks >@stdout & after 500 diff --git a/tests/lindex.test b/tests/lindex.test index ea52e91..63d1548 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -12,75 +12,75 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: lindex.test,v 1.10 2002/04/19 13:08:56 dkf Exp $ +# RCS: @(#) $Id: lindex.test,v 1.11 2003/11/14 20:44:46 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -set lindex lindex set minus - +testConstraint testevalex [llength [info commands testevalex]] # Tests of Tcl_LindexObjCmd, NOT COMPILED -test lindex-1.1 {wrong # args} { - list [catch {eval $lindex} result] $result +test lindex-1.1 {wrong # args} testevalex { + list [catch {testevalex lindex} result] $result } "1 {wrong # args: should be \"lindex list ?index...?\"}" # Indices that are lists or convertible to lists -test lindex-2.1 {empty index list} { +test lindex-2.1 {empty index list} testevalex { set x {} - list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]] + list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {{a b c} {a b c}} -test lindex-2.2 {singleton index list} { +test lindex-2.2 {singleton index list} testevalex { set x { 1 } - list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]] + list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {b b} -test lindex-2.3 {multiple indices in list} { +test lindex-2.3 {multiple indices in list} testevalex { set x {1 2} - list [eval [list $lindex {{a b c} {d e f}} $x]] \ - [eval [list $lindex {{a b c} {d e f}} $x]] + list [testevalex {lindex {{a b c} {d e f}} $x}] \ + [testevalex {lindex {{a b c} {d e f}} $x}] } {f f} -test lindex-2.4 {malformed index list} { +test lindex-2.4 {malformed index list} testevalex { set x \{ - list [catch { eval [list $lindex {a b c} $x] } result] $result + list [catch { testevalex {lindex {a b c} $x} } result] $result } {1 bad\ index\ \"\{\":\ must\ be\ integer\ or\ end?-integer?} # Indices that are integers or convertible to integers -test lindex-3.1 {integer -1} { +test lindex-3.1 {integer -1} testevalex { set x ${minus}1 - list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]] + list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {{} {}} -test lindex-3.2 {integer 0} { +test lindex-3.2 {integer 0} testevalex { set x [string range 00 0 0] - list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]] + list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {a a} -test lindex-3.3 {integer 2} { +test lindex-3.3 {integer 2} testevalex { set x [string range 22 0 0] - list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]] + list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {c c} -test lindex-3.4 {integer 3} { +test lindex-3.4 {integer 3} testevalex { set x [string range 33 0 0] - list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]] + list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {{} {}} -test lindex-3.5 {bad octal} { +test lindex-3.5 {bad octal} testevalex { set x 08 - list [catch { eval [list $lindex {a b c} $x] } result] $result + list [catch { testevalex {lindex {a b c} $x} } result] $result } "1 {bad index \"08\": must be integer or end?-integer? (looks like invalid octal number)}" -test lindex-3.6 {bad octal} { +test lindex-3.6 {bad octal} testevalex { set x -09 - list [catch { eval [list $lindex {a b c} $x] } result] $result + list [catch { testevalex {lindex {a b c} $x} } result] $result } "1 {bad index \"-09\": must be integer or end?-integer? (looks like invalid octal number)}" test lindex-3.7 {indexes don't shimmer wide ints} { @@ -90,122 +90,122 @@ test lindex-3.7 {indexes don't shimmer wide ints} { # Indices relative to end -test lindex-4.1 {index = end} { +test lindex-4.1 {index = end} testevalex { set x end - list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]] + list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {c c} -test lindex-4.2 {index = end--1} { +test lindex-4.2 {index = end--1} testevalex { set x end--1 - list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]] + list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {{} {}} -test lindex-4.3 {index = end-0} { +test lindex-4.3 {index = end-0} testevalex { set x end-0 - list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]] + list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {c c} -test lindex-4.4 {index = end-2} { +test lindex-4.4 {index = end-2} testevalex { set x end-2 - list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]] + list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {a a} -test lindex-4.5 {index = end-3} { +test lindex-4.5 {index = end-3} testevalex { set x end-3 - list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]] + list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {{} {}} -test lindex-4.6 {bad octal} { +test lindex-4.6 {bad octal} testevalex { set x end-08 - list [catch { eval [list $lindex {a b c} $x] } result] $result + list [catch { testevalex {lindex {a b c} $x} } result] $result } "1 {bad index \"end-08\": must be integer or end?-integer? (looks like invalid octal number)}" -test lindex-4.7 {bad octal} { +test lindex-4.7 {bad octal} testevalex { set x end--09 - list [catch { eval [list $lindex {a b c} $x] } result] $result + list [catch { testevalex {lindex {a b c} $x} } result] $result } "1 {bad index \"end--09\": must be integer or end?-integer?}" -test lindex-4.8 {bad integer, not octal} { +test lindex-4.8 {bad integer, not octal} testevalex { set x end-0a2 - list [catch { eval [list $lindex {a b c} $x] } result] $result + list [catch { testevalex {lindex {a b c} $x} } result] $result } "1 {bad index \"end-0a2\": must be integer or end?-integer?}" -test lindex-4.9 {incomplete end} { +test lindex-4.9 {incomplete end} testevalex { set x en - list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]] + list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {c c} -test lindex-4.10 {incomplete end-} { +test lindex-4.10 {incomplete end-} testevalex { set x end- - list [catch { eval [list $lindex {a b c} $x] } result] $result + list [catch { testevalex {lindex {a b c} $x} } result] $result } "1 {bad index \"end-\": must be integer or end?-integer?}" -test lindex-5.1 {bad second index} { - list [catch { eval [list $lindex {a b c} 0 0a2] } result] $result +test lindex-5.1 {bad second index} testevalex { + list [catch { testevalex {lindex {a b c} 0 0a2} } result] $result } "1 {bad index \"0a2\": must be integer or end?-integer?}" -test lindex-5.2 {good second index} { - eval [list $lindex {{a b c} {d e f} {g h i}} 1 2] +test lindex-5.2 {good second index} testevalex { + testevalex {lindex {{a b c} {d e f} {g h i}} 1 2} } f -test lindex-5.3 {three indices} { - eval [list $lindex {{{a b} {c d}} {{e f} {g h}}} 1 0 1] +test lindex-5.3 {three indices} testevalex { + testevalex {lindex {{{a b} {c d}} {{e f} {g h}}} 1 0 1} } f -test lindex-6.1 {error conditions in parsing list} { - list [catch {eval [list $lindex "a \{" 2]} msg] $msg +test lindex-6.1 {error conditions in parsing list} testevalex { + list [catch {testevalex {lindex "a \{" 2}} msg] $msg } {1 {unmatched open brace in list}} -test lindex-6.2 {error conditions in parsing list} { - list [catch {eval [list $lindex {a {b c}d e} 2]} msg] $msg +test lindex-6.2 {error conditions in parsing list} testevalex { + list [catch {testevalex {lindex {a {b c}d e} 2}} msg] $msg } {1 {list element in braces followed by "d" instead of space}} -test lindex-6.3 {error conditions in parsing list} { - list [catch {eval [list $lindex {a "b c"def ghi} 2]} msg] $msg +test lindex-6.3 {error conditions in parsing list} testevalex { + list [catch {testevalex {lindex {a "b c"def ghi} 2}} msg] $msg } {1 {list element in quotes followed by "def" instead of space}} -test lindex-7.1 {quoted elements} { - eval [list $lindex {a "b c" d} 1] +test lindex-7.1 {quoted elements} testevalex { + testevalex {lindex {a "b c" d} 1} } {b c} -test lindex-7.2 {quoted elements} { - eval [list $lindex {"{}" b c} 0] +test lindex-7.2 {quoted elements} testevalex { + testevalex {lindex {"{}" b c} 0} } {{}} -test lindex-7.3 {quoted elements} { - eval [list $lindex {ab "c d \" x" y} 1] +test lindex-7.3 {quoted elements} testevalex { + testevalex {lindex {ab "c d \" x" y} 1} } {c d " x} test lindex-7.4 {quoted elements} { lindex {a b {c d "e} {f g"}} 2 } {c d "e} -test lindex-8.1 {data reuse} { +test lindex-8.1 {data reuse} testevalex { set x 0 - eval [list $lindex $x $x] + testevalex {lindex $x $x} } {0} -test lindex-8.2 {data reuse} { +test lindex-8.2 {data reuse} testevalex { set a 0 - eval [list $lindex $a $a $a] + testevalex {lindex $a $a $a} } 0 -test lindex-8.3 {data reuse} { +test lindex-8.3 {data reuse} testevalex { set a 1 - eval [list $lindex $a $a $a] + testevalex {lindex $a $a $a} } {} -test lindex-8.4 {data reuse} { +test lindex-8.4 {data reuse} testevalex { set x [list 0 0] - eval [list $lindex $x $x] + testevalex {lindex $x $x} } {0} -test lindex-8.5 {data reuse} { +test lindex-8.5 {data reuse} testevalex { set x 0 - eval [list $lindex $x [list $x $x]] + testevalex {lindex $x [list $x $x]} } {0} -test lindex-8.6 {data reuse} { +test lindex-8.6 {data reuse} testevalex { set x [list 1 1] - eval [list $lindex $x $x] + testevalex {lindex $x $x} } {} -test lindex-8.7 {data reuse} { +test lindex-8.7 {data reuse} testevalex { set x 1 - eval [list lindex $x [list $x $x]] + testevalex {lindex $x [list $x $x]} } {} #---------------------------------------------------------------------- @@ -469,7 +469,6 @@ test lindex-16.7 {data reuse} { set result } {} -catch { unset lindex} catch { unset minus } # cleanup diff --git a/tests/lset.test b/tests/lset.test index 6bf412f..048e9ba 100644 --- a/tests/lset.test +++ b/tests/lset.test @@ -22,427 +22,427 @@ proc failTrace {name1 name2 op} { error "trace failed" } -set lset lset +testConstraint testevalex [llength [info commands testevalex]] set noRead {} trace add variable noRead read failTrace set noWrite {a b c} trace add variable noWrite write failTrace -test lset-1.1 {lset, not compiled, arg count} { - list [catch {eval $lset} msg] $msg +test lset-1.1 {lset, not compiled, arg count} testevalex { + list [catch {testevalex lset} msg] $msg } "1 {wrong \# args: should be \"lset listVar index ?index...? value\"}" -test lset-1.2 {lset, not compiled, no such var} { - list [catch {eval [list $lset noSuchVar 0 {}]} msg] $msg +test lset-1.2 {lset, not compiled, no such var} testevalex { + list [catch {testevalex {lset noSuchVar 0 {}}} msg] $msg } "1 {can't read \"noSuchVar\": no such variable}" -test lset-1.3 {lset, not compiled, var not readable} { - list [catch {eval [list $lset noRead 0 {}]} msg] $msg +test lset-1.3 {lset, not compiled, var not readable} testevalex { + list [catch {testevalex {lset noRead 0 {}}} msg] $msg } "1 {can't read \"noRead\": trace failed}" -test lset-2.1 {lset, not compiled, 3 args, second arg a plain index} { +test lset-2.1 {lset, not compiled, 3 args, second arg a plain index} testevalex { set x {0 1 2} - list [eval [list $lset x 0 3]] $x + list [testevalex {lset x 0 3}] $x } {{3 1 2} {3 1 2}} -test lset-2.2 {lset, not compiled, 3 args, second arg neither index nor list} { +test lset-2.2 {lset, not compiled, 3 args, second arg neither index nor list} testevalex { set x {0 1 2} list [catch { - eval [list $lset x {{bad}1} 3] + testevalex {lset x {{bad}1} 3} } msg] $msg } "1 {bad index \"{bad}1\": must be integer or end?-integer?}" -test lset-3.1 {lset, not compiled, 3 args, data duplicated} { +test lset-3.1 {lset, not compiled, 3 args, data duplicated} testevalex { set x {0 1 2} - list [eval [list $lset x 0 $x]] $x + list [testevalex {lset x 0 $x}] $x } {{{0 1 2} 1 2} {{0 1 2} 1 2}} -test lset-3.2 {lset, not compiled, 3 args, data duplicated} { +test lset-3.2 {lset, not compiled, 3 args, data duplicated} testevalex { set x {0 1} set y $x - list [eval [list $lset x 0 2]] $x $y + list [testevalex {lset x 0 2}] $x $y } {{2 1} {2 1} {0 1}} -test lset-3.3 {lset, not compiled, 3 args, data duplicated} { +test lset-3.3 {lset, not compiled, 3 args, data duplicated} testevalex { set x {0 1} set y $x - list [eval [list $lset x 0 $x]] $x $y + list [testevalex {lset x 0 $x}] $x $y } {{{0 1} 1} {{0 1} 1} {0 1}} -test lset-3.4 {lset, not compiled, 3 args, data duplicated} { +test lset-3.4 {lset, not compiled, 3 args, data duplicated} testevalex { set x {0 1 2} - list [eval [list $lset x [list 0] $x]] $x + list [testevalex {lset x [list 0] $x}] $x } {{{0 1 2} 1 2} {{0 1 2} 1 2}} -test lset-3.5 {lset, not compiled, 3 args, data duplicated} { +test lset-3.5 {lset, not compiled, 3 args, data duplicated} testevalex { set x {0 1} set y $x - list [eval [list $lset x [list 0] 2]] $x $y + list [testevalex {lset x [list 0] 2}] $x $y } {{2 1} {2 1} {0 1}} -test lset-3.6 {lset, not compiled, 3 args, data duplicated} { +test lset-3.6 {lset, not compiled, 3 args, data duplicated} testevalex { set x {0 1} set y $x - list [eval [list $lset x [list 0] $x]] $x $y + list [testevalex {lset x [list 0] $x}] $x $y } {{{0 1} 1} {{0 1} 1} {0 1}} -test lset-4.1 {lset, not compiled, 3 args, not a list} { +test lset-4.1 {lset, not compiled, 3 args, not a list} testevalex { set a "x \{" list [catch { - eval [list $lset a [list 0] y] + testevalex {lset a [list 0] y} } msg] $msg } {1 {unmatched open brace in list}} -test lset-4.2 {lset, not compiled, 3 args, bad index} { +test lset-4.2 {lset, not compiled, 3 args, bad index} testevalex { set a {x y z} list [catch { - eval [list $lset a [list 2a2] w] + testevalex {lset a [list 2a2] w} } msg] $msg } {1 {bad index "2a2": must be integer or end?-integer?}} -test lset-4.3 {lset, not compiled, 3 args, index out of range} { +test lset-4.3 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { - eval [list $lset a [list -1] w] + testevalex {lset a [list -1] w} } msg] $msg } {1 {list index out of range}} -test lset-4.4 {lset, not compiled, 3 args, index out of range} { +test lset-4.4 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { - eval [list $lset a [list 3] w] + testevalex {lset a [list 3] w} } msg] $msg } {1 {list index out of range}} -test lset-4.5 {lset, not compiled, 3 args, index out of range} { +test lset-4.5 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { - eval [list $lset a [list end--1] w] + testevalex {lset a [list end--1] w} } msg] $msg } {1 {list index out of range}} -test lset-4.6 {lset, not compiled, 3 args, index out of range} { +test lset-4.6 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { - eval [list $lset a [list end-3] w] + testevalex {lset a [list end-3] w} } msg] $msg } {1 {list index out of range}} -test lset-4.7 {lset, not compiled, 3 args, not a list} { +test lset-4.7 {lset, not compiled, 3 args, not a list} testevalex { set a "x \{" list [catch { - eval [list $lset a 0 y] + testevalex {lset a 0 y} } msg] $msg } {1 {unmatched open brace in list}} -test lset-4.8 {lset, not compiled, 3 args, bad index} { +test lset-4.8 {lset, not compiled, 3 args, bad index} testevalex { set a {x y z} list [catch { - eval [list $lset a 2a2 w] + testevalex {lset a 2a2 w} } msg] $msg } {1 {bad index "2a2": must be integer or end?-integer?}} -test lset-4.9 {lset, not compiled, 3 args, index out of range} { +test lset-4.9 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { - eval [list $lset a -1 w] + testevalex {lset a -1 w} } msg] $msg } {1 {list index out of range}} -test lset-4.10 {lset, not compiled, 3 args, index out of range} { +test lset-4.10 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { - eval [list $lset a 3 w] + testevalex {lset a 3 w} } msg] $msg } {1 {list index out of range}} -test lset-4.11 {lset, not compiled, 3 args, index out of range} { +test lset-4.11 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { - eval [list $lset a end--1 w] + testevalex {lset a end--1 w} } msg] $msg } {1 {list index out of range}} -test lset-4.12 {lset, not compiled, 3 args, index out of range} { +test lset-4.12 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { - eval [list $lset a end-3 w] + testevalex {lset a end-3 w} } msg] $msg } {1 {list index out of range}} -test lset-5.1 {lset, not compiled, 3 args, can't set variable} { +test lset-5.1 {lset, not compiled, 3 args, can't set variable} testevalex { list [catch { - eval [list $lset noWrite 0 d] + testevalex {lset noWrite 0 d} } msg] $msg $noWrite } {1 {can't set "noWrite": trace failed} {d b c}} -test lset-5.2 {lset, not compiled, 3 args, can't set variable} { +test lset-5.2 {lset, not compiled, 3 args, can't set variable} testevalex { list [catch { - eval [list $lset noWrite [list 0] d] + testevalex {lset noWrite [list 0] d} } msg] $msg $noWrite } {1 {can't set "noWrite": trace failed} {d b c}} -test lset-6.1 {lset, not compiled, 3 args, 1-d list basics} { +test lset-6.1 {lset, not compiled, 3 args, 1-d list basics} testevalex { set a {x y z} - list [eval [list $lset a 0 a]] $a + list [testevalex {lset a 0 a}] $a } {{a y z} {a y z}} -test lset-6.2 {lset, not compiled, 3 args, 1-d list basics} { +test lset-6.2 {lset, not compiled, 3 args, 1-d list basics} testevalex { set a {x y z} - list [eval [list $lset a [list 0] a]] $a + list [testevalex {lset a [list 0] a}] $a } {{a y z} {a y z}} -test lset-6.3 {lset, not compiled, 1-d list basics} { +test lset-6.3 {lset, not compiled, 1-d list basics} testevalex { set a {x y z} - list [eval [list $lset a 2 a]] $a + list [testevalex {lset a 2 a}] $a } {{x y a} {x y a}} -test lset-6.4 {lset, not compiled, 1-d list basics} { +test lset-6.4 {lset, not compiled, 1-d list basics} testevalex { set a {x y z} - list [eval [list $lset a [list 2] a]] $a + list [testevalex {lset a [list 2] a}] $a } {{x y a} {x y a}} -test lset-6.5 {lset, not compiled, 1-d list basics} { +test lset-6.5 {lset, not compiled, 1-d list basics} testevalex { set a {x y z} - list [eval [list $lset a end a]] $a + list [testevalex {lset a end a}] $a } {{x y a} {x y a}} -test lset-6.6 {lset, not compiled, 1-d list basics} { +test lset-6.6 {lset, not compiled, 1-d list basics} testevalex { set a {x y z} - list [eval [list $lset a [list end] a]] $a + list [testevalex {lset a [list end] a}] $a } {{x y a} {x y a}} -test lset-6.7 {lset, not compiled, 1-d list basics} { +test lset-6.7 {lset, not compiled, 1-d list basics} testevalex { set a {x y z} - list [eval [list $lset a end-0 a]] $a + list [testevalex {lset a end-0 a}] $a } {{x y a} {x y a}} -test lset-6.8 {lset, not compiled, 1-d list basics} { +test lset-6.8 {lset, not compiled, 1-d list basics} testevalex { set a {x y z} - list [eval [list $lset a [list end-0] a]] $a + list [testevalex {lset a [list end-0] a}] $a } {{x y a} {x y a}} -test lset-6.9 {lset, not compiled, 1-d list basics} { +test lset-6.9 {lset, not compiled, 1-d list basics} testevalex { set a {x y z} - list [eval [list $lset a end-2 a]] $a + list [testevalex {lset a end-2 a}] $a } {{a y z} {a y z}} -test lset-6.10 {lset, not compiled, 1-d list basics} { +test lset-6.10 {lset, not compiled, 1-d list basics} testevalex { set a {x y z} - list [eval [list $lset a [list end-2] a]] $a + list [testevalex {lset a [list end-2] a}] $a } {{a y z} {a y z}} -test lset-7.1 {lset, not compiled, data sharing} { +test lset-7.1 {lset, not compiled, data sharing} testevalex { set a 0 - list [eval [list $lset a $a {gag me}]] $a + list [testevalex {lset a $a {gag me}}] $a } {{{gag me}} {{gag me}}} -test lset-7.2 {lset, not compiled, data sharing} { +test lset-7.2 {lset, not compiled, data sharing} testevalex { set a [list 0] - list [eval [list $lset a $a {gag me}]] $a + list [testevalex {lset a $a {gag me}}] $a } {{{gag me}} {{gag me}}} -test lset-7.3 {lset, not compiled, data sharing} { +test lset-7.3 {lset, not compiled, data sharing} testevalex { set a {x y} - list [eval [list $lset a 0 $a]] $a + list [testevalex {lset a 0 $a}] $a } {{{x y} y} {{x y} y}} -test lset-7.4 {lset, not compiled, data sharing} { +test lset-7.4 {lset, not compiled, data sharing} testevalex { set a {x y} - list [eval [list $lset a [list 0] $a]] $a + list [testevalex {lset a [list 0] $a}] $a } {{{x y} y} {{x y} y}} -test lset-7.5 {lset, not compiled, data sharing} { +test lset-7.5 {lset, not compiled, data sharing} testevalex { set n 0 set a {x y} - list [eval [list $lset a $n $n]] $a $n + list [testevalex {lset a $n $n}] $a $n } {{0 y} {0 y} 0} -test lset-7.6 {lset, not compiled, data sharing} { +test lset-7.6 {lset, not compiled, data sharing} testevalex { set n [list 0] set a {x y} - list [eval [list $lset a $n $n]] $a $n + list [testevalex {lset a $n $n}] $a $n } {{0 y} {0 y} 0} -test lset-7.7 {lset, not compiled, data sharing} { +test lset-7.7 {lset, not compiled, data sharing} testevalex { set n 0 set a [list $n $n] - list [eval [list $lset a $n 1]] $a $n + list [testevalex {lset a $n 1}] $a $n } {{1 0} {1 0} 0} -test lset-7.8 {lset, not compiled, data sharing} { +test lset-7.8 {lset, not compiled, data sharing} testevalex { set n [list 0] set a [list $n $n] - list [eval [list $lset a $n 1]] $a $n + list [testevalex {lset a $n 1}] $a $n } {{1 0} {1 0} 0} -test lset-7.9 {lset, not compiled, data sharing} { +test lset-7.9 {lset, not compiled, data sharing} testevalex { set a 0 - list [eval [list $lset a $a $a]] $a + list [testevalex {lset a $a $a}] $a } {0 0} -test lset-7.10 {lset, not compiled, data sharing} { +test lset-7.10 {lset, not compiled, data sharing} testevalex { set a [list 0] - list [eval [list $lset a $a $a]] $a + list [testevalex {lset a $a $a}] $a } {0 0} -test lset-8.1 {lset, not compiled, malformed sublist} { +test lset-8.1 {lset, not compiled, malformed sublist} testevalex { set a [list "a \{" b] - list [catch {eval [list $lset a 0 1 c]} msg] $msg + list [catch {testevalex {lset a 0 1 c}} msg] $msg } {1 {unmatched open brace in list}} -test lset-8.2 {lset, not compiled, malformed sublist} { +test lset-8.2 {lset, not compiled, malformed sublist} testevalex { set a [list "a \{" b] - list [catch {eval [list $lset a {0 1} c]} msg] $msg + list [catch {testevalex {lset a {0 1} c}} msg] $msg } {1 {unmatched open brace in list}} -test lset-8.3 {lset, not compiled, bad second index} { +test lset-8.3 {lset, not compiled, bad second index} testevalex { set a {{b c} {d e}} - list [catch {eval [list $lset a 0 2a2 f]} msg] $msg + list [catch {testevalex {lset a 0 2a2 f}} msg] $msg } {1 {bad index "2a2": must be integer or end?-integer?}} -test lset-8.4 {lset, not compiled, bad second index} { +test lset-8.4 {lset, not compiled, bad second index} testevalex { set a {{b c} {d e}} - list [catch {eval [list $lset a {0 2a2} f]} msg] $msg + list [catch {testevalex {lset a {0 2a2} f}} msg] $msg } {1 {bad index "2a2": must be integer or end?-integer?}} -test lset-8.5 {lset, not compiled, second index out of range} { +test lset-8.5 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} - list [catch {eval [list $lset a 2 -1 h]} msg] $msg + list [catch {testevalex {lset a 2 -1 h}} msg] $msg } {1 {list index out of range}} -test lset-8.6 {lset, not compiled, second index out of range} { +test lset-8.6 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} - list [catch {eval [list $lset a {2 -1} h]} msg] $msg + list [catch {testevalex {lset a {2 -1} h}} msg] $msg } {1 {list index out of range}} -test lset-8.7 {lset, not compiled, second index out of range} { +test lset-8.7 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} - list [catch {eval [list $lset a 2 2 h]} msg] $msg + list [catch {testevalex {lset a 2 2 h}} msg] $msg } {1 {list index out of range}} -test lset-8.8 {lset, not compiled, second index out of range} { +test lset-8.8 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} - list [catch {eval [list $lset a {2 2} h]} msg] $msg + list [catch {testevalex {lset a {2 2} h}} msg] $msg } {1 {list index out of range}} -test lset-8.9 {lset, not compiled, second index out of range} { +test lset-8.9 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} - list [catch {eval [list $lset a 2 end--1 h]} msg] $msg + list [catch {testevalex {lset a 2 end--1 h}} msg] $msg } {1 {list index out of range}} -test lset-8.10 {lset, not compiled, second index out of range} { +test lset-8.10 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} - list [catch {eval [list $lset a {2 end--1} h]} msg] $msg + list [catch {testevalex {lset a {2 end--1} h}} msg] $msg } {1 {list index out of range}} -test lset-8.11 {lset, not compiled, second index out of range} { +test lset-8.11 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} - list [catch {eval [list $lset a 2 end-2 h]} msg] $msg + list [catch {testevalex {lset a 2 end-2 h}} msg] $msg } {1 {list index out of range}} -test lset-8.12 {lset, not compiled, second index out of range} { +test lset-8.12 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} - list [catch {eval [list $lset a {2 end-2} h]} msg] $msg + list [catch {testevalex {lset a {2 end-2} h}} msg] $msg } {1 {list index out of range}} -test lset-9.1 {lset, not compiled, entire variable} { +test lset-9.1 {lset, not compiled, entire variable} testevalex { set a x - list [eval [list $lset a y]] $a + list [testevalex {lset a y}] $a } {y y} -test lset-9.2 {lset, not compiled, entire variable} { +test lset-9.2 {lset, not compiled, entire variable} testevalex { set a x - list [eval [list $lset a {} y]] $a + list [testevalex {lset a {} y}] $a } {y y} -test lset-10.1 {lset, not compiled, shared data} { +test lset-10.1 {lset, not compiled, shared data} testevalex { set row {p q} set a [list $row $row] - list [eval [list $lset a 0 0 x]] $a + list [testevalex {lset a 0 0 x}] $a } {{{x q} {p q}} {{x q} {p q}}} -test lset-10.2 {lset, not compiled, shared data} { +test lset-10.2 {lset, not compiled, shared data} testevalex { set row {p q} set a [list $row $row] - list [eval [list $lset a {0 0} x]] $a + list [testevalex {lset a {0 0} x}] $a } {{{x q} {p q}} {{x q} {p q}}} -test lset-11.1 {lset, not compiled, 2-d basics} { +test lset-11.1 {lset, not compiled, 2-d basics} testevalex { set a {{b c} {d e}} - list [eval [list $lset a 0 0 f]] $a + list [testevalex {lset a 0 0 f}] $a } {{{f c} {d e}} {{f c} {d e}}} -test lset-11.2 {lset, not compiled, 2-d basics} { +test lset-11.2 {lset, not compiled, 2-d basics} testevalex { set a {{b c} {d e}} - list [eval [list $lset a {0 0} f]] $a + list [testevalex {lset a {0 0} f}] $a } {{{f c} {d e}} {{f c} {d e}}} -test lset-11.3 {lset, not compiled, 2-d basics} { +test lset-11.3 {lset, not compiled, 2-d basics} testevalex { set a {{b c} {d e}} - list [eval [list $lset a 0 1 f]] $a + list [testevalex {lset a 0 1 f}] $a } {{{b f} {d e}} {{b f} {d e}}} -test lset-11.4 {lset, not compiled, 2-d basics} { +test lset-11.4 {lset, not compiled, 2-d basics} testevalex { set a {{b c} {d e}} - list [eval [list $lset a {0 1} f]] $a + list [testevalex {lset a {0 1} f}] $a } {{{b f} {d e}} {{b f} {d e}}} -test lset-11.5 {lset, not compiled, 2-d basics} { +test lset-11.5 {lset, not compiled, 2-d basics} testevalex { set a {{b c} {d e}} - list [eval [list $lset a 1 0 f]] $a + list [testevalex {lset a 1 0 f}] $a } {{{b c} {f e}} {{b c} {f e}}} -test lset-11.6 {lset, not compiled, 2-d basics} { +test lset-11.6 {lset, not compiled, 2-d basics} testevalex { set a {{b c} {d e}} - list [eval [list $lset a {1 0} f]] $a + list [testevalex {lset a {1 0} f}] $a } {{{b c} {f e}} {{b c} {f e}}} -test lset-11.7 {lset, not compiled, 2-d basics} { +test lset-11.7 {lset, not compiled, 2-d basics} testevalex { set a {{b c} {d e}} - list [eval [list $lset a 1 1 f]] $a + list [testevalex {lset a 1 1 f}] $a } {{{b c} {d f}} {{b c} {d f}}} -test lset-11.8 {lset, not compiled, 2-d basics} { +test lset-11.8 {lset, not compiled, 2-d basics} testevalex { set a {{b c} {d e}} - list [eval [list $lset a {1 1} f]] $a + list [testevalex {lset a {1 1} f}] $a } {{{b c} {d f}} {{b c} {d f}}} -test lset-12.0 {lset, not compiled, typical sharing pattern} { +test lset-12.0 {lset, not compiled, typical sharing pattern} testevalex { set zero 0 set row [list $zero $zero $zero $zero] set ident [list $row $row $row $row] for { set i 0 } { $i < 4 } { incr i } { - eval [list $lset ident $i $i 1] + testevalex {lset ident $i $i 1} } set ident } {{1 0 0 0} {0 1 0 0} {0 0 1 0} {0 0 0 1}} -test lset-13.0 {lset, not compiled, shimmering hell} { +test lset-13.0 {lset, not compiled, shimmering hell} testevalex { set a 0 - list [eval [list $lset a $a $a $a $a {gag me}]] $a + list [testevalex {lset a $a $a $a $a {gag me}}] $a } {{{{{{gag me}}}}} {{{{{gag me}}}}}} -test lset-13.1 {lset, not compiled, shimmering hell} { +test lset-13.1 {lset, not compiled, shimmering hell} testevalex { set a [list 0] - list [eval [list $lset a $a $a $a $a {gag me}]] $a + list [testevalex {lset a $a $a $a $a {gag me}}] $a } {{{{{{gag me}}}}} {{{{{gag me}}}}}} -test lset-13.2 {lset, not compiled, shimmering hell} { +test lset-13.2 {lset, not compiled, shimmering hell} testevalex { set a [list 0 0 0 0] - list [eval [list $lset a $a {gag me}]] $a + list [testevalex {lset a $a {gag me}}] $a } {{{{{{gag me}}}} 0 0 0} {{{{{gag me}}}} 0 0 0}} -test lset-14.1 {lset, not compiled, list args, is string rep preserved?} { +test lset-14.1 {lset, not compiled, list args, is string rep preserved?} testevalex { set a { { 1 2 } { 3 4 } } - catch { eval [list $lset a {1 5} 5] } + catch { testevalex {lset a {1 5} 5} } list $a [lindex $a 1] } "{ { 1 2 } { 3 4 } } { 3 4 }" -test lset-14.2 {lset, not compiled, flat args, is string rep preserved?} { +test lset-14.2 {lset, not compiled, flat args, is string rep preserved?} testevalex { set a { { 1 2 } { 3 4 } } - catch { eval [list $lset a 1 5 5] } + catch { testevalex {lset a 1 5 5} } list $a [lindex $a 1] } "{ { 1 2 } { 3 4 } } { 3 4 }" diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 5137051..fd51099 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -14,7 +14,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: namespace-old.test,v 1.6 2001/04/07 02:11:19 msofer Exp $ +# RCS: @(#) $Id: namespace-old.test,v 1.7 2003/11/14 20:44:46 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -22,7 +22,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } # Clear out any namespaces called test_ns_* -catch {eval namespace delete [namespace children :: test_ns_*]} +catch {namespace delete {expand}[namespace children :: test_ns_*]} test namespace-old-1.1 {usage for "namespace" command} { list [catch {namespace} msg] $msg @@ -251,8 +251,8 @@ test namespace-old-4.3 {command "namespace delete" doesn't support patterns} { test namespace-old-4.4 {command "namespace delete" handles multiple args} { set cmd { namespace eval test_ns_delete { - eval namespace delete \ - [namespace children [namespace current] ns?] + namespace delete \ + {expand}[namespace children [namespace current] ns?] } } list [catch $cmd msg] $msg [namespace children test_ns_delete] diff --git a/tests/namespace.test b/tests/namespace.test index 0a9343c..72a2f33 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -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: namespace.test,v 1.22 2003/09/29 14:37:14 dkf Exp $ +# RCS: @(#) $Id: namespace.test,v 1.23 2003/11/14 20:44:46 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -19,7 +19,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } # Clear out any namespaces called test_ns_* -catch {eval namespace delete [namespace children :: test_ns_*]} +catch {namespace delete {expand}[namespace children :: test_ns_*]} test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} { namespace children :: test_ns_* @@ -79,7 +79,7 @@ test namespace-5.2 {Tcl_PopCallFrame, local vars must be deleted} { } {123} test namespace-6.1 {Tcl_CreateNamespace} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [lsort [namespace children :: test_ns_*]] \ [namespace eval test_ns_1 {namespace current}] \ [namespace eval test_ns_2 {namespace current}] \ @@ -98,7 +98,7 @@ test namespace-6.3 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} { list [catch {namespace eval test_ns_7::: {namespace current}} msg] $msg } {0 ::test_ns_7} test namespace-6.4 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1:: { namespace eval test_ns_2:: {} namespace eval test_ns_3:: {} @@ -116,7 +116,7 @@ test namespace-6.5 {Tcl_CreateNamespace, relative ns names now only looked up in } {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_2} test namespace-7.1 {Tcl_DeleteNamespace, active call frames in ns} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1 { proc p {} { namespace delete [namespace current] @@ -161,7 +161,7 @@ test namespace-8.1 {TclTeardownNamespace, delete global namespace} { [interp delete test_interp] } {{::test_ns_1 27} {} 1 {invalid command name "set"} {}} test namespace-8.2 {TclTeardownNamespace, remove deleted ns from parent} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1::test_ns_2::test_ns_3a {proc p {} {}} namespace eval test_ns_1::test_ns_2::test_ns_3b {proc q {} {}} list [namespace children test_ns_1] \ @@ -169,7 +169,7 @@ test namespace-8.2 {TclTeardownNamespace, remove deleted ns from parent} { [namespace children test_ns_1] } {::test_ns_1::test_ns_2 {} {}} test namespace-8.3 {TclTeardownNamespace, delete child namespaces} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1::test_ns_2::test_ns_3a {proc p {} {}} namespace eval test_ns_1::test_ns_2::test_ns_3b {proc q {} {}} list [namespace children test_ns_1] \ @@ -179,7 +179,7 @@ test namespace-8.3 {TclTeardownNamespace, delete child namespaces} { [info commands test_ns_1::test_ns_2::test_ns_3a::*] } {::test_ns_1::test_ns_2 {} {} 1 {unknown namespace "test_ns_1::test_ns_2" in namespace children command} {}} test namespace-8.4 {TclTeardownNamespace, cmds imported from deleted ns go away} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_export { namespace export cmd1 cmd2 proc cmd1 {args} {return "cmd1: $args"} @@ -195,7 +195,7 @@ test namespace-8.4 {TclTeardownNamespace, cmds imported from deleted ns go away} } [list [lsort {::test_ns_import::p ::test_ns_import::cmd1 ::test_ns_import::cmd2}] {} ::test_ns_import::p] test namespace-9.1 {Tcl_Import, empty import pattern} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace eval test_ns_import {namespace import {}}} msg] $msg } {1 {empty import pattern}} test namespace-9.2 {Tcl_Import, unknown namespace in import pattern} { @@ -205,7 +205,7 @@ test namespace-9.3 {Tcl_Import, import ns == export ns} { list [catch {namespace eval test_ns_import {namespace import ::test_ns_import::puts}} msg] $msg } {1 {import pattern "::test_ns_import::puts" tries to import from namespace "test_ns_import" into itself}} test namespace-9.4 {Tcl_Import, simple import} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_export { namespace export cmd1 proc cmd1 {args} {return "cmd1: $args"} @@ -227,7 +227,7 @@ test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} { } } {cmd1: 555} test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_export { namespace export cmd1 proc cmd1 {args} {return "cmd1: $args"} @@ -245,7 +245,7 @@ test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} { } {{cmd1: a b c} {cmd1: d e f} {} ::test_ns_export::cmd1 ::test_ns_export::cmd1 {new1: g h i} {new1: j k l}} test namespace-10.1 {Tcl_ForgetImport, check for valid namespaces} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace forget xyzzy::*} msg] $msg } {1 {unknown namespace in namespace forget pattern "xyzzy::*"}} test namespace-10.2 {Tcl_ForgetImport, ignores patterns that don't match} { @@ -271,7 +271,7 @@ test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} { } [list [lsort {::test_ns_import::p ::test_ns_import::cmd1}] ::test_ns_import::p 1 {invalid command name "cmd1"}] test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_export { namespace export cmd1 proc cmd1 {args} {return "cmd1: $args"} @@ -295,7 +295,7 @@ test namespace-11.3 {TclGetOriginalCommand, indirectly imported cmd} { } {{cmd1: 123} ::test_ns_export::cmd1} test namespace-12.1 {InvokeImportedCmd} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_export { namespace export cmd1 proc cmd1 {args} {namespace current} @@ -316,7 +316,7 @@ test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} { } {::test_ns_import::cmd1 {}} test namespace-14.1 {TclGetNamespaceForQualName, absolute names} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} variable v 10 namespace eval test_ns_1::test_ns_2 { variable v 20 @@ -394,7 +394,7 @@ test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for lappend l [test_ns_1::test_ns_2:: hello] } {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}} test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1 { variable {} set test_ns_1::(x) y @@ -402,12 +402,12 @@ test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for set test_ns_1::(x) } y test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace eval test_ns_1 {proc {} {} {}; namespace eval {} {}; {}}} msg] $msg } {1 {can't create namespace "": only global namespace can have empty name}} test namespace-15.1 {Tcl_FindNamespace, absolute name found} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_delete { namespace eval test_ns_delete2 {} proc cmd {args} {namespace current} @@ -434,7 +434,7 @@ test namespace-15.4 {Tcl_FindNamespace, relative name not found} { } {1 {unknown namespace "test_ns_delete2" in namespace delete command}} test namespace-16.1 {Tcl_FindCommand, absolute name found} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1 { proc cmd {args} {return "[namespace current]::cmd: $args"} variable v "::test_ns_1::cmd" @@ -502,7 +502,7 @@ test namespace-16.11 {Tcl_FindCommand, relative name not found} { catch {unset x} test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} set x 314159 namespace eval test_ns_1 { set ::x @@ -565,7 +565,7 @@ catch {unset x} catch {unset l} catch {rename foo {}} test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} proc foo {} {return "global foo"} namespace eval test_ns_1 { proc trigger {} { @@ -606,7 +606,7 @@ catch {unset l} catch {rename foo {}} test namespace-19.1 {GetNamespaceFromObj, global name found} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1::test_ns_2 {} namespace children ::test_ns_1 } {::test_ns_1::test_ns_2} @@ -636,7 +636,7 @@ test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} { } {{} ::test_ns_1::test_ns_2::test_ns_3} test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace} msg] $msg } {1 {wrong # args: should be "namespace subcommand ?arg ...?"}} test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} { @@ -647,7 +647,7 @@ test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} { } {} test namespace-21.1 {NamespaceChildrenCmd, no args} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1::test_ns_2 {} expr {[string first ::test_ns_1 [namespace children]] != -1} } {1} @@ -679,7 +679,7 @@ test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} { } [lsort {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo}] test namespace-22.1 {NamespaceCodeCmd, bad args} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace code} msg] $msg \ [catch {namespace code xxx yyy} msg] $msg } {1 {wrong # args: should be "namespace code arg"} 1 {wrong # args: should be "namespace code arg"}} @@ -713,7 +713,7 @@ test namespace-22.6 {NamespaceCodeCmd, in other namespace} { } {42} test namespace-23.1 {NamespaceCurrentCmd, bad args} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace current xxx} msg] $msg \ [catch {namespace current xxx yyy} msg] $msg } {1 {wrong # args: should be "namespace current"} 1 {wrong # args: should be "namespace current"}} @@ -727,7 +727,7 @@ test namespace-23.3 {NamespaceCurrentCmd, in nested ns} { } {::test_ns_1::test_ns_2} test namespace-24.1 {NamespaceDeleteCmd, no args} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace delete } {} test namespace-24.2 {NamespaceDeleteCmd, one arg} { @@ -743,7 +743,7 @@ test namespace-24.4 {NamespaceDeleteCmd, unknown ns} { } {1 {unknown namespace "::test_ns_foo" in namespace delete command}} test namespace-25.1 {NamespaceEvalCmd, bad args} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace eval} msg] $msg } {1 {wrong # args: should be "namespace eval name arg ?arg...?"}} test namespace-25.2 {NamespaceEvalCmd, bad args} { @@ -781,7 +781,7 @@ test namespace-25.6 {NamespaceEvalCmd, error in eval'd script} { catch {unset v} test namespace-26.1 {NamespaceExportCmd, no args and new ns} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace export } {} test namespace-26.2 {NamespaceExportCmd, just -clear arg} { @@ -830,7 +830,7 @@ test namespace-26.7 {NamespaceExportCmd, -clear resets export list} { } [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}] test namespace-27.1 {NamespaceForgetCmd, no args} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace forget } {} test namespace-27.2 {NamespaceForgetCmd, args must be valid namespaces} { @@ -850,7 +850,7 @@ test namespace-27.3 {NamespaceForgetCmd, arg is forgotten} { } {::test_ns_2::cmd2} test namespace-28.1 {NamespaceImportCmd, no args} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace import } {} test namespace-28.2 {NamespaceImportCmd, no args and just "-force"} { @@ -870,7 +870,7 @@ test namespace-28.3 {NamespaceImportCmd, arg is imported} { } {::test_ns_2::cmd2} test namespace-29.1 {NamespaceInscopeCmd, bad args} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace inscope} msg] $msg } {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}} test namespace-29.2 {NamespaceInscopeCmd, bad args} { @@ -895,7 +895,7 @@ test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} { } {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}} test namespace-30.1 {NamespaceOriginCmd, bad args} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace origin} msg] $msg } {1 {wrong # args: should be "namespace origin name"}} test namespace-30.2 {NamespaceOriginCmd, bad args} { @@ -928,7 +928,7 @@ test namespace-30.5 {NamespaceOriginCmd, imported command} { } {::foreach ::test_ns_2::p ::test_ns_1::cmd1 ::test_ns_1::cmd2} test namespace-31.1 {NamespaceParentCmd, bad args} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace parent a b} msg] $msg } {1 {wrong # args: should be "namespace parent ?name?"}} test namespace-31.2 {NamespaceParentCmd, no args} { @@ -949,7 +949,7 @@ test namespace-31.4 {NamespaceParentCmd, bad namespace specified} { } {1 {unknown namespace "test_ns_1::test_ns_foo" in namespace parent command}} test namespace-32.1 {NamespaceQualifiersCmd, bad args} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace qualifiers} msg] $msg } {1 {wrong # args: should be "namespace qualifiers string"}} test namespace-32.2 {NamespaceQualifiersCmd, bad args} { @@ -975,7 +975,7 @@ test namespace-32.8 {NamespaceQualifiersCmd, odd number of :s} { } {foo} test namespace-33.1 {NamespaceTailCmd, bad args} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace tail} msg] $msg } {1 {wrong # args: should be "namespace tail string"}} test namespace-33.2 {NamespaceTailCmd, bad args} { @@ -1001,7 +1001,7 @@ test namespace-33.8 {NamespaceTailCmd, odd number of :s} { } {} test namespace-34.1 {NamespaceWhichCmd, bad args} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {namespace which} msg] $msg } {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} test namespace-34.2 {NamespaceWhichCmd, bad args} { @@ -1054,7 +1054,7 @@ test namespace-34.7 {NamespaceWhichCmd, variable lookup} { } {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}} test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1 { proc p {} { namespace delete [namespace current] @@ -1077,7 +1077,7 @@ test namespace-35.2 {FreeNsNameInternalRep, resulting ref count == 0} { catch {unset x} catch {unset y} test namespace-36.1 {DupNsNameInternalRep} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1 {} set x "::test_ns_1" list [namespace parent $x] [set y $x] [namespace parent $y] @@ -1086,7 +1086,7 @@ catch {unset x} catch {unset y} test namespace-37.1 {SetNsNameFromAny, ns name found} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1::test_ns_2 {} namespace eval test_ns_1 { namespace children ::test_ns_1 @@ -1099,14 +1099,14 @@ test namespace-37.2 {SetNsNameFromAny, ns name not found} { } {1 {unknown namespace "::test_ns_1::test_ns_foo" in namespace children command}} test namespace-38.1 {UpdateStringOfNsName} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} ;# Tcl_NamespaceObjCmd calls UpdateStringOfNsName to get subcmd name list [namespace eval {} {namespace current}] \ [namespace eval {} {namespace current}] } {:: ::} test namespace-39.1 {NamespaceExistsCmd} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval ::test_ns_z::test_me { variable foo } list [namespace exists ::] \ [namespace exists ::bogus_namespace] \ @@ -1309,10 +1309,9 @@ set SETUP { namespace ensemble create -subcommands {b c} } } -test namespace-43.3 {ensembles: list-driven} { - eval $SETUP +test namespace-43.3 {ensembles: list-driven} -setup $SETUP -body { namespace delete ns -} {} +} -result {} test namespace-43.4 {ensembles: list-driven} -setup $SETUP -body { ns a foo bar boo spong wibble } -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "a": must be b, or c} @@ -1335,10 +1334,9 @@ set SETUP { namespace ensemble create -subcommands {b c} -map {c ::ns::d} } } -test namespace-43.8 {ensembles: list-and-map-driven} { - eval $SETUP +test namespace-43.8 {ensembles: list-and-map-driven} -setup $SETUP -body { namespace delete ns -} {} +} -result {} test namespace-43.9 {ensembles: list-and-map-driven} -setup $SETUP -body { ns a foo bar boo spong wibble } -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "a": must be b, or c} @@ -1359,10 +1357,9 @@ set SETUP { namespace ensemble create -prefixes off } } -test namespace-43.13 {ensembles: turn off prefixes} { - eval $SETUP +test namespace-43.13 {ensembles: turn off prefixes} -setup $SETUP -body { namespace delete ns -} {} +} -result {} test namespace-43.14 {ensembles: turn off prefixes} -setup $SETUP -body { ns fo } -cleanup {namespace delete ns} -returnCodes error -result {unknown subcommand "fo": must be foo, or spong} @@ -1636,6 +1633,6 @@ catch {rename cmd1 {}} catch {unset l} catch {unset msg} catch {unset trigger} -eval namespace delete [namespace children :: test_ns_*] +namespace delete {expand}[namespace children :: test_ns_*] ::tcltest::cleanupTests return diff --git a/tests/parse.test b/tests/parse.test index ee2a772..3a83af1 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -8,141 +8,148 @@ # 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.16 2003/07/24 16:05:24 dgp Exp $ +# RCS: @(#) $Id: parse.test,v 1.17 2003/11/14 20:44:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* +if {[catch {package require tcltest 2.0.2}]} { + puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." + return } -if {[info commands testparser] == {}} { - puts "This application hasn't been compiled with the \"testparser\"" - puts "command, so I can't test the Tcl parser." - ::tcltest::cleanupTests - return -} +namespace eval ::tcl::test::parse { + namespace import ::tcltest::test + namespace import ::tcltest::testConstraint + namespace import ::tcltest::cleanupTests + namespace import ::tcltest::bytestring + + testConstraint testparser [llength [info commands testparser]] + testConstraint testevalobjv [llength [info commands testevalobjv]] + testConstraint testevalex [llength [info commands testevalex]] + testConstraint testparsevarname [llength [info commands testparsevarname]] + testConstraint testparsevar [llength [info commands testparsevar]] + testConstraint testasync [llength [info commands testasync]] + testConstraint testcmdtrace [llength [info commands testcmdtrace]] -test parse-1.1 {Tcl_ParseCommand procedure, computing string length} { +test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} -test parse-1.2 {Tcl_ParseCommand procedure, computing string length} { +test parse-1.2 {Tcl_ParseCommand procedure, computing string length} testparser { testparser "foo bar" -1 } {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}} -test parse-1.3 {Tcl_ParseCommand procedure, leading space} { +test parse-1.3 {Tcl_ParseCommand procedure, leading space} testparser { testparser " \n\t foo" 0 } {- foo 1 simple foo 1 text foo 0 {}} -test parse-1.4 {Tcl_ParseCommand procedure, leading space} { +test parse-1.4 {Tcl_ParseCommand procedure, leading space} testparser { testparser "\f\r\vfoo" 0 } {- foo 1 simple foo 1 text foo 0 {}} -test parse-1.5 {Tcl_ParseCommand procedure, backslash-newline in leading space} { +test parse-1.5 {Tcl_ParseCommand procedure, backslash-newline in leading space} testparser { testparser " \\\n foo" 0 } {- foo 1 simple foo 1 text foo 0 {}} -test parse-1.6 {Tcl_ParseCommand procedure, backslash-newline in leading space} { +test parse-1.6 {Tcl_ParseCommand procedure, backslash-newline in leading space} testparser { testparser { \a foo} 0 } {- {\a foo} 2 word {\a} 1 backslash {\a} 0 simple foo 1 text foo 0 {}} -test parse-1.7 {Tcl_ParseCommand procedure, missing continuation line in leading space} { +test parse-1.7 {Tcl_ParseCommand procedure, missing continuation line in leading space} testparser { testparser " \\\n" 0 } {- {} 0 {}} -test parse-1.8 {Tcl_ParseCommand procedure, eof in leading space} { +test parse-1.8 {Tcl_ParseCommand procedure, eof in leading space} testparser { testparser " foo" 3 } {- {} 0 { foo}} -test parse-2.1 {Tcl_ParseCommand procedure, comments} { +test parse-2.1 {Tcl_ParseCommand procedure, comments} testparser { testparser "# foo bar\n foo" 0 } {{# foo bar } foo 1 simple foo 1 text foo 0 {}} -test parse-2.2 {Tcl_ParseCommand procedure, several comments} { +test parse-2.2 {Tcl_ParseCommand procedure, several comments} testparser { testparser " # foo bar\n # another comment\n\n foo" 0 } {{# foo bar # another comment } foo 1 simple foo 1 text foo 0 {}} -test parse-2.3 {Tcl_ParseCommand procedure, backslash-newline in comments} { +test parse-2.3 {Tcl_ParseCommand procedure, backslash-newline in comments} testparser { testparser " # foo bar\\\ncomment on continuation line\nfoo" 0 } {\#\ foo\ bar\\\ncomment\ on\ continuation\ line\n foo 1 simple foo 1 text foo 0 {}} -test parse-2.4 {Tcl_ParseCommand procedure, missing continuation line in comment} { +test parse-2.4 {Tcl_ParseCommand procedure, missing continuation line in comment} testparser { testparser "# \\\n" 0 } {\#\ \ \ \\\n {} 0 {}} -test parse-2.5 {Tcl_ParseCommand procedure, eof in comment} { +test parse-2.5 {Tcl_ParseCommand procedure, eof in comment} testparser { testparser " # foo bar\nfoo" 8 } {{# foo b} {} 0 {ar foo}} -test parse-3.1 {Tcl_ParseCommand procedure, parsing words, skipping space} { +test parse-3.1 {Tcl_ParseCommand procedure, parsing words, skipping space} testparser { testparser "foo bar\t\tx" 0 } {- {foo bar x} 3 simple foo 1 text foo 0 simple bar 1 text bar 0 simple x 1 text x 0 {}} -test parse-3.2 {Tcl_ParseCommand procedure, missing continuation line in leading space} { +test parse-3.2 {Tcl_ParseCommand procedure, missing continuation line in leading space} testparser { testparser "abc \\\n" 0 } {- abc\ \ \\\n 1 simple abc 1 text abc 0 {}} -test parse-3.3 {Tcl_ParseCommand procedure, parsing words, command ends in space} { +test parse-3.3 {Tcl_ParseCommand procedure, parsing words, command ends in space} testparser { testparser "foo ; bar x" 0 } {- {foo ;} 1 simple foo 1 text foo 0 { bar x}} -test parse-3.4 {Tcl_ParseCommand procedure, parsing words, command ends in space} { +test parse-3.4 {Tcl_ParseCommand procedure, parsing words, command ends in space} testparser { testparser "foo " 5 } {- {foo } 1 simple foo 1 text foo 0 { }} -test parse-3.5 {Tcl_ParseCommand procedure, quoted words} { +test parse-3.5 {Tcl_ParseCommand procedure, quoted words} testparser { testparser {foo "a b c" d "efg";} 0 } {- {foo "a b c" d "efg";} 4 simple foo 1 text foo 0 simple {"a b c"} 1 text {a b c} 0 simple d 1 text d 0 simple {"efg"} 1 text efg 0 {}} -test parse-3.6 {Tcl_ParseCommand procedure, words in braces} { +test parse-3.6 {Tcl_ParseCommand procedure, words in braces} testparser { testparser {foo {a $b [concat foo]} {c d}} 0 } {- {foo {a $b [concat foo]} {c d}} 3 simple foo 1 text foo 0 simple {{a $b [concat foo]}} 1 text {a $b [concat foo]} 0 simple {{c d}} 1 text {c d} 0 {}} -test parse-3.7 {Tcl_ParseCommand procedure, error in unquoted word} { +test parse-3.7 {Tcl_ParseCommand procedure, error in unquoted word} testparser { list [catch {testparser "foo \$\{abc" 0} msg] $msg $errorInfo } {1 {missing close-brace for variable name} missing\ close-brace\ for\ variable\ name\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\$\\\{abc\"\ 0\"} -test parse-4.1 {Tcl_ParseCommand procedure, simple words} { +test parse-4.1 {Tcl_ParseCommand procedure, simple words} testparser { testparser {foo} 0 } {- foo 1 simple foo 1 text foo 0 {}} -test parse-4.2 {Tcl_ParseCommand procedure, simple words} { +test parse-4.2 {Tcl_ParseCommand procedure, simple words} testparser { testparser {{abc}} 0 } {- {{abc}} 1 simple {{abc}} 1 text abc 0 {}} -test parse-4.3 {Tcl_ParseCommand procedure, simple words} { +test parse-4.3 {Tcl_ParseCommand procedure, simple words} testparser { testparser {"c d"} 0 } {- {"c d"} 1 simple {"c d"} 1 text {c d} 0 {}} -test parse-4.4 {Tcl_ParseCommand procedure, simple words} { +test parse-4.4 {Tcl_ParseCommand procedure, simple words} testparser { testparser {x$d} 0 } {- {x$d} 1 word {x$d} 3 text x 0 variable {$d} 1 text d 0 {}} -test parse-4.5 {Tcl_ParseCommand procedure, simple words} { +test parse-4.5 {Tcl_ParseCommand procedure, simple words} testparser { testparser {"a [foo] b"} 0 } {- {"a [foo] b"} 1 word {"a [foo] b"} 3 text {a } 0 command {[foo]} 0 text { b} 0 {}} -test parse-4.6 {Tcl_ParseCommand procedure, simple words} { +test parse-4.6 {Tcl_ParseCommand procedure, simple words} testparser { testparser {$x} 0 } {- {$x} 1 word {$x} 2 variable {$x} 1 text x 0 {}} -test parse-5.1 {Tcl_ParseCommand procedure, backslash-newline terminates word} { +test parse-5.1 {Tcl_ParseCommand procedure, backslash-newline terminates word} testparser { testparser "{abc}\\\n" 0 } {- \{abc\}\\\n 1 simple {{abc}} 1 text abc 0 {}} -test parse-5.2 {Tcl_ParseCommand procedure, backslash-newline terminates word} { +test parse-5.2 {Tcl_ParseCommand procedure, backslash-newline terminates word} testparser { testparser "foo\\\nbar" 0 } {- foo\\\nbar 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}} -test parse-5.3 {Tcl_ParseCommand procedure, word terminator is command terminator} { +test parse-5.3 {Tcl_ParseCommand procedure, word terminator is command terminator} testparser { testparser "foo\n bar" 0 } {- {foo } 1 simple foo 1 text foo 0 { bar}} -test parse-5.4 {Tcl_ParseCommand procedure, word terminator is command terminator} { +test parse-5.4 {Tcl_ParseCommand procedure, word terminator is command terminator} testparser { testparser "foo; bar" 0 } {- {foo;} 1 simple foo 1 text foo 0 { bar}} -test parse-5.5 {Tcl_ParseCommand procedure, word terminator is end of string} { +test parse-5.5 {Tcl_ParseCommand procedure, word terminator is end of string} testparser { testparser "\"foo\" bar" 5 } {- {"foo"} 1 simple {"foo"} 1 text foo 0 { bar}} -test parse-5.6 {Tcl_ParseCommand procedure, junk after close quote} { +test parse-5.6 {Tcl_ParseCommand procedure, junk after close quote} testparser { list [catch {testparser {foo "bar"x} 0} msg] $msg $errorInfo } {1 {extra characters after close-quote} {extra characters after close-quote (remainder of script: "x") invoked from within "testparser {foo "bar"x} 0"}} -test parse-5.7 {Tcl_ParseCommand procedure, backslash-newline after close quote} { +test parse-5.7 {Tcl_ParseCommand procedure, backslash-newline after close quote} testparser { testparser "foo \"bar\"\\\nx" 0 } {- foo\ \"bar\"\\\nx 3 simple foo 1 text foo 0 simple {"bar"} 1 text bar 0 simple x 1 text x 0 {}} -test parse-5.8 {Tcl_ParseCommand procedure, junk after close brace} { +test parse-5.8 {Tcl_ParseCommand procedure, junk after close brace} testparser { list [catch {testparser {foo {bar}x} 0} msg] $msg $errorInfo } {1 {extra characters after close-brace} {extra characters after close-brace (remainder of script: "x") invoked from within "testparser {foo {bar}x} 0"}} -test parse-5.9 {Tcl_ParseCommand procedure, backslash-newline after close brace} { +test parse-5.9 {Tcl_ParseCommand procedure, backslash-newline after close brace} testparser { testparser "foo {bar}\\\nx" 0 } {- foo\ \{bar\}\\\nx 3 simple foo 1 text foo 0 simple {{bar}} 1 text bar 0 simple x 1 text x 0 {}} -test parse-5.10 {Tcl_ParseCommand procedure, multiple deletion of non-static buffer} { +test parse-5.10 {Tcl_ParseCommand procedure, multiple deletion of non-static buffer} testparser { # This test is designed to catch bug 1681. list [catch {testparser "a \"\\1\\2\\3\\4\\5\\6\\7\\8\\9\\1\\2\\3\\4\\5\\6\\7\\8" 0} msg] $msg $errorInfo } "1 {missing \"} {missing \" @@ -150,25 +157,84 @@ test parse-5.10 {Tcl_ParseCommand procedure, multiple deletion of non-static buf invoked from within \"testparser \"a \\\"\\\\1\\\\2\\\\3\\\\4\\\\5\\\\6\\\\7\\\\8\\\\9\\\\1\\\\2\\\\3\\\\4\\\\5\\\\6\\\\7\\\\8\" 0\"}" -test parse-6.1 {ParseTokens procedure, empty word} { +test parse-5.11 {Tcl_ParseCommand: {expand} parsing} testparser { + testparser {{expan}} 0 +} {- {{expan}} 1 simple {{expan}} 1 text expan 0 {}} +test parse-5.12 {Tcl_ParseCommand: {expand} parsing} -constraints { + testparser +} -body { + testparser {{expan}x} 0 +} -returnCodes error -result {extra characters after close-brace} +test parse-5.13 {Tcl_ParseCommand: {expand} parsing} testparser { + testparser {{expandy}} 0 +} {- {{expandy}} 1 simple {{expandy}} 1 text expandy 0 {}} +test parse-5.14 {Tcl_ParseCommand: {expand} parsing} -constraints { + testparser +} -body { + testparser {{expandy}x} 0 +} -returnCodes error -result {extra characters after close-brace} +test parse-5.15 {Tcl_ParseCommand: {expand} parsing} -constraints { + testparser +} -body { + testparser {{expand}{123456}x} 0 +} -returnCodes error -result {extra characters after close-brace} +test parse-5.16 {Tcl_ParseCommand: {expand} parsing} testparser { + testparser {{123456\ + }} 0 +} {- {{123456 }} 1 simple {{123456 }} 1 text {123456 } 0 {}} +test parse-5.17 {Tcl_ParseCommand: {expand} parsing} -constraints { + testparser +} -body { + testparser {{123456\ + }x} 0 +} -returnCodes error -result {extra characters after close-brace} +test parse-5.18 {Tcl_ParseCommand: {expand} parsing} testparser { + testparser {{expand\ + }} 0 +} {- {{expand }} 1 simple {{expand }} 1 text {expand } 0 {}} +test parse-5.19 {Tcl_ParseCommand: {expand} parsing} -constraints { + testparser +} -body { + testparser {{expand\ + }x} 0 +} -returnCodes error -result {extra characters after close-brace} +test parse-5.20 {Tcl_ParseCommand: {expand} parsing} testparser { + testparser {{123456}} 0 +} {- {{123456}} 1 simple {{123456}} 1 text 123456 0 {}} +test parse-5.21 {Tcl_ParseCommand: {expand} parsing} -constraints { + testparser +} -body { + testparser {{123456}x} 0 +} -returnCodes error -result {extra characters after close-brace} +test parse-5.22 {Tcl_ParseCommand: {expand} parsing} testparser { + testparser {{expand}} 0 +} {- {{expand}} 1 simple {{expand}} 1 text expand 0 {}} +test parse-5.23 {Tcl_ParseCommand: {expand} parsing} testparser { + testparser {{expand} } 0 +} {- {{expand} } 1 simple {{expand}} 1 text expand 0 {}} +test parse-5.24 {Tcl_ParseCommand: {expand} parsing} testparser { + testparser {{expand}x} 0 +} {- {{expand}x} 1 expand {{expand}x} 1 text x 0 {}} + +test parse-6.1 {ParseTokens procedure, empty word} testparser { testparser {""} 0 } {- {""} 1 simple {""} 1 text {} 0 {}} -test parse-6.2 {ParseTokens procedure, simple range} { +test parse-6.2 {ParseTokens procedure, simple range} testparser { testparser {"abc$x.e"} 0 } {- {"abc$x.e"} 1 word {"abc$x.e"} 4 text abc 0 variable {$x} 1 text x 0 text .e 0 {}} -test parse-6.3 {ParseTokens procedure, variable reference} { +test parse-6.3 {ParseTokens procedure, variable reference} testparser { testparser {abc$x.e $y(z)} 0 } {- {abc$x.e $y(z)} 2 word {abc$x.e} 4 text abc 0 variable {$x} 1 text x 0 text .e 0 word {$y(z)} 3 variable {$y(z)} 2 text y 0 text z 0 {}} -test parse-6.4 {ParseTokens procedure, variable reference} { +test parse-6.4 {ParseTokens procedure, variable reference} testparser { list [catch {testparser {$x([a )} 0} msg] $msg } {1 {missing close-bracket}} -test parse-6.5 {ParseTokens procedure, command substitution} { +test parse-6.5 {ParseTokens procedure, command substitution} testparser { testparser {[foo $x bar]z} 0 } {- {[foo $x bar]z} 1 word {[foo $x bar]z} 2 command {[foo $x bar]} 0 text z 0 {}} -test parse-6.6 {ParseTokens procedure, command substitution} { +test parse-6.6 {ParseTokens procedure, command substitution} testparser { testparser {[foo \] [a b]]} 0 } {- {[foo \] [a b]]} 1 word {[foo \] [a b]]} 1 command {[foo \] [a b]]} 0 {}} -test parse-6.7 {ParseTokens procedure, error in command substitution} { +test parse-6.7 {ParseTokens procedure, error in command substitution} testparser { list [catch {testparser {a [b {}c d] e} 0} msg] $msg $errorInfo } {1 {extra characters after close-brace} {extra characters after close-brace (remainder of script: "c d] e") @@ -185,85 +251,94 @@ test parse-6.10 {ParseTokens procedure, incomplete sub-command} { expr 1+1 #this is a comment ]} } {0} -test parse-6.11 {ParseTokens procedure, memory allocation for big nested command} { +test parse-6.11 {ParseTokens procedure, memory allocation for big nested command} testparser { testparser {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 0 } {- {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 1 word {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 1 command {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 0 {}} -test parse-6.12 {ParseTokens procedure, missing close bracket} { +test parse-6.12 {ParseTokens procedure, missing close bracket} testparser { list [catch {testparser {[foo $x bar} 0} msg] $msg $errorInfo } {1 {missing close-bracket} {missing close-bracket (remainder of script: "[foo $x bar") invoked from within "testparser {[foo $x bar} 0"}} -test parse-6.13 {ParseTokens procedure, backslash-newline without continuation line} { +test parse-6.13 {ParseTokens procedure, backslash-newline without continuation line} testparser { list [catch {testparser "\"a b\\\n" 0} msg] $msg $errorInfo } {1 {missing "} missing\ \"\n\ \ \ \ (remainder\ of\ script:\ \"\"a\ b\\\n\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\\\"a\ b\\\\\\n\"\ 0\"} -test parse-6.14 {ParseTokens procedure, backslash-newline} { +test parse-6.14 {ParseTokens procedure, backslash-newline} testparser { testparser "b\\\nc" 0 } {- b\\\nc 2 simple b 1 text b 0 simple c 1 text c 0 {}} -test parse-6.15 {ParseTokens procedure, backslash-newline} { +test parse-6.15 {ParseTokens procedure, backslash-newline} testparser { testparser "\"b\\\nc\"" 0 } {- \"b\\\nc\" 1 word \"b\\\nc\" 3 text b 0 backslash \\\n 0 text c 0 {}} -test parse-6.16 {ParseTokens procedure, backslash substitution} { +test parse-6.16 {ParseTokens procedure, backslash substitution} testparser { testparser {\n\a\x7f} 0 } {- {\n\a\x7f} 1 word {\n\a\x7f} 3 backslash {\n} 0 backslash {\a} 0 backslash {\x7f} 0 {}} -test parse-6.17 {ParseTokens procedure, null characters} { +test parse-6.17 {ParseTokens procedure, null characters} testparser { testparser [bytestring "foo\0zz"] 0 } "- [bytestring foo\0zz] 1 word [bytestring foo\0zz] 3 text foo 0 text [bytestring \0] 0 text zz 0 {}" -test parse-6.18 {ParseTokens procedure, seek past numBytes for close-bracket} { +test parse-6.18 {ParseTokens procedure, seek past numBytes for close-bracket} testparser { # Test for Bug 681841 list [catch {testparser {[a]} 2} msg] $msg } {1 {missing close-bracket}} -test parse-7.1 {Tcl_FreeParse and ExpandTokenArray procedures} { +test parse-7.1 {Tcl_FreeParse and ExpandTokenArray procedures} testparser { testparser {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 0 } {- {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 16 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 {}} -test parse-8.1 {Tcl_EvalObjv procedure} { +test parse-8.1 {Tcl_EvalObjv procedure} testevalobjv { testevalobjv 0 concat this is a test } {this is a test} -test parse-8.2 {Tcl_EvalObjv procedure, unknown commands} { - rename unknown unknown.old +test parse-8.2 {Tcl_EvalObjv procedure, unknown commands} testevalobjv { + rename ::unknown unknown.old set x [catch {testevalobjv 10 asdf poiu} msg] - rename unknown.old unknown + rename unknown.old ::unknown list $x $msg } {1 {invalid command name "asdf"}} -test parse-8.3 {Tcl_EvalObjv procedure, unknown commands} { - rename unknown unknown.old - proc unknown args { +test parse-8.3 {Tcl_EvalObjv procedure, unknown commands} testevalobjv { + rename ::unknown unknown.old + proc ::unknown args { return "unknown $args" } set x [catch {testevalobjv 0 asdf poiu} msg] - rename unknown {} - rename unknown.old unknown + rename ::unknown {} + rename unknown.old ::unknown list $x $msg } {0 {unknown asdf poiu}} -test parse-8.4 {Tcl_EvalObjv procedure, unknown commands} { - rename unknown unknown.old - proc unknown args { +test parse-8.4 {Tcl_EvalObjv procedure, unknown commands} testevalobjv { + rename ::unknown unknown.old + proc ::unknown args { error "I don't like that command" } set x [catch {testevalobjv 0 asdf poiu} msg] - rename unknown {} - rename unknown.old unknown + rename ::unknown {} + rename unknown.old ::unknown list $x $msg } {1 {I don't like that command}} -test parse-8.5 {Tcl_EvalObjv procedure, command traces} { +test parse-8.5 {Tcl_EvalObjv procedure, command traces} {testevalobjv testcmdtrace} { testevalobjv 0 set x 123 testcmdtrace tracetest {testevalobjv 0 set x $x} } {{testevalobjv 0 set x $x} {testevalobjv 0 set x 123} {set x 123} {set x 123}} -test parse-8.7 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL flag} { +test parse-8.7 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL flag} -constraints { + testevalobjv +} -setup { proc x {} { set y 23 set z [testevalobjv 1 set y] return [list $z $y] } - catch {unset y} - set y 16 + set ::y 16 +} -cleanup { + unset ::y +} -body { x -} {16 23} -test parse-8.8 {Tcl_EvalObjv procedure, async handlers} { +} -result {16 23} +test parse-8.8 {Tcl_EvalObjv procedure, async handlers} -constraints { + testevalobjv testasync +} -setup { + variable ::aresult + variable ::acode proc async1 {result code} { - global aresult acode + variable ::aresult + variable ::acode set aresult $result set acode $code return "new result" @@ -271,15 +346,16 @@ test parse-8.8 {Tcl_EvalObjv procedure, async handlers} { set handler1 [testasync create async1] set aresult xxx set acode yyy - set x [list [catch [list testevalobjv 0 testasync mark $handler1 original 0] msg] $msg $acode $aresult] +} -cleanup { testasync delete - set x -} {0 {new result} 0 original} -test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} { +} -body { + list [testevalobjv 0 testasync mark $handler1 original 0] $acode $aresult +} -result {{new result} 0 original} +test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} testevalobjv { list [catch {testevalobjv 0 error message} msg] $msg } {1 message} -test parse-9.1 {Tcl_LogCommandInfo, line numbers} { +test parse-9.1 {Tcl_LogCommandInfo, line numbers} testevalex { catch {unset x} list [catch {testevalex {for {} 1 {} { @@ -305,264 +381,268 @@ test parse-9.1 {Tcl_LogCommandInfo, line numbers} { # asdf set x }}"}} -test parse-9.2 {Tcl_LogCommandInfo, truncating long commands} { +test parse-9.2 {Tcl_LogCommandInfo, truncating long commands} testevalex { list [testevalex {catch {set a b 111111111 222222222 333333333 444444444 555555555 666666666 777777777 888888888 999999999 000000000 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee fffffffff ggggggggg}}] $errorInfo } {1 {wrong # args: should be "set varName ?newValue?" while executing "set a b 111111111 222222222 333333333 444444444 555555555 666666666 777777777 888888888 999999999 000000000 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd ee..."}} -test parse-10.1 {Tcl_EvalTokens, simple text} { +test parse-10.1 {Tcl_EvalTokens, simple text} testevalex { testevalex {concat test} } {test} -test parse-10.2 {Tcl_EvalTokens, backslash sequences} { +test parse-10.2 {Tcl_EvalTokens, backslash sequences} testevalex { testevalex {concat test\063\062test} } {test32test} -test parse-10.3 {Tcl_EvalTokens, nested commands} { +test parse-10.3 {Tcl_EvalTokens, nested commands} testevalex { testevalex {concat [expr 2 + 6]} } {8} -test parse-10.4 {Tcl_EvalTokens, nested commands} { +test parse-10.4 {Tcl_EvalTokens, nested commands} testevalex { catch {unset a} list [catch {testevalex {concat xxx[expr $a]}} msg] $msg } {1 {can't read "a": no such variable}} -test parse-10.5 {Tcl_EvalTokens, simple variables} { +test parse-10.5 {Tcl_EvalTokens, simple variables} testevalex { set a hello testevalex {concat $a} } {hello} -test parse-10.6 {Tcl_EvalTokens, array variables} { +test parse-10.6 {Tcl_EvalTokens, array variables} testevalex { catch {unset a} set a(12) 46 testevalex {concat $a(12)} } {46} -test parse-10.7 {Tcl_EvalTokens, array variables} { +test parse-10.7 {Tcl_EvalTokens, array variables} testevalex { catch {unset a} set a(12) 46 testevalex {concat $a(1[expr 3 - 1])} } {46} -test parse-10.8 {Tcl_EvalTokens, array variables} { +test parse-10.8 {Tcl_EvalTokens, array variables} testevalex { catch {unset a} list [catch {testevalex {concat $x($a)}} msg] $msg } {1 {can't read "a": no such variable}} -test parse-10.9 {Tcl_EvalTokens, array variables} { +test parse-10.9 {Tcl_EvalTokens, array variables} testevalex { catch {unset a} list [catch {testevalex {concat xyz$a(1)}} msg] $msg } {1 {can't read "a(1)": no such variable}} -test parse-10.10 {Tcl_EvalTokens, object values} { +test parse-10.10 {Tcl_EvalTokens, object values} testevalex { set a 123 testevalex {concat $a} } {123} -test parse-10.11 {Tcl_EvalTokens, object values} { +test parse-10.11 {Tcl_EvalTokens, object values} testevalex { set a 123 testevalex {concat $a$a$a} } {123123123} -test parse-10.12 {Tcl_EvalTokens, object values} { +test parse-10.12 {Tcl_EvalTokens, object values} testevalex { testevalex {concat [expr 2][expr 4][expr 6]} } {246} -test parse-10.13 {Tcl_EvalTokens, string values} { +test parse-10.13 {Tcl_EvalTokens, string values} testevalex { testevalex {concat {a" b"}} } {a" b"} -test parse-10.14 {Tcl_EvalTokens, string values} { +test parse-10.14 {Tcl_EvalTokens, string values} testevalex { set a 111 testevalex {concat x$a.$a.$a} } {x111.111.111} -test parse-11.1 {Tcl_EvalEx, TCL_EVAL_GLOBAL flag} { +test parse-11.1 {Tcl_EvalEx, TCL_EVAL_GLOBAL flag} -constraints { + testevalex +} -setup { proc x {} { set y 777 set z [testevalex "set y" global] return [list $z $y] } - catch {unset y} - set y 321 + set ::y 321 +} -cleanup { + unset ::y +} -body { x -} {321 777} -test parse-11.2 {Tcl_EvalEx, error while parsing} { +} -result {321 777} +test parse-11.2 {Tcl_EvalEx, error while parsing} testevalex { list [catch {testevalex {concat "abc}} msg] $msg } {1 {missing "}} -test parse-11.3 {Tcl_EvalEx, error while collecting words} { +test parse-11.3 {Tcl_EvalEx, error while collecting words} testevalex { catch {unset a} list [catch {testevalex {concat xyz $a}} msg] $msg } {1 {can't read "a": no such variable}} -test parse-11.4 {Tcl_EvalEx, error in Tcl_EvalObjv call} { +test parse-11.4 {Tcl_EvalEx, error in Tcl_EvalObjv call} testevalex { catch {unset a} list [catch {testevalex {_bogus_ a b c d}} msg] $msg } {1 {invalid command name "_bogus_"}} -test parse-11.5 {Tcl_EvalEx, exceptional return} { +test parse-11.5 {Tcl_EvalEx, exceptional return} testevalex { list [catch {testevalex {break}} msg] $msg } {3 {}} -test parse-11.6 {Tcl_EvalEx, freeing memory} { +test parse-11.6 {Tcl_EvalEx, freeing memory} testevalex { testevalex {concat a b c d e f g h i j k l m n o p q r s t u v w x y z} } {a b c d e f g h i j k l m n o p q r s t u v w x y z} -test parse-11.7 {Tcl_EvalEx, multiple commands in script} { +test parse-11.7 {Tcl_EvalEx, multiple commands in script} testevalex { list [testevalex {set a b; set c d}] $a $c } {d b d} -test parse-11.8 {Tcl_EvalEx, multiple commands in script} { +test parse-11.8 {Tcl_EvalEx, multiple commands in script} testevalex { list [testevalex { set a b set c d }] $a $c } {d b d} -test parse-11.9 {Tcl_EvalEx, freeing memory after error} { +test parse-11.9 {Tcl_EvalEx, freeing memory after error} testevalex { catch {unset a} list [catch {testevalex {concat a b c d e f g h i j k l m n o p q r s t u v w x y z $a}} msg] $msg } {1 {can't read "a": no such variable}} -test parse-11.10 {Tcl_EvalTokens, empty commands} { +test parse-11.10 {Tcl_EvalTokens, empty commands} testevalex { testevalex {concat xyz; } } {xyz} -test parse-11.11 {Tcl_EvalTokens, empty commands} { +test parse-11.11 {Tcl_EvalTokens, empty commands} testevalex { testevalex "concat abc; ; # this is a comment\n" } {abc} -test parse-11.12 {Tcl_EvalTokens, empty commands} { +test parse-11.12 {Tcl_EvalTokens, empty commands} testevalex { testevalex {} } {} -test parse-12.1 {Tcl_ParseVarName procedure, initialization} { +test parse-12.1 {Tcl_ParseVarName procedure, initialization} testparsevarname { list [catch {testparsevarname {$a([first second])} 8 0} msg] $msg } {1 {missing close-bracket}} -test parse-12.2 {Tcl_ParseVarName procedure, initialization} { +test parse-12.2 {Tcl_ParseVarName procedure, initialization} testparsevarname { testparsevarname {$a([first second])} 0 0 } {- {} 0 variable {$a([first second])} 2 text a 0 command {[first second]} 0 {}} -test parse-12.3 {Tcl_ParseVarName procedure, initialization} { +test parse-12.3 {Tcl_ParseVarName procedure, initialization} testparsevarname { list [catch {testparsevarname {$abcd} 3 0} msg] $msg } {0 {- {} 0 variable {$ab} 1 text ab 0 cd}} -test parse-12.4 {Tcl_ParseVarName procedure, initialization} { +test parse-12.4 {Tcl_ParseVarName procedure, initialization} testparsevarname { testparsevarname {$abcd} 0 0 } {- {} 0 variable {$abcd} 1 text abcd 0 {}} -test parse-12.5 {Tcl_ParseVarName procedure, just a dollar sign} { +test parse-12.5 {Tcl_ParseVarName procedure, just a dollar sign} testparsevarname { testparsevarname {$abcd} 1 0 } {- {} 0 text {$} 0 abcd} -test parse-12.6 {Tcl_ParseVarName procedure, braced variable name} { +test parse-12.6 {Tcl_ParseVarName procedure, braced variable name} testparser { testparser {${..[]b}cd} 0 } {- {${..[]b}cd} 1 word {${..[]b}cd} 3 variable {${..[]b}} 1 text {..[]b} 0 text cd 0 {}} -test parse-12.7 {Tcl_ParseVarName procedure, braced variable name} { +test parse-12.7 {Tcl_ParseVarName procedure, braced variable name} testparser { testparser "\$\{\{\} " 0 } {- \$\{\{\}\ 1 word \$\{\{\} 2 variable \$\{\{\} 1 text \{ 0 {}} -test parse-12.8 {Tcl_ParseVarName procedure, missing close brace} { +test parse-12.8 {Tcl_ParseVarName procedure, missing close brace} testparser { list [catch {testparser "$\{abc" 0} msg] $msg $errorInfo } {1 {missing close-brace for variable name} missing\ close-brace\ for\ variable\ name\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\$\\\{abc\"\ 0\"} -test parse-12.9 {Tcl_ParseVarName procedure, missing close brace} { +test parse-12.9 {Tcl_ParseVarName procedure, missing close brace} testparsevarname { list [catch {testparsevarname {${bcd}} 4 0} msg] $msg } {1 {missing close-brace for variable name}} -test parse-12.10 {Tcl_ParseVarName procedure, missing close brace} { +test parse-12.10 {Tcl_ParseVarName procedure, missing close brace} testparsevarname { list [catch {testparsevarname {${bc}} 4 0} msg] $msg } {1 {missing close-brace for variable name}} -test parse-12.11 {Tcl_ParseVarName procedure, simple variable name} { +test parse-12.11 {Tcl_ParseVarName procedure, simple variable name} testparser { testparser {$az_AZ.} 0 } {- {$az_AZ.} 1 word {$az_AZ.} 3 variable {$az_AZ} 1 text az_AZ 0 text . 0 {}} -test parse-12.12 {Tcl_ParseVarName procedure, simple variable name} { +test parse-12.12 {Tcl_ParseVarName procedure, simple variable name} testparser { testparser {$abcdefg} 4 } {- {$abc} 1 word {$abc} 2 variable {$abc} 1 text abc 0 defg} -test parse-12.13 {Tcl_ParseVarName procedure, simple variable name with ::} { +test parse-12.13 {Tcl_ParseVarName procedure, simple variable name with ::} testparser { testparser {$xyz::ab:c} 0 } {- {$xyz::ab:c} 1 word {$xyz::ab:c} 3 variable {$xyz::ab} 1 text xyz::ab 0 text :c 0 {}} -test parse-12.14 {Tcl_ParseVarName procedure, variable names with many colons} { +test parse-12.14 {Tcl_ParseVarName procedure, variable names with many colons} testparser { testparser {$xyz:::::c} 0 } {- {$xyz:::::c} 1 word {$xyz:::::c} 2 variable {$xyz:::::c} 1 text xyz:::::c 0 {}} -test parse-12.15 {Tcl_ParseVarName procedure, : vs. ::} { +test parse-12.15 {Tcl_ParseVarName procedure, : vs. ::} testparsevarname { testparsevarname {$ab:cd} 0 0 } {- {} 0 variable {$ab} 1 text ab 0 :cd} -test parse-12.16 {Tcl_ParseVarName procedure, eof in ::} { +test parse-12.16 {Tcl_ParseVarName procedure, eof in ::} testparsevarname { testparsevarname {$ab::cd} 4 0 } {- {} 0 variable {$ab} 1 text ab 0 ::cd} -test parse-12.17 {Tcl_ParseVarName procedure, eof in ::} { +test parse-12.17 {Tcl_ParseVarName procedure, eof in ::} testparsevarname { testparsevarname {$ab:::cd} 5 0 } {- {} 0 variable {$ab::} 1 text ab:: 0 :cd} -test parse-12.18 {Tcl_ParseVarName procedure, no variable name} { +test parse-12.18 {Tcl_ParseVarName procedure, no variable name} testparser { testparser {$$ $.} 0 } {- {$$ $.} 2 word {$$} 2 text {$} 0 text {$} 0 word {$.} 2 text {$} 0 text . 0 {}} -test parse-12.19 {Tcl_ParseVarName procedure, EOF before (} { +test parse-12.19 {Tcl_ParseVarName procedure, EOF before (} testparsevarname { testparsevarname {$ab(cd)} 3 0 } {- {} 0 variable {$ab} 1 text ab 0 (cd)} -test parse-12.20 {Tcl_ParseVarName procedure, array reference} { +test parse-12.20 {Tcl_ParseVarName procedure, array reference} testparser { testparser {$x(abc)} 0 } {- {$x(abc)} 1 word {$x(abc)} 3 variable {$x(abc)} 2 text x 0 text abc 0 {}} -test parse-12.21 {Tcl_ParseVarName procedure, array reference} { +test parse-12.21 {Tcl_ParseVarName procedure, array reference} testparser { testparser {$x(ab$cde[foo bar])} 0 } {- {$x(ab$cde[foo bar])} 1 word {$x(ab$cde[foo bar])} 6 variable {$x(ab$cde[foo bar])} 5 text x 0 text ab 0 variable {$cde} 1 text cde 0 command {[foo bar]} 0 {}} -test parse-12.22 {Tcl_ParseVarName procedure, array reference} { +test parse-12.22 {Tcl_ParseVarName procedure, array reference} testparser { testparser {$x([cmd arg]zz)} 0 } {- {$x([cmd arg]zz)} 1 word {$x([cmd arg]zz)} 4 variable {$x([cmd arg]zz)} 3 text x 0 command {[cmd arg]} 0 text zz 0 {}} -test parse-12.23 {Tcl_ParseVarName procedure, missing close paren in array reference} { +test parse-12.23 {Tcl_ParseVarName procedure, missing close paren in array reference} testparser { list [catch {testparser {$x(poiu} 0} msg] $msg $errorInfo } {1 {missing )} {missing ) (remainder of script: "(poiu") invoked from within "testparser {$x(poiu} 0"}} -test parse-12.24 {Tcl_ParseVarName procedure, missing close paren in array reference} { +test parse-12.24 {Tcl_ParseVarName procedure, missing close paren in array reference} testparsevarname { list [catch {testparsevarname {$ab(cd)} 6 0} msg] $msg $errorInfo } {1 {missing )} {missing ) (remainder of script: "(cd)") invoked from within "testparsevarname {$ab(cd)} 6 0"}} -test parse-12.25 {Tcl_ParseVarName procedure, nested array reference} { +test parse-12.25 {Tcl_ParseVarName procedure, nested array reference} testparser { testparser {$x(a$y(b$z))} 0 } {- {$x(a$y(b$z))} 1 word {$x(a$y(b$z))} 8 variable {$x(a$y(b$z))} 7 text x 0 text a 0 variable {$y(b$z)} 4 text y 0 text b 0 variable {$z} 1 text z 0 {}} -test parse-13.1 {Tcl_ParseVar procedure} { +test parse-13.1 {Tcl_ParseVar procedure} testparsevar { set abc 24 testparsevar {$abc.fg} } {24 .fg} -test parse-13.2 {Tcl_ParseVar procedure, no variable name} { +test parse-13.2 {Tcl_ParseVar procedure, no variable name} testparsevar { testparsevar {$} } {{$} {}} -test parse-13.3 {Tcl_ParseVar procedure, no variable name} { +test parse-13.3 {Tcl_ParseVar procedure, no variable name} testparsevar { testparsevar {$.123} } {{$} .123} -test parse-13.4 {Tcl_ParseVar procedure, error looking up variable} { +test parse-13.4 {Tcl_ParseVar procedure, error looking up variable} testparsevar { catch {unset abc} list [catch {testparsevar {$abc}} msg] $msg } {1 {can't read "abc": no such variable}} -test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} { +test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar { catch {unset abc} list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg } {1 {invalid command name "bogus"}} -test parse-14.1 {Tcl_ParseBraces procedure, computing string length} { +test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} -test parse-14.2 {Tcl_ParseBraces procedure, computing string length} { +test parse-14.2 {Tcl_ParseBraces procedure, computing string length} testparser { testparser "foo bar" -1 } {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}} -test parse-14.3 {Tcl_ParseBraces procedure, words in braces} { +test parse-14.3 {Tcl_ParseBraces procedure, words in braces} testparser { testparser {foo {a $b [concat foo]} {c d}} 0 } {- {foo {a $b [concat foo]} {c d}} 3 simple foo 1 text foo 0 simple {{a $b [concat foo]}} 1 text {a $b [concat foo]} 0 simple {{c d}} 1 text {c d} 0 {}} -test parse-14.4 {Tcl_ParseBraces procedure, empty nested braces} { +test parse-14.4 {Tcl_ParseBraces procedure, empty nested braces} testparser { testparser {foo {{}}} 0 } {- {foo {{}}} 2 simple foo 1 text foo 0 simple {{{}}} 1 text {{}} 0 {}} -test parse-14.5 {Tcl_ParseBraces procedure, nested braces} { +test parse-14.5 {Tcl_ParseBraces procedure, nested braces} testparser { testparser {foo {{a {b} c} {} {d e}}} 0 } {- {foo {{a {b} c} {} {d e}}} 2 simple foo 1 text foo 0 simple {{{a {b} c} {} {d e}}} 1 text {{a {b} c} {} {d e}} 0 {}} -test parse-14.6 {Tcl_ParseBraces procedure, backslashes in words in braces} { +test parse-14.6 {Tcl_ParseBraces procedure, backslashes in words in braces} testparser { testparser "foo {a \\n\\\{}" 0 } {- {foo {a \n\{}} 2 simple foo 1 text foo 0 simple {{a \n\{}} 1 text {a \n\{} 0 {}} -test parse-14.7 {Tcl_ParseBraces procedure, missing continuation line in braces} { +test parse-14.7 {Tcl_ParseBraces procedure, missing continuation line in braces} testparser { list [catch {testparser "\{abc\\\n" 0} msg] $msg $errorInfo } {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\\\n\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\\\{abc\\\\\\n\"\ 0\"} -test parse-14.8 {Tcl_ParseBraces procedure, backslash-newline in braces} { +test parse-14.8 {Tcl_ParseBraces procedure, backslash-newline in braces} testparser { testparser "foo {\\\nx}" 0 } {- foo\ \{\\\nx\} 2 simple foo 1 text foo 0 word \{\\\nx\} 2 backslash \\\n 0 text x 0 {}} -test parse-14.9 {Tcl_ParseBraces procedure, backslash-newline in braces} { +test parse-14.9 {Tcl_ParseBraces procedure, backslash-newline in braces} testparser { testparser "foo {a \\\n b}" 0 } {- foo\ \{a\ \\\n\ \ \ b\} 2 simple foo 1 text foo 0 word \{a\ \\\n\ \ \ b\} 3 text {a } 0 backslash \\\n\ \ \ 0 text b 0 {}} -test parse-14.10 {Tcl_ParseBraces procedure, backslash-newline in braces} { +test parse-14.10 {Tcl_ParseBraces procedure, backslash-newline in braces} testparser { testparser "foo {xyz\\\n }" 0 } {- foo\ \{xyz\\\n\ \} 2 simple foo 1 text foo 0 word \{xyz\\\n\ \} 2 text xyz 0 backslash \\\n\ 0 {}} -test parse-14.11 {Tcl_ParseBraces procedure, empty braced string} { +test parse-14.11 {Tcl_ParseBraces procedure, empty braced string} testparser { testparser {foo {}} 0 } {- {foo {}} 2 simple foo 1 text foo 0 simple {{}} 1 text {} 0 {}} -test parse-14.12 {Tcl_ParseBraces procedure, missing close brace} { +test parse-14.12 {Tcl_ParseBraces procedure, missing close brace} testparser { list [catch {testparser "foo \{xy\\\nz" 0} msg] $msg $errorInfo } {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{xy\\\nz\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\{xy\\\\\\nz\"\ 0\"} -test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} { +test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} -test parse-15.2 {Tcl_ParseQuotedString procedure, computing string length} { +test parse-15.2 {Tcl_ParseQuotedString procedure, computing string length} testparser { testparser "foo bar" -1 } {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}} -test parse-15.3 {Tcl_ParseQuotedString procedure, word is quoted string} { +test parse-15.3 {Tcl_ParseQuotedString procedure, word is quoted string} testparser { testparser {foo "a b c" d "efg";} 0 } {- {foo "a b c" d "efg";} 4 simple foo 1 text foo 0 simple {"a b c"} 1 text {a b c} 0 simple d 1 text d 0 simple {"efg"} 1 text efg 0 {}} -test parse-15.4 {Tcl_ParseQuotedString procedure, garbage after quoted string} { +test parse-15.4 {Tcl_ParseQuotedString procedure, garbage after quoted string} testparser { list [catch {testparser {foo "a b c"d} 0} msg] $msg $errorInfo } {1 {extra characters after close-quote} {extra characters after close-quote (remainder of script: "d") @@ -708,16 +788,16 @@ test parse-15.50 {CommandComplete procedure} { info complete "abc\\\n" } 0 test parse-15.51 {CommandComplete procedure} " - info complete \"\\{abc\\}\\{\" + info complete \"\\\{abc\\\}\\\{\" " 1 test parse-15.52 {CommandComplete procedure} { info complete "\"abc\"(" } 1 test parse-15.53 {CommandComplete procedure} " - info complete \" # {\" + info complete \" # \{\" " 1 test parse-15.54 {CommandComplete procedure} " - info complete \"foo bar;# {\" + info complete \"foo bar;# \{\" " 1 test parse-15.55 {CommandComplete procedure} { info complete "set x [bytestring \0]; puts hi" @@ -853,7 +933,8 @@ test parse-18.30 {Tcl_SubstObj, side effects} { set a } 1 -# cleanup -catch {unset a} -::tcltest::cleanupTests + cleanupTests +} + +namespace delete ::tcl::test::parse return diff --git a/tests/pkg.test b/tests/pkg.test index 189d2c1..73ccb75 100644 --- a/tests/pkg.test +++ b/tests/pkg.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: pkg.test,v 1.10 2003/06/27 17:22:41 dgp Exp $ +# RCS: @(#) $Id: pkg.test,v 1.11 2003/11/14 20:44:46 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -25,7 +25,7 @@ interp eval $i [list package require tcltest] interp eval $i [list namespace import -force ::tcltest::*] interp eval $i { -eval package forget [package names] +package forget {expand}[package names] set oldPkgUnknown [package unknown] package unknown {} set oldPath $auto_path diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index cf3509d..958acaf 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -8,7 +8,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: pkgMkIndex.test,v 1.24 2003/07/24 08:45:09 rmax Exp $ +# RCS: @(#) $Id: pkgMkIndex.test,v 1.25 2003/11/14 20:44:46 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -89,7 +89,7 @@ proc pkgtest::parseIndex { filePath } { set ver [lindex $args 2] set ::PKGS($pkg:$ver) [lindex $args 3] } else { - return [eval package_original $args] + return [package_original {expand}$args] } } array set ::PKGS {} @@ -148,7 +148,7 @@ proc pkgtest::parseIndex { filePath } { # 1: the error result if element 0 was 1 proc pkgtest::createIndex { args } { - set parsed [eval parseArgs $args] + set parsed [parseArgs {expand}$args] set options [lindex $parsed 0] set dirPath [lindex $parsed 1] set patternList [lindex $parsed 2] @@ -157,7 +157,7 @@ proc pkgtest::createIndex { args } { if {[catch { file delete [file join $dirPath pkgIndex.tcl] - eval pkg_mkIndex $options [list $dirPath] $patternList + pkg_mkIndex {expand}$options $dirPath {expand}$patternList } err]} { return [list 1 $err] } @@ -231,7 +231,7 @@ proc makePkgList { inList } { proc pkgtest::runCreatedIndex {rv args} { if {[lindex $rv 0] == 0} { - set parsed [eval parseArgs $args] + set parsed [parseArgs {expand}$args] set dirPath [lindex $parsed 1] set idxFile [file join $dirPath pkgIndex.tcl] @@ -248,8 +248,8 @@ proc pkgtest::runCreatedIndex {rv args} { return $result } proc pkgtest::runIndex { args } { - set rv [eval createIndex $args] - return [eval [list runCreatedIndex $rv] $args] + set rv [createIndex {expand}$args] + return [runCreatedIndex $rv {expand}$args] } # If there is no match to the patterns, make sure the directory hasn't diff --git a/tests/proc.test b/tests/proc.test index ce07e88..bf23ef7 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -13,20 +13,20 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: proc.test,v 1.11 2002/12/11 21:29:52 dgp Exp $ +# RCS: @(#) $Id: proc.test,v 1.12 2003/11/14 20:44:47 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -catch {eval namespace delete [namespace children :: test_ns_*]} +catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename {} ""} catch {unset msg} test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1 { namespace eval baz {} } @@ -38,11 +38,11 @@ test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} [info commands test_ns_1::baz::*] } {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p} test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} list [catch {proc test_ns_1::baz::p {} {}} msg] $msg } {1 {can't create procedure "test_ns_1::baz::p": unknown namespace}} test proc-1.3 {Tcl_ProcObjCmd, empty proc name} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} proc :: {} { return "empty called" } @@ -52,7 +52,7 @@ test proc-1.3 {Tcl_ProcObjCmd, empty proc name} { return "empty called" }} test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1 { namespace eval baz { proc p {} { @@ -64,7 +64,7 @@ test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} { [info commands test_ns_1::baz::*] } {{p in ::test_ns_1::baz} ::test_ns_1::baz::p} test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1::baz {} namespace eval test_ns_1 { proc baz::p {} { @@ -76,7 +76,7 @@ test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace [namespace eval test_ns_1::baz {namespace which p}] } {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p} test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1 { proc q: {} {return "q:"} proc value:at: {} {return "value:at:"} @@ -103,13 +103,13 @@ test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple name } {1 {procedure "p" has formal parameter "b::a" that is not a simple name}} test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename p ""} proc p {} {return "p in [namespace current]"} info body p } {return "p in [namespace current]"} test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1 { namespace eval baz { proc p {} {return "p in [namespace current]"} @@ -118,7 +118,7 @@ test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} { namespace eval test_ns_1::baz {info body p} } {return "p in [namespace current]"} test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1::baz {} namespace eval test_ns_1 { proc baz::p {} {return "p in [namespace current]"} @@ -126,26 +126,26 @@ test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} { namespace eval test_ns_1 {info body baz::p} } {return "p in [namespace current]"} test proc-2.4 {TclFindProc, global proc and executing in namespace} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename p ""} proc p {} {return "global p"} namespace eval test_ns_1::baz {info body p} } {return "global p"} test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} proc p {} {return "p in [namespace current]"} p } {p in ::} test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_1::baz { proc p {} {return "p in [namespace current]"} p } } {p in ::test_ns_1::baz} test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename p ""} proc p {} {return "p in [namespace current]"} namespace eval test_ns_1::baz { @@ -153,7 +153,7 @@ test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespa } } {p in ::} test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename p ""} namespace eval test_ns_1::baz { proc p {} {return "p in [namespace current]"} @@ -166,7 +166,7 @@ test proc-3.5 {TclObjInterpProc, any old result is reset before appending error list [catch {p} msg] $msg } {1 {wrong # args: should be "p x"}} -catch {eval namespace delete [namespace children :: test_ns_*]} +catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename {} ""} catch {unset msg} diff --git a/tests/reg.test b/tests/reg.test index a8bd678..bbcb2d1 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -9,7 +9,7 @@ # # Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. # -# RCS: @(#) $Id: reg.test,v 1.18 2003/10/06 14:32:22 dgp Exp $ +# RCS: @(#) $Id: reg.test,v 1.19 2003/11/14 20:44:47 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -231,10 +231,8 @@ proc f {testid flags re target args} { if {$amp >= 0} { set f [string range $flags 0 [expr $amp - 1]] append f [string range $flags [expr $amp + 1] end] - eval [linsert $args 0 f [linsert $testid end ARE] ${f} $re \ - $target] - eval [linsert $args 0 f [linsert $testid end BRE] ${f}b $re \ - $target] + f [linsert $testid end ARE] ${f} $re $target {expand}$args + f [linsert $testid end BRE] ${f}b $re $target {expand}$args return } @@ -283,10 +281,12 @@ proc matchexpected {opts testid flags re target args} { if {$amp >= 0} { set f [string range $flags 0 [expr $amp - 1]] append f [string range $flags [expr $amp + 1] end] - eval [concat [list matchexpected $opts \ - [linsert $testid end ARE] ${f} $re $target] $args] - eval [concat [list matchexpected $opts \ - [linsert $testid end BRE] ${f}b $re $target] $args] + matchexpected $opts [linsert $testid end ARE] \ + ${f} $re $target {expand}$args + + + matchexpected $opts [linsert $testid end BRE] \ + ${f}b $re $target {expand}$args return } @@ -332,13 +332,13 @@ proc matchexpected {opts testid flags re target args} { # match expected (no missing, empty, or ambiguous submatches) # m testno flags re target mat submat ... proc m {args} { - eval matchexpected [linsert $args 0 [list]] + matchexpected {} {expand}$args } # match expected (full fanciness) # i testno flags re target mat submat ... proc i {args} { - eval matchexpected [linsert $args 0 [list "-indices"]] + matchexpected -indices {expand}$args } # partial match expected @@ -347,7 +347,7 @@ proc i {args} { proc p {args} { set f [lindex $args 1] ;# add ! flag set args [lreplace $args 1 1 "!$f"] - eval matchexpected [linsert $args 0 [list "-indices"]] + matchexpected -indices {expand}$args } # test is a knownBug diff --git a/tests/trace.test b/tests/trace.test index c22cfc7..0325cef 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -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: trace.test,v 1.32 2003/09/29 21:28:09 dgp Exp $ +# RCS: @(#) $Id: trace.test,v 1.33 2003/11/14 20:44:47 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -1346,7 +1346,7 @@ test trace-20.7 {trace add command delete in subinterp while being deleted} { } {} proc traceDelete {cmd old new op} { - eval trace remove command $cmd [lindex [trace info command $cmd] 0] + trace remove command $cmd {expand}[lindex [trace info command $cmd] 0] global info set info [list $old $new $op] } @@ -1602,7 +1602,7 @@ test trace-23.3 {recursive(3) trace execution: enter, leave, enterstep, leaveste {factorial 3} 0 6 leave} proc traceDelete {cmd args} { - eval trace remove execution $cmd [lindex [trace info execution $cmd] 0] + trace remove execution $cmd {expand}[lindex [trace info execution $cmd] 0] global info set info $args } diff --git a/tests/upvar.test b/tests/upvar.test index ad8fe6c..dcc2e23 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -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: upvar.test,v 1.7 2000/04/10 17:19:05 ericm Exp $ +# RCS: @(#) $Id: upvar.test,v 1.8 2003/11/14 20:44:47 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -320,7 +320,7 @@ test upvar-8.8 {create nested array with upvar} { list [catch p1 msg] $msg } {1 {can't set "b(2)": variable isn't array}} test upvar-8.9 {upvar won't create namespace variable that refers to procedure variable} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {expand}[namespace children :: test_ns_*]} catch {rename MakeLink ""} namespace eval ::test_ns_1 {} proc MakeLink {a} { diff --git a/tests/winConsole.test b/tests/winConsole.test index 81ddb54..2d0e9e5 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winConsole.test,v 1.5 2000/04/10 17:19:06 ericm Exp $ +# RCS: @(#) $Id: winConsole.test,v 1.6 2003/11/14 20:44:47 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -39,7 +39,7 @@ test winConsole-1.1 {Console file channel: non-blocking gets} \ #cleanup the fileevent fileevent stdin readable {} - eval fconfigure stdin $oldmode + fconfigure stdin {expand}$oldmode set result diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 2829fb6..49b4612 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.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: winFCmd.test,v 1.22 2003/09/16 14:56:08 vincentdarley Exp $ +# RCS: @(#) $Id: winFCmd.test,v 1.23 2003/11/14 20:44:47 dgp Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -39,7 +39,7 @@ proc cleanup {args} { set x [glob -directory $p tf* td*] } if {$x != ""} { - catch {eval file delete -force -- $x} + catch {file delete -force -- {expand}$x} } } } |