Attachment "tip157.patch.1" to
ticket [827119ffff]
added by
msofer
2003-11-07 20:34:51.
Index: doc/ParseCmd.3
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/ParseCmd.3,v
retrieving revision 1.11
diff -c -r1.11 ParseCmd.3
*** doc/ParseCmd.3 19 Mar 2003 20:07:17 -0000 1.11
--- doc/ParseCmd.3 7 Nov 2003 13:26:57 -0000
***************
*** 286,291 ****
--- 286,301 ----
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,386 ****
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
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
word, and so on until all \fInumWords\fR have been accounted
for.
.PP
After \fBTcl_ParseExpr\fR returns, the first token pointed to by
the \fItokenPtr\fR field of the
--- 385,400 ----
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
! .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
! 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
Index: generic/tcl.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.h,v
retrieving revision 1.166
diff -c -r1.166 tcl.h
*** generic/tcl.h 13 Oct 2003 16:48:06 -0000 1.166
--- generic/tcl.h 7 Nov 2003 13:26:58 -0000
***************
*** 2078,2083 ****
--- 2078,2084 ----
#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
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.92
diff -c -r1.92 tclBasic.c
*** generic/tclBasic.c 14 Oct 2003 15:44:52 -0000 1.92
--- generic/tclBasic.c 7 Nov 2003 13:26:58 -0000
***************
*** 3499,3507 ****
CONST char *p, *next;
Tcl_Parse parse;
#define NUM_STATIC_OBJS 20
! Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;
Tcl_Token *tokenPtr;
! int i, code, commandLength, bytesLeft;
CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
* in case TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
--- 3499,3508 ----
CONST char *p, *next;
Tcl_Parse parse;
#define NUM_STATIC_OBJS 20
! Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv, **objvSpace;
! int expandStatic[NUM_STATIC_OBJS], *expand;
Tcl_Token *tokenPtr;
! 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,3535 ****
* command from the script and then executes it.
*/
! objv = staticObjArray;
p = script;
bytesLeft = numBytes;
iPtr->evalFlags = 0;
--- 3530,3537 ----
* command from the script and then executes it.
*/
! objv = objvSpace = staticObjArray;
! expand = expandStatic;
p = script;
bytesLeft = numBytes;
iPtr->evalFlags = 0;
***************
*** 3544,3567 ****
/*
* Generate an array of objects for the words of the command.
*/
! if (parse.numWords <= NUM_STATIC_OBJS) {
! objv = staticObjArray;
! } else {
! objv = (Tcl_Obj **) ckalloc((unsigned)
(parse.numWords * sizeof (Tcl_Obj *)));
}
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 {
goto error;
}
}
/*
--- 3546,3633 ----
/*
* Generate an array of objects for the words of the command.
*/
+ int objectsNeeded = 0;
! 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) {
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(interp, 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,3597 ****
Tcl_DecrRefCount(objv[i]);
}
objectsUsed = 0;
! if (objv != staticObjArray) {
! ckfree((char *) objv);
! objv = staticObjArray;
}
}
--- 3655,3671 ----
Tcl_DecrRefCount(objv[i]);
}
objectsUsed = 0;
! 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,3644 ****
if (gotParse) {
Tcl_FreeParse(&parse);
}
! if (objv != staticObjArray) {
! ckfree((char *) objv);
}
iPtr->varFramePtr = savedVarFramePtr;
return code;
--- 3711,3721 ----
if (gotParse) {
Tcl_FreeParse(&parse);
}
! if (objvSpace != staticObjArray) {
! ckfree((char *) objvSpace);
! }
! if (expand != expandStatic) {
! ckfree((char *) expand);
}
iPtr->varFramePtr = savedVarFramePtr;
return code;
Index: generic/tclCompile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.c,v
retrieving revision 1.51
diff -c -r1.51 tclCompile.c
*** generic/tclCompile.c 14 Oct 2003 15:44:52 -0000 1.51
--- generic/tclCompile.c 7 Nov 2003 13:26:59 -0000
***************
*** 273,278 ****
--- 273,285 ----
/* return TCL_RETURN code. */
{"expon", 1, -1, 0, {OPERAND_NONE}},
/* Binary exponentiation operator: push (stknext ** stktop) */
+ {"lconcat", 2, INT_MIN, 1, {OPERAND_UINT1}},
+ /* Concatenate as lists the top op1 items and push result */
+ {"listverify", 1, 0, 0, {OPERAND_NONE}},
+ /* Test that top of stack is a valid list; error if not */
+ {"invokelist", 1, 0, 0, {OPERAND_NONE}},
+ /* Invoke the command contained in the list at stacktop, and
+ * push the result. */
{0}
};
***************
*** 843,848 ****
--- 850,857 ----
}
gotParse = 1;
if (parse.numWords > 0) {
+ int expand = 0;
+
/*
* If not the first command, pop the previous command's result
* and, if we're compiling a top level command, update the last
***************
*** 883,899 ****
fprintf(stdout, "\n");
}
#endif
/*
! * Each iteration of the following loop compiles one word
! * from the command.
*/
!
envPtr->numCommands++;
currCmdIndex = (envPtr->numCommands - 1);
lastTopLevelCmdIndex = currCmdIndex;
startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
EnterCmdStartData(envPtr, currCmdIndex,
(parse.commandStart - envPtr->source), startCodeOffset);
for (wordIdx = 0, tokenPtr = parse.tokenPtr;
wordIdx < parse.numWords;
--- 892,969 ----
fprintf(stdout, "\n");
}
#endif
+
/*
! * 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;
! break;
! }
! }
!
envPtr->numCommands++;
currCmdIndex = (envPtr->numCommands - 1);
lastTopLevelCmdIndex = currCmdIndex;
startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
EnterCmdStartData(envPtr, currCmdIndex,
(parse.commandStart - envPtr->source), startCodeOffset);
+
+ /*
+ * Handle separately the compilation of commands that include
+ * any expanding words .
+ */
+
+ if (expand) {
+ int listCount = 0, concatCount = 0;
+ for (wordIdx = 0, tokenPtr = parse.tokenPtr;
+ wordIdx < parse.numWords;
+ wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
+
+ if (listCount
+ && (tokenPtr->type == TCL_TOKEN_EXPAND_WORD)) {
+ TclEmitInstInt4(INST_LIST, listCount, envPtr);
+ concatCount++;
+ listCount = 0;
+ }
+ code = TclCompileTokens(interp, tokenPtr+1,
+ tokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ goto log;
+ }
+ if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
+ /*
+ * Include runtime check that value to be
+ * expanded is a valid list
+ */
+ TclEmitOpcode(INST_LIST_VERIFY, envPtr);
+ concatCount++;
+ } else {
+ listCount++;
+ }
+ }
+ if (listCount) {
+ TclEmitInstInt4(INST_LIST, listCount, envPtr);
+ concatCount++;
+ }
+ while (concatCount > 255) {
+ TclEmitInstInt1(INST_LCONCAT1, 255, envPtr);
+ concatCount -= 254; /* concat pushes 1 obj, the result */
+ }
+ TclEmitInstInt1(INST_LCONCAT1, concatCount, envPtr);
+ TclEmitOpcode(INST_INVOKE_LIST, envPtr);
+ goto finishCommand;
+ }
+
+ /*
+ * Each iteration of the following loop compiles one word
+ * from the command.
+ */
for (wordIdx = 0, tokenPtr = parse.tokenPtr;
wordIdx < parse.numWords;
Index: generic/tclCompile.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.h,v
retrieving revision 1.38
diff -c -r1.38 tclCompile.h
*** generic/tclCompile.h 15 Sep 2003 09:46:22 -0000 1.38
--- generic/tclCompile.h 7 Nov 2003 13:26:59 -0000
***************
*** 526,533 ****
#define INST_EXPON 99 /* TIP#123 - exponentiation */
/* The last opcode */
! #define LAST_INST_OPCODE 99
/*
* Table describing the Tcl bytecode instructions: their name (for
--- 526,537 ----
#define INST_EXPON 99 /* TIP#123 - exponentiation */
+ #define INST_LCONCAT1 100
+ #define INST_LIST_VERIFY 101
+ #define INST_INVOKE_LIST 102
+
/* The last opcode */
! #define LAST_INST_OPCODE 102
/*
* Table describing the Tcl bytecode instructions: their name (for
Index: generic/tclExecute.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclExecute.c,v
retrieving revision 1.113
diff -c -r1.113 tclExecute.c
*** generic/tclExecute.c 28 Oct 2003 22:06:14 -0000 1.113
--- generic/tclExecute.c 7 Nov 2003 13:26:59 -0000
***************
*** 1086,1091 ****
--- 1086,1094 ----
int traceInstructions = (tclTraceExec == 3);
char cmdNameBuf[21];
#endif
+ int objc = 0;
+ Tcl_Obj **objv;
+
/*
* The execution uses a unified stack: first the catch stack, immediately
***************
*** 1304,1339 ****
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(2, opnd, 1);
}
case INST_INVOKE_STK4:
! opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doInvocation;
case INST_INVOKE_STK1:
! opnd = TclGetUInt1AtPtr(pc+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.
*/
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) {
--- 1307,1407 ----
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_LCONCAT1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ {
+ Tcl_Obj **currPtr;
+
+ /*
+ * Concatenate lists from the top opnd items on the stack
+ * starting with the deepest item.
+ *
+ * NOTE: It is assumed that each operand is a valid list,
+ * and prior bytecodes have already checked for this.
+ */
+
+ opnd--;
+ objResultPtr = *(tosPtr - opnd);
+
+ /* Make sure the first list is unshared, as we will
+ * append to it and leave it as the result. If shared,
+ * replace it with an unshared copy.
+ */
+
+ if (Tcl_IsShared(objResultPtr)) {
+ TclDecrRefCount(objResultPtr);
+ objResultPtr = Tcl_DuplicateObj(objResultPtr);
+ Tcl_IncrRefCount(objResultPtr);
+ *(tosPtr - opnd) = objResultPtr;
+ }
+
+ for (currPtr = tosPtr - (opnd-1); currPtr <= tosPtr;
+ currPtr++) {
+ Tcl_ListObjAppendList(NULL, objResultPtr, *currPtr);
+ }
+
+ TRACE_WITH_OBJ(("%u => ", opnd+1), objResultPtr);
+ NEXT_INST_V(2, opnd, 0);
+ }
+
+ case INST_INVOKE_LIST:
+ /*
+ * If the list at stackTop is empty, do not
+ * invoke and leave it as the result; otherwise,
+ * set the cleanup parameters and invoke the
+ * command contained in the list.
+ */
+
+ Tcl_ListObjGetElements(interp, *tosPtr, &objc, &objv);
+ if (!objc) {
+ NEXT_INST_F(1, 0, 0);
+ }
+ opnd = 1; /* The number of stack objs to free. */
+ pcAdjustment = 1;
+ goto doInvocation;
case INST_INVOKE_STK4:
! opnd = TclGetUInt4AtPtr(pc+1); /* The number of stack objs to free. */
! objc = opnd; /* The number of arguments. */
! objv = (tosPtr - (objc-1)); /* The array of argument objects. */
pcAdjustment = 5;
goto doInvocation;
case INST_INVOKE_STK1:
! opnd = TclGetUInt1AtPtr(pc+1); /* The number of stack objs to free. */
! objc = opnd; /* The number of arguments. */
! objv = (tosPtr - (objc-1)); /* The array of argument objects. */
pcAdjustment = 2;
doInvocation:
{
! /*
! * We have to insure that the memory currently containing
! * the stack is preserved: it may contain the objv array,
! * which must be kept live throughout trace and command
! * invokations.
! *
* We keep the stack reference count as a (char *), as that
* works nicely as a portable pointer-sized counter.
*/
char **preservedStackRefCountPtr;
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
if (traceInstructions) {
Index: generic/tclParse.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclParse.c,v
retrieving revision 1.28
diff -c -r1.28 tclParse.c
*** generic/tclParse.c 2 Nov 2003 18:57:35 -0000 1.28
--- generic/tclParse.c 7 Nov 2003 13:27:00 -0000
***************
*** 287,292 ****
--- 287,294 ----
parsePtr->commandStart = src;
while (1) {
+ int expandWord = 0;
+
/*
* Create the token for the word.
*/
***************
*** 319,329 ****
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).
*/
if (*src == '"') {
if (Tcl_ParseQuotedString(interp, src, numBytes,
parsePtr, 1, &termPtr) != TCL_OK) {
--- 321,332 ----
parsePtr->numWords++;
/*
! * 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,341 ****
--- 334,372 ----
}
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
***************
*** 361,366 ****
--- 392,400 ----
if ((tokenPtr->numComponents == 1)
&& (tokenPtr[1].type == TCL_TOKEN_TEXT)) {
tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
+ }
+ if (expandWord) {
+ tokenPtr->type = TCL_TOKEN_EXPAND_WORD;
}
/*
Index: generic/tclTest.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclTest.c,v
retrieving revision 1.69
diff -c -r1.69 tclTest.c
*** generic/tclTest.c 13 Oct 2003 16:48:06 -0000 1.69
--- generic/tclTest.c 7 Nov 2003 13:27:00 -0000
***************
*** 3045,3050 ****
--- 3045,3053 ----
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;
Index: library/auto.tcl
===================================================================
RCS file: /cvsroot/tcl/tcl/library/auto.tcl,v
retrieving revision 1.13
diff -c -r1.13 auto.tcl
*** library/auto.tcl 19 Mar 2003 21:57:40 -0000 1.13
--- library/auto.tcl 7 Nov 2003 13:27:00 -0000
***************
*** 178,189 ****
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 == ""} {
set args *.tcl
}
auto_mkindex_parser::init
! foreach file [eval glob $args] {
if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {
append index $msg
} else {
--- 178,189 ----
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 {[llength $args] == 0} {
set args *.tcl
}
auto_mkindex_parser::init
! foreach file [glob {expand}$args] {
if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {
append index $msg
} else {
***************
*** 216,225 ****
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 ""]} {
set args *.tcl
}
! foreach file [eval glob $args] {
set f ""
set error [catch {
set f [open $file]
--- 216,225 ----
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 {[llength $args] == 0} {
set args *.tcl
}
! foreach file [glob {expand}$args] {
set f ""
set error [catch {
set f [open $file]
Index: library/package.tcl
===================================================================
RCS file: /cvsroot/tcl/tcl/library/package.tcl,v
retrieving revision 1.26
diff -c -r1.26 package.tcl
*** library/package.tcl 24 Sep 2003 18:07:45 -0000 1.26
--- library/package.tcl 7 Nov 2003 13:27:00 -0000
***************
*** 140,146 ****
set oldDir [pwd]
cd $dir
! if {[catch {eval glob $patternList} fileList]} {
global errorCode errorInfo
cd $oldDir
return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList
--- 140,146 ----
set oldDir [pwd]
cd $dir
! if {[catch {glob {expand}$patternList} fileList]} {
global errorCode errorInfo
cd $oldDir
return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList
***************
*** 206,212 ****
proc package {what args} {
switch -- $what {
require { return ; # ignore transitive requires }
! default { eval __package_orig {$what} $args }
}
}
proc tclPkgUnknown args {}
--- 206,212 ----
proc package {what args} {
switch -- $what {
require { return ; # ignore transitive requires }
! default { __package_orig $what {expand}$args }
}
}
proc tclPkgUnknown args {}
***************
*** 261,267 ****
proc ::tcl::GetAllNamespaces {{root ::}} {
set list $root
foreach ns [namespace children $root] {
! eval lappend list [::tcl::GetAllNamespaces $ns]
}
return $list
}
--- 261,267 ----
proc ::tcl::GetAllNamespaces {{root ::}} {
set list $root
foreach ns [namespace children $root] {
! lappend list {expand}[::tcl::GetAllNamespaces $ns]
}
return $list
}
Index: library/safe.tcl
===================================================================
RCS file: /cvsroot/tcl/tcl/library/safe.tcl,v
retrieving revision 1.11
diff -c -r1.11 safe.tcl
*** library/safe.tcl 16 Jul 2003 22:49:12 -0000 1.11
--- library/safe.tcl 7 Nov 2003 13:27:00 -0000
***************
*** 525,531 ****
# remove the hook now, otherwise if the hook
# calls us somehow, we'll loop
Unset $hookname
! if {[catch {eval $hook [list $slave]} err]} {
Log $slave "Delete hook error ($err)"
}
}
--- 525,531 ----
# remove the hook now, otherwise if the hook
# calls us somehow, we'll loop
Unset $hookname
! if {[catch {{expand}$hook $slave} err]} {
Log $slave "Delete hook error ($err)"
}
}
***************
*** 636,650 ****
}
# set/get values
proc Set {args} {
! eval [list Toplevel set] $args
}
# lappend on toplevel vars
proc Lappend {args} {
! eval [list Toplevel lappend] $args
}
# unset a var/token (currently just an global level eval)
proc Unset {args} {
! eval [list Toplevel unset] $args
}
# test existance
proc Exists {varname} {
--- 636,650 ----
}
# set/get values
proc Set {args} {
! Toplevel set {expand}$args
}
# lappend on toplevel vars
proc Lappend {args} {
! Toplevel lappend {expand}$args
}
# unset a var/token (currently just an global level eval)
proc Unset {args} {
! Toplevel unset {expand}$args
}
# test existance
proc Exists {varname} {
***************
*** 691,697 ****
proc Log {slave msg {type ERROR}} {
variable Log
if {[info exists Log] && [llength $Log]} {
! eval $Log [list "$type for slave $slave : $msg"]
}
}
--- 691,697 ----
proc Log {slave msg {type ERROR}} {
variable Log
if {[info exists Log] && [llength $Log]} {
! {expand}$Log "$type for slave $slave : $msg"
}
}
***************
*** 856,862 ****
proc Subset {slave command okpat args} {
set subcommand [lindex $args 0]
if {[regexp $okpat $subcommand]} {
! return [eval [list $command $subcommand] [lrange $args 1 end]]
}
set msg "not allowed to invoke subcommand $subcommand of $command"
Log $slave $msg
--- 856,862 ----
proc Subset {slave command okpat args} {
set subcommand [lindex $args 0]
if {[regexp $okpat $subcommand]} {
! return [$command $subcommand {expand}[lrange $args 1 end]]
}
set msg "not allowed to invoke subcommand $subcommand of $command"
Log $slave $msg
***************
*** 891,898 ****
set subcommand [lindex $args 0]
if {[regexp $okpat $subcommand]} {
! return [eval ::interp invokehidden $slave encoding $subcommand \
! [lrange $args 1 end]]
}
if {[string match $subcommand system]} {
--- 891,898 ----
set subcommand [lindex $args 0]
if {[regexp $okpat $subcommand]} {
! return [::interp invokehidden $slave encoding $subcommand \
! {expand}[lrange $args 1 end]]
}
if {[string match $subcommand system]} {
Index: tests/basic.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/basic.test,v
retrieving revision 1.29
diff -c -r1.29 basic.test
*** tests/basic.test 24 Jul 2003 16:05:24 -0000 1.29
--- tests/basic.test 7 Nov 2003 13:27:00 -0000
***************
*** 21,26 ****
--- 21,27 ----
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,213 ****
} {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_*]}
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 {rename value:at: ""}
list [testcreatecommand create2] \
[value:at:] \
--- 202,214 ----
} {42 {} {} Hello {} {} 42}
test basic-14.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {testcreatecommand} {
! 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 {namespace delete {expand}[namespace children :: test_ns_*]}
catch {rename value:at: ""}
list [testcreatecommand create2] \
[value:at:] \
***************
*** 215,221 ****
} {{} {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_*]}
namespace eval test_ns_basic {}
proc test_ns_basic::cmd {} { ;# proc requires that ns already exist
return [namespace current]
--- 216,222 ----
} {{} {CreatedCommandProc2 in ::} {}}
test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} {
! 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,237 ****
} {}
test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename cmd ""}
namespace eval test_ns_basic {
proc p {} {
--- 232,238 ----
} {}
test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
catch {rename cmd ""}
namespace eval test_ns_basic {
proc p {} {
***************
*** 243,253 ****
[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_*]}
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_*]}
namespace eval test_ns_basic {
proc p {} {
return "p in [namespace current]"
--- 244,254 ----
[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 {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 {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_basic {
proc p {} {
return "p in [namespace current]"
***************
*** 258,264 ****
[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_*]}
namespace eval test_ns_basic {
proc p {} {
return "p in [namespace current]"
--- 259,265 ----
[info commands test_ns_basic::*]
} {::test_ns_basic::p {} {}}
test basic-18.4 {TclRenameCommand, bad new name} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_basic {
proc p {} {
return "p in [namespace current]"
***************
*** 275,281 ****
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 {rename p ""}
catch {rename q ""}
proc p {} {
--- 276,282 ----
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 {namespace delete {expand}[namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename q ""}
proc p {} {
***************
*** 298,304 ****
} {}
test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {testcmdtoken} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename q ""}
catch {unset x}
--- 299,305 ----
} {}
test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {testcmdtoken} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename q ""}
catch {unset x}
***************
*** 317,323 ****
[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} {
catch {rename \# ""}
set x [testcmdtoken create \#]
testcmdtoken name $x
--- 318,324 ----
[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} testcmdtoken {
catch {rename \# ""}
set x [testcmdtoken create \#]
testcmdtoken name $x
***************
*** 327,333 ****
} {}
test basic-22.1 {Tcl_GetCommandFullName} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_basic1 {
namespace export cmd*
proc cmd1 {} {}
--- 328,334 ----
} {}
test basic-22.1 {Tcl_GetCommandFullName} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_basic1 {
namespace export cmd*
proc cmd1 {} {}
***************
*** 373,379 ****
[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 {rename p ""}
proc p {} {
return "global p"
--- 374,380 ----
[interp delete test_interp]
} {123 {set called with a 123} {}}
test basic-24.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
catch {rename p ""}
proc p {} {
return "global p"
***************
*** 391,397 ****
[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 {rename p ""}
namespace eval test_ns_basic {
namespace export p
--- 392,398 ----
[test_ns_basic::callP]
} {{namespace p} {} {global p}}
test basic-24.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
catch {rename p ""}
namespace eval test_ns_basic {
namespace export p
***************
*** 459,465 ****
} {}
test basic-36.1 {TclObjInvoke, lookup of "unknown" command} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
--- 460,466 ----
} {}
test basic-36.1 {TclObjInvoke, lookup of "unknown" command} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
***************
*** 587,595 ****
subst {a[set b [format cd]}
} -returnCodes error -result {missing close-bracket}
! # cleanup
! catch {eval namespace delete [namespace children :: test_ns_*]}
catch {namespace delete george}
catch {interp delete test_interp}
catch {rename p ""}
--- 588,913 ----
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} $constraints {
+ list [catch {run {{expand}\{}}] $::errorInfo
+ } {1 {unmatched open brace in list
+ (expanding word 0)
+ invoked from within
+ "{expand}\{"
+ invoked from within
+ "run {{expand}\{}"}}
+
+ test basic-47.3.$noComp {Tcl_EvalEx, error during substitution} $constraints {
+ list [catch {run {{expand}[error foo]}}] $::errorInfo
+ } {1 {foo
+ while executing
+ "error foo"
+ invoked from within
+ "{expand}[error foo]"
+ invoked from within
+ "run {{expand}[error 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 {namespace delete {expand}[namespace children :: test_ns_*]}
catch {namespace delete george}
catch {interp delete test_interp}
catch {rename p ""}
Index: tests/cmdInfo.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/cmdInfo.test,v
retrieving revision 1.7
diff -c -r1.7 cmdInfo.test
*** tests/cmdInfo.test 22 Jun 2002 04:19:47 -0000 1.7
--- tests/cmdInfo.test 7 Nov 2003 13:27:00 -0000
***************
*** 71,77 ****
rename x1 newName
set y [testcmdtoken name $x]
rename newName x1
! eval lappend y [testcmdtoken name $x]
} {newName ::newName x1 ::x1}
catch {rename newTestCmd {}}
--- 71,77 ----
rename x1 newName
set y [testcmdtoken name $x]
rename newName x1
! lappend y {expand}[testcmdtoken name $x]
} {newName ::newName x1 ::x1}
catch {rename newTestCmd {}}
***************
*** 88,94 ****
}]
set y [testcmdtoken name $x]
rename ::testCmd newTestCmd
! eval lappend y [testcmdtoken name $x]
} {testCmd ::testCmd newTestCmd ::newTestCmd}
test cmdinfo-6.1 {Names for commands created when outside namespaces} \
--- 88,94 ----
}]
set y [testcmdtoken name $x]
rename ::testCmd newTestCmd
! lappend y {expand}[testcmdtoken name $x]
} {testCmd ::testCmd newTestCmd ::newTestCmd}
test cmdinfo-6.1 {Names for commands created when outside namespaces} \
***************
*** 96,102 ****
set x [testcmdtoken create cmdInfoNs1::cmdInfoNs2::testCmd]
set y [testcmdtoken name $x]
rename cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2
! eval lappend y [testcmdtoken name $x]
} {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2}
# cleanup
--- 96,102 ----
set x [testcmdtoken create cmdInfoNs1::cmdInfoNs2::testCmd]
set y [testcmdtoken name $x]
rename cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2
! lappend y {expand}[testcmdtoken name $x]
} {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2}
# cleanup
Index: tests/compile.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/compile.test,v
retrieving revision 1.27
diff -c -r1.27 compile.test
*** tests/compile.test 9 May 2003 13:42:40 -0000 1.27
--- tests/compile.test 7 Nov 2003 13:27:00 -0000
***************
*** 274,282 ****
#
# Special test for leak on interp delete [Bug 467523].
::tcltest::testConstraint exec [llength [info commands exec]]
! ::tcltest::testConstraint memDebug [llength [info commands memory]]
! test compile-12.1 {testing literal leak on interp delete} {memDebug} {
proc getbytes {} {
set lines [split [memory info] "\n"]
lindex [lindex $lines 3] 3
--- 274,282 ----
#
# Special test for leak on interp delete [Bug 467523].
::tcltest::testConstraint exec [llength [info commands exec]]
! ::tcltest::testConstraint memory [llength [info commands memory]]
! 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,304 ****
# 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} {
makeFile {
for {set i 0} {$i < 5} {incr i} {
namespace eval bar {}
--- 298,304 ----
# 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} {memory exec} {
makeFile {
for {set i 0} {$i < 5} {incr i} {
namespace eval bar {}
***************
*** 373,378 ****
--- 373,509 ----
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 ""}
Index: tests/encoding.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/encoding.test,v
retrieving revision 1.18
diff -c -r1.18 encoding.test
*** tests/encoding.test 27 Mar 2003 21:44:05 -0000 1.18
--- tests/encoding.test 7 Nov 2003 13:27:00 -0000
***************
*** 541,547 ****
}
}
! eval [list file delete] [glob -directory [temporaryDirectory] *.chars *.tcltestout]
# ===> Cut here <===
# EscapeFreeProc, GetTableEncoding, unilen
--- 541,547 ----
}
}
! file delete {expand}[glob -directory [temporaryDirectory] *.chars *.tcltestout]
# ===> Cut here <===
# EscapeFreeProc, GetTableEncoding, unilen
Index: tests/execute.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/execute.test,v
retrieving revision 1.15
diff -c -r1.15 execute.test
*** tests/execute.test 4 Oct 2003 16:12:12 -0000 1.15
--- tests/execute.test 7 Nov 2003 13:27:00 -0000
***************
*** 21,27 ****
namespace import -force ::tcltest::*
}
! catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
catch {unset y}
--- 21,27 ----
namespace import -force ::tcltest::*
}
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
catch {unset y}
***************
*** 507,513 ****
# INST_PUSH_RETURN_CODE not tested
test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
catch {unset x}
catch {unset y}
namespace eval test_ns_1 {
--- 507,513 ----
# INST_PUSH_RETURN_CODE not tested
test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
catch {unset x}
catch {unset y}
namespace eval test_ns_1 {
***************
*** 525,531 ****
[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 {rename foo ""}
catch {unset l}
proc foo {} {
--- 525,531 ----
[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 {namespace delete {expand}[namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset l}
proc foo {} {
***************
*** 547,553 ****
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 {rename foo ""}
namespace eval test_ns_1 {
proc foo {} {
--- 547,553 ----
set l
} {::foo ::test_ns_1::foo}
test execute-4.3 {Tcl_GetCommandFromObj, command never found} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
catch {rename foo ""}
namespace eval test_ns_1 {
proc foo {} {
***************
*** 565,571 ****
} {::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 {unset l}
proc {} {} {return {}}
{}
--- 565,571 ----
} {::test_ns_1::foo {} 0 {}}
test execute-5.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
catch {unset l}
proc {} {} {return {}}
{}
***************
*** 734,740 ****
if {[info commands testobj] != {}} {
testobj freeallvars
}
! catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename foo ""}
catch {rename p ""}
catch {rename {} ""}
--- 734,740 ----
if {[info commands testobj] != {}} {
testobj freeallvars
}
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
catch {rename foo ""}
catch {rename p ""}
catch {rename {} ""}
Index: tests/fCmd.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/fCmd.test,v
retrieving revision 1.31
diff -c -r1.31 fCmd.test
*** tests/fCmd.test 7 Oct 2003 16:00:33 -0000 1.31
--- tests/fCmd.test 7 Nov 2003 13:27:01 -0000
***************
*** 2194,2200 ****
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]
} {0 {}}
# Find a group that exists on this Unix system, or else skip tests that
--- 2194,2200 ----
catch {file delete -force -- foo.tmp}
createfile foo.tmp
set attrs [file attributes 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,2226 ****
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]
} {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]
} {0 {} {}}
if {[string equal $tcl_platform(platform) "windows"]} {
--- 2214,2226 ----
catch {file delete -force -- foo.tmp}
createfile foo.tmp
set attrs [file attributes 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 {file attributes foo.tmp {expand}[lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}
if {[string equal $tcl_platform(platform) "windows"]} {
Index: tests/http.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/http.test,v
retrieving revision 1.35
diff -c -r1.35 http.test
*** tests/http.test 18 Jul 2003 19:36:40 -0000 1.35
--- tests/http.test 7 Nov 2003 13:27:01 -0000
***************
*** 100,106 ****
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
set x
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}
--- 100,106 ----
set savedconf [http::config]
http::config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
set x [http::config]
! http::config {expand}$savedconf
set x
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}
Index: tests/init.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/init.test,v
retrieving revision 1.11
diff -c -r1.11 init.test
*** tests/init.test 27 Jun 2003 17:22:41 -0000 1.11
--- tests/init.test 7 Nov 2003 13:27:01 -0000
***************
*** 18,24 ****
}
# Clear out any namespaces called test_ns_*
! catch {eval namespace delete [namespace children :: test_ns_*]}
# Six cases - white box testing
--- 18,24 ----
}
# Clear out any namespaces called test_ns_*
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
# Six cases - white box testing
Index: tests/interp.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/interp.test,v
retrieving revision 1.24
diff -c -r1.24 interp.test
*** tests/interp.test 4 Sep 2003 17:36:56 -0000 1.24
--- tests/interp.test 7 Nov 2003 13:27:01 -0000
***************
*** 2084,2090 ****
proc MyTestAlias {interp args} {
global aliasTrace;
lappend aliasTrace $args;
! eval interp invokehidden [list $interp] $args
}
foreach c {return} {
interp hide $interp $c;
--- 2084,2090 ----
proc MyTestAlias {interp args} {
global aliasTrace;
lappend aliasTrace $args;
! interp invokehidden $interp {expand}$args
}
foreach c {return} {
interp hide $interp $c;
Index: tests/io.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/io.test,v
retrieving revision 1.47
diff -c -r1.47 io.test
*** tests/io.test 7 Oct 2003 21:45:39 -0000 1.47
--- tests/io.test 7 Nov 2003 13:27:01 -0000
***************
*** 2147,2153 ****
close $f
lappend l [lsort [testchannel open]]
set x [list $consoleFileNames \
! [lsort [eval list $consoleFileNames $f]] \
$consoleFileNames]
string compare $l $x
} 0
--- 2147,2153 ----
close $f
lappend l [lsort [testchannel open]]
set x [list $consoleFileNames \
! [lsort [list {expand}$consoleFileNames $f]] \
$consoleFileNames]
string compare $l $x
} 0
Index: tests/ioUtil.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/ioUtil.test,v
retrieving revision 1.14
diff -c -r1.14 ioUtil.test
*** tests/ioUtil.test 11 Apr 2003 16:00:00 -0000 1.14
--- tests/ioUtil.test 7 Nov 2003 13:27:01 -0000
***************
*** 191,197 ****
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 exists testOpenFileChannel1%.fil} err1
catch {file exists testOpenFileChannel2%.fil} err2
catch {file exists testOpenFileChannel3%.fil} err3
--- 191,197 ----
cd [temporaryDirectory]
test ioUtil-3.1 {TclOpenFileChannel: Check that none of the test procs are there.} {testopenfilechannelproc} {
! 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
Index: tests/iogt.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/iogt.test,v
retrieving revision 1.7
diff -c -r1.7 iogt.test
*** tests/iogt.test 4 Jul 2002 15:46:55 -0000 1.7
--- tests/iogt.test 7 Nov 2003 13:27:01 -0000
***************
*** 147,154 ****
# 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 &
after 500
--- 147,154 ----
# fixed port, not so good. lets hope for the best, for now.
set port 4000
! exec tclsh __echo_srv__.tcl \
! $port $fdelay $idelay {expand}$blocks >@stdout &
after 500
Index: tests/lindex.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/lindex.test,v
retrieving revision 1.10
diff -c -r1.10 lindex.test
*** tests/lindex.test 19 Apr 2002 13:08:56 -0000 1.10
--- tests/lindex.test 7 Nov 2003 13:27:01 -0000
***************
*** 19,86 ****
namespace import -force ::tcltest::*
}
- set lindex lindex
set minus -
# Tests of Tcl_LindexObjCmd, NOT COMPILED
! test lindex-1.1 {wrong # args} {
! list [catch {eval $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} {
set x {}
! list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {{a b c} {a b c}}
! test lindex-2.2 {singleton index list} {
set x { 1 }
! list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {b b}
! test lindex-2.3 {multiple indices in list} {
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]]
} {f f}
! test lindex-2.4 {malformed index list} {
set x \{
! list [catch { eval [list $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} {
set x ${minus}1
! list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {{} {}}
! test lindex-3.2 {integer 0} {
set x [string range 00 0 0]
! list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {a a}
! test lindex-3.3 {integer 2} {
set x [string range 22 0 0]
! list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {c c}
! test lindex-3.4 {integer 3} {
set x [string range 33 0 0]
! list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {{} {}}
! test lindex-3.5 {bad octal} {
set x 08
! list [catch { eval [list $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} {
set x -09
! list [catch { eval [list $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} {
--- 19,86 ----
namespace import -force ::tcltest::*
}
set minus -
+ testConstraint testevalex [llength [info commands testevalex]]
# Tests of Tcl_LindexObjCmd, NOT COMPILED
! 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} testevalex {
set 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} testevalex {
set x { 1 }
! list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {b b}
! test lindex-2.3 {multiple indices in list} testevalex {
set x {1 2}
! 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} testevalex {
set x \{
! 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} testevalex {
set x ${minus}1
! list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {{} {}}
! test lindex-3.2 {integer 0} testevalex {
set x [string range 00 0 0]
! list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {a a}
! test lindex-3.3 {integer 2} testevalex {
set x [string range 22 0 0]
! list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {c c}
! test lindex-3.4 {integer 3} testevalex {
set x [string range 33 0 0]
! list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {{} {}}
! test lindex-3.5 {bad octal} testevalex {
set x 08
! 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} testevalex {
set x -09
! 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,211 ****
# Indices relative to end
! test lindex-4.1 {index = end} {
set x end
! list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {c c}
! test lindex-4.2 {index = end--1} {
set x end--1
! list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {{} {}}
! test lindex-4.3 {index = end-0} {
set x end-0
! list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {c c}
! test lindex-4.4 {index = end-2} {
set x end-2
! list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {a a}
! test lindex-4.5 {index = end-3} {
set x end-3
! list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {{} {}}
! test lindex-4.6 {bad octal} {
set x end-08
! list [catch { eval [list $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} {
set x end--09
! list [catch { eval [list $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} {
set x end-0a2
! list [catch { eval [list $lindex {a b c} $x] } result] $result
} "1 {bad index \"end-0a2\": must be integer or end?-integer?}"
! test lindex-4.9 {incomplete end} {
set x en
! list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
} {c c}
! test lindex-4.10 {incomplete end-} {
set x end-
! list [catch { eval [list $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
} "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]
} f
! test lindex-5.3 {three indices} {
! eval [list $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
} {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
} {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
} {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]
} {b c}
! test lindex-7.2 {quoted elements} {
! eval [list $lindex {"{}" b c} 0]
} {{}}
! test lindex-7.3 {quoted elements} {
! eval [list $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} {
set x 0
! eval [list $lindex $x $x]
} {0}
! test lindex-8.2 {data reuse} {
set a 0
! eval [list $lindex $a $a $a]
} 0
! test lindex-8.3 {data reuse} {
set a 1
! eval [list $lindex $a $a $a]
} {}
! test lindex-8.4 {data reuse} {
set x [list 0 0]
! eval [list $lindex $x $x]
} {0}
! test lindex-8.5 {data reuse} {
set x 0
! eval [list $lindex $x [list $x $x]]
} {0}
! test lindex-8.6 {data reuse} {
set x [list 1 1]
! eval [list $lindex $x $x]
} {}
! test lindex-8.7 {data reuse} {
set x 1
! eval [list lindex $x [list $x $x]]
} {}
#----------------------------------------------------------------------
--- 90,211 ----
# Indices relative to end
! test lindex-4.1 {index = end} testevalex {
set x end
! list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {c c}
! test lindex-4.2 {index = end--1} testevalex {
set x end--1
! list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {{} {}}
! test lindex-4.3 {index = end-0} testevalex {
set x end-0
! list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {c c}
! test lindex-4.4 {index = end-2} testevalex {
set x end-2
! list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {a a}
! test lindex-4.5 {index = end-3} testevalex {
set x end-3
! list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {{} {}}
! test lindex-4.6 {bad octal} testevalex {
set x end-08
! 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} testevalex {
set x end--09
! 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} testevalex {
set x end-0a2
! 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} testevalex {
set x en
! list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {c c}
! test lindex-4.10 {incomplete end-} testevalex {
set x end-
! 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} 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} testevalex {
! testevalex {lindex {{a b c} {d e f} {g h i}} 1 2}
} f
! 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} testevalex {
! list [catch {testevalex {lindex "a \{" 2}} msg] $msg
} {1 {unmatched open brace in list}}
! 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} 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} testevalex {
! testevalex {lindex {a "b c" d} 1}
} {b c}
! test lindex-7.2 {quoted elements} testevalex {
! testevalex {lindex {"{}" b c} 0}
} {{}}
! 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} testevalex {
set x 0
! testevalex {lindex $x $x}
} {0}
! test lindex-8.2 {data reuse} testevalex {
set a 0
! testevalex {lindex $a $a $a}
} 0
! test lindex-8.3 {data reuse} testevalex {
set a 1
! testevalex {lindex $a $a $a}
} {}
! test lindex-8.4 {data reuse} testevalex {
set x [list 0 0]
! testevalex {lindex $x $x}
} {0}
! test lindex-8.5 {data reuse} testevalex {
set x 0
! testevalex {lindex $x [list $x $x]}
} {0}
! test lindex-8.6 {data reuse} testevalex {
set x [list 1 1]
! testevalex {lindex $x $x}
} {}
! test lindex-8.7 {data reuse} testevalex {
set x 1
! testevalex {lindex $x [list $x $x]}
} {}
#----------------------------------------------------------------------
***************
*** 469,475 ****
set result
} {}
- catch { unset lindex}
catch { unset minus }
# cleanup
--- 469,474 ----
Index: tests/lset.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/lset.test,v
retrieving revision 1.3
diff -c -r1.3 lset.test
*** tests/lset.test 23 Nov 2001 01:26:10 -0000 1.3
--- tests/lset.test 7 Nov 2003 13:27:01 -0000
***************
*** 22,448 ****
error "trace failed"
}
! set lset lset
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
} "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
} "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
} "1 {can't read \"noRead\": trace failed}"
! test lset-2.1 {lset, not compiled, 3 args, second arg a plain index} {
set x {0 1 2}
! list [eval [list $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} {
set x {0 1 2}
list [catch {
! eval [list $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} {
set x {0 1 2}
! list [eval [list $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} {
set x {0 1}
set y $x
! list [eval [list $lset x 0 2]] $x $y
} {{2 1} {2 1} {0 1}}
! test lset-3.3 {lset, not compiled, 3 args, data duplicated} {
set x {0 1}
set y $x
! list [eval [list $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} {
set x {0 1 2}
! list [eval [list $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} {
set x {0 1}
set y $x
! list [eval [list $lset x [list 0] 2]] $x $y
} {{2 1} {2 1} {0 1}}
! test lset-3.6 {lset, not compiled, 3 args, data duplicated} {
set x {0 1}
set y $x
! list [eval [list $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} {
set a "x \{"
list [catch {
! eval [list $lset a [list 0] y]
} msg] $msg
} {1 {unmatched open brace in list}}
! test lset-4.2 {lset, not compiled, 3 args, bad index} {
set a {x y z}
list [catch {
! eval [list $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} {
set a {x y z}
list [catch {
! eval [list $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} {
set a {x y z}
list [catch {
! eval [list $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} {
set a {x y z}
list [catch {
! eval [list $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} {
set a {x y z}
list [catch {
! eval [list $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} {
set a "x \{"
list [catch {
! eval [list $lset a 0 y]
} msg] $msg
} {1 {unmatched open brace in list}}
! test lset-4.8 {lset, not compiled, 3 args, bad index} {
set a {x y z}
list [catch {
! eval [list $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} {
set a {x y z}
list [catch {
! eval [list $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} {
set a {x y z}
list [catch {
! eval [list $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} {
set a {x y z}
list [catch {
! eval [list $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} {
set a {x y z}
list [catch {
! eval [list $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} {
list [catch {
! eval [list $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} {
list [catch {
! eval [list $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} {
set a {x y z}
! list [eval [list $lset a 0 a]] $a
} {{a y z} {a y z}}
! test lset-6.2 {lset, not compiled, 3 args, 1-d list basics} {
set a {x y z}
! list [eval [list $lset a [list 0] a]] $a
} {{a y z} {a y z}}
! test lset-6.3 {lset, not compiled, 1-d list basics} {
set a {x y z}
! list [eval [list $lset a 2 a]] $a
} {{x y a} {x y a}}
! test lset-6.4 {lset, not compiled, 1-d list basics} {
set a {x y z}
! list [eval [list $lset a [list 2] a]] $a
} {{x y a} {x y a}}
! test lset-6.5 {lset, not compiled, 1-d list basics} {
set a {x y z}
! list [eval [list $lset a end a]] $a
} {{x y a} {x y a}}
! test lset-6.6 {lset, not compiled, 1-d list basics} {
set a {x y z}
! list [eval [list $lset a [list end] a]] $a
} {{x y a} {x y a}}
! test lset-6.7 {lset, not compiled, 1-d list basics} {
set a {x y z}
! list [eval [list $lset a end-0 a]] $a
} {{x y a} {x y a}}
! test lset-6.8 {lset, not compiled, 1-d list basics} {
set a {x y z}
! list [eval [list $lset a [list end-0] a]] $a
} {{x y a} {x y a}}
! test lset-6.9 {lset, not compiled, 1-d list basics} {
set a {x y z}
! list [eval [list $lset a end-2 a]] $a
} {{a y z} {a y z}}
! test lset-6.10 {lset, not compiled, 1-d list basics} {
set a {x y z}
! list [eval [list $lset a [list end-2] a]] $a
} {{a y z} {a y z}}
! test lset-7.1 {lset, not compiled, data sharing} {
set a 0
! list [eval [list $lset a $a {gag me}]] $a
} {{{gag me}} {{gag me}}}
! test lset-7.2 {lset, not compiled, data sharing} {
set a [list 0]
! list [eval [list $lset a $a {gag me}]] $a
} {{{gag me}} {{gag me}}}
! test lset-7.3 {lset, not compiled, data sharing} {
set a {x y}
! list [eval [list $lset a 0 $a]] $a
} {{{x y} y} {{x y} y}}
! test lset-7.4 {lset, not compiled, data sharing} {
set a {x y}
! list [eval [list $lset a [list 0] $a]] $a
} {{{x y} y} {{x y} y}}
! test lset-7.5 {lset, not compiled, data sharing} {
set n 0
set a {x y}
! list [eval [list $lset a $n $n]] $a $n
} {{0 y} {0 y} 0}
! test lset-7.6 {lset, not compiled, data sharing} {
set n [list 0]
set a {x y}
! list [eval [list $lset a $n $n]] $a $n
} {{0 y} {0 y} 0}
! test lset-7.7 {lset, not compiled, data sharing} {
set n 0
set a [list $n $n]
! list [eval [list $lset a $n 1]] $a $n
} {{1 0} {1 0} 0}
! test lset-7.8 {lset, not compiled, data sharing} {
set n [list 0]
set a [list $n $n]
! list [eval [list $lset a $n 1]] $a $n
} {{1 0} {1 0} 0}
! test lset-7.9 {lset, not compiled, data sharing} {
set a 0
! list [eval [list $lset a $a $a]] $a
} {0 0}
! test lset-7.10 {lset, not compiled, data sharing} {
set a [list 0]
! list [eval [list $lset a $a $a]] $a
} {0 0}
! test lset-8.1 {lset, not compiled, malformed sublist} {
set a [list "a \{" b]
! list [catch {eval [list $lset a 0 1 c]} msg] $msg
} {1 {unmatched open brace in list}}
! test lset-8.2 {lset, not compiled, malformed sublist} {
set a [list "a \{" b]
! list [catch {eval [list $lset a {0 1} c]} msg] $msg
} {1 {unmatched open brace in list}}
! test lset-8.3 {lset, not compiled, bad second index} {
set a {{b c} {d e}}
! list [catch {eval [list $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} {
set a {{b c} {d e}}
! list [catch {eval [list $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} {
set a {{b c} {d e} {f g}}
! list [catch {eval [list $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} {
set a {{b c} {d e} {f g}}
! list [catch {eval [list $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} {
set a {{b c} {d e} {f g}}
! list [catch {eval [list $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} {
set a {{b c} {d e} {f g}}
! list [catch {eval [list $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} {
set a {{b c} {d e} {f g}}
! list [catch {eval [list $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} {
set a {{b c} {d e} {f g}}
! list [catch {eval [list $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} {
set a {{b c} {d e} {f g}}
! list [catch {eval [list $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} {
set a {{b c} {d e} {f g}}
! list [catch {eval [list $lset a {2 end-2} h]} msg] $msg
} {1 {list index out of range}}
! test lset-9.1 {lset, not compiled, entire variable} {
set a x
! list [eval [list $lset a y]] $a
} {y y}
! test lset-9.2 {lset, not compiled, entire variable} {
set a x
! list [eval [list $lset a {} y]] $a
} {y y}
! test lset-10.1 {lset, not compiled, shared data} {
set row {p q}
set a [list $row $row]
! list [eval [list $lset a 0 0 x]] $a
} {{{x q} {p q}} {{x q} {p q}}}
! test lset-10.2 {lset, not compiled, shared data} {
set row {p q}
set a [list $row $row]
! list [eval [list $lset a {0 0} x]] $a
} {{{x q} {p q}} {{x q} {p q}}}
! test lset-11.1 {lset, not compiled, 2-d basics} {
set a {{b c} {d e}}
! list [eval [list $lset a 0 0 f]] $a
} {{{f c} {d e}} {{f c} {d e}}}
! test lset-11.2 {lset, not compiled, 2-d basics} {
set a {{b c} {d e}}
! list [eval [list $lset a {0 0} f]] $a
} {{{f c} {d e}} {{f c} {d e}}}
! test lset-11.3 {lset, not compiled, 2-d basics} {
set a {{b c} {d e}}
! list [eval [list $lset a 0 1 f]] $a
} {{{b f} {d e}} {{b f} {d e}}}
! test lset-11.4 {lset, not compiled, 2-d basics} {
set a {{b c} {d e}}
! list [eval [list $lset a {0 1} f]] $a
} {{{b f} {d e}} {{b f} {d e}}}
! test lset-11.5 {lset, not compiled, 2-d basics} {
set a {{b c} {d e}}
! list [eval [list $lset a 1 0 f]] $a
} {{{b c} {f e}} {{b c} {f e}}}
! test lset-11.6 {lset, not compiled, 2-d basics} {
set a {{b c} {d e}}
! list [eval [list $lset a {1 0} f]] $a
} {{{b c} {f e}} {{b c} {f e}}}
! test lset-11.7 {lset, not compiled, 2-d basics} {
set a {{b c} {d e}}
! list [eval [list $lset a 1 1 f]] $a
} {{{b c} {d f}} {{b c} {d f}}}
! test lset-11.8 {lset, not compiled, 2-d basics} {
set a {{b c} {d e}}
! list [eval [list $lset a {1 1} f]] $a
} {{{b c} {d f}} {{b c} {d f}}}
! test lset-12.0 {lset, not compiled, typical sharing pattern} {
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]
}
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} {
set a 0
! list [eval [list $lset a $a $a $a $a {gag me}]] $a
} {{{{{{gag me}}}}} {{{{{gag me}}}}}}
! test lset-13.1 {lset, not compiled, shimmering hell} {
set a [list 0]
! list [eval [list $lset a $a $a $a $a {gag me}]] $a
} {{{{{{gag me}}}}} {{{{{gag me}}}}}}
! test lset-13.2 {lset, not compiled, shimmering hell} {
set a [list 0 0 0 0]
! list [eval [list $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?} {
set a { { 1 2 } { 3 4 } }
! catch { eval [list $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?} {
set a { { 1 2 } { 3 4 } }
! catch { eval [list $lset a 1 5 5] }
list $a [lindex $a 1]
} "{ { 1 2 } { 3 4 } } { 3 4 }"
--- 22,448 ----
error "trace failed"
}
! 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} 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} 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} 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} testevalex {
set x {0 1 2}
! 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} testevalex {
set x {0 1 2}
list [catch {
! 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} testevalex {
set x {0 1 2}
! 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} testevalex {
set x {0 1}
set y $x
! 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} testevalex {
set x {0 1}
set y $x
! 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} testevalex {
set x {0 1 2}
! 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} testevalex {
set x {0 1}
set y $x
! 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} testevalex {
set x {0 1}
set y $x
! 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} testevalex {
set a "x \{"
list [catch {
! 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} testevalex {
set a {x y z}
list [catch {
! 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} testevalex {
set a {x y z}
list [catch {
! 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} testevalex {
set a {x y z}
list [catch {
! 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} testevalex {
set a {x y z}
list [catch {
! 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} testevalex {
set a {x y z}
list [catch {
! 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} testevalex {
set a "x \{"
list [catch {
! testevalex {lset a 0 y}
} msg] $msg
} {1 {unmatched open brace in list}}
! test lset-4.8 {lset, not compiled, 3 args, bad index} testevalex {
set a {x y z}
list [catch {
! 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} testevalex {
set a {x y z}
list [catch {
! 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} testevalex {
set a {x y z}
list [catch {
! 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} testevalex {
set a {x y z}
list [catch {
! 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} testevalex {
set a {x y z}
list [catch {
! 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} testevalex {
list [catch {
! 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} testevalex {
list [catch {
! 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} testevalex {
set a {x y z}
! 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} testevalex {
set a {x y z}
! 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} testevalex {
set a {x y z}
! list [testevalex {lset a 2 a}] $a
} {{x y a} {x y a}}
! test lset-6.4 {lset, not compiled, 1-d list basics} testevalex {
set a {x y z}
! 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} testevalex {
set a {x y z}
! list [testevalex {lset a end a}] $a
} {{x y a} {x y a}}
! test lset-6.6 {lset, not compiled, 1-d list basics} testevalex {
set a {x y z}
! 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} testevalex {
set a {x y z}
! 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} testevalex {
set a {x y z}
! 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} testevalex {
set a {x y z}
! 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} testevalex {
set a {x y z}
! list [testevalex {lset a [list end-2] a}] $a
} {{a y z} {a y z}}
! test lset-7.1 {lset, not compiled, data sharing} testevalex {
set a 0
! list [testevalex {lset a $a {gag me}}] $a
} {{{gag me}} {{gag me}}}
! test lset-7.2 {lset, not compiled, data sharing} testevalex {
set a [list 0]
! list [testevalex {lset a $a {gag me}}] $a
} {{{gag me}} {{gag me}}}
! test lset-7.3 {lset, not compiled, data sharing} testevalex {
set a {x y}
! list [testevalex {lset a 0 $a}] $a
} {{{x y} y} {{x y} y}}
! test lset-7.4 {lset, not compiled, data sharing} testevalex {
set a {x y}
! list [testevalex {lset a [list 0] $a}] $a
} {{{x y} y} {{x y} y}}
! test lset-7.5 {lset, not compiled, data sharing} testevalex {
set n 0
set a {x y}
! list [testevalex {lset a $n $n}] $a $n
} {{0 y} {0 y} 0}
! test lset-7.6 {lset, not compiled, data sharing} testevalex {
set n [list 0]
set a {x y}
! list [testevalex {lset a $n $n}] $a $n
} {{0 y} {0 y} 0}
! test lset-7.7 {lset, not compiled, data sharing} testevalex {
set n 0
set a [list $n $n]
! list [testevalex {lset a $n 1}] $a $n
} {{1 0} {1 0} 0}
! test lset-7.8 {lset, not compiled, data sharing} testevalex {
set n [list 0]
set a [list $n $n]
! list [testevalex {lset a $n 1}] $a $n
} {{1 0} {1 0} 0}
! test lset-7.9 {lset, not compiled, data sharing} testevalex {
set a 0
! list [testevalex {lset a $a $a}] $a
} {0 0}
! test lset-7.10 {lset, not compiled, data sharing} testevalex {
set a [list 0]
! list [testevalex {lset a $a $a}] $a
} {0 0}
! test lset-8.1 {lset, not compiled, malformed sublist} testevalex {
set a [list "a \{" b]
! 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} testevalex {
set a [list "a \{" b]
! 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} testevalex {
set a {{b c} {d e}}
! 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} testevalex {
set a {{b c} {d e}}
! 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} testevalex {
set a {{b c} {d e} {f g}}
! 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} testevalex {
set a {{b c} {d e} {f g}}
! 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} testevalex {
set a {{b c} {d e} {f g}}
! 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} testevalex {
set a {{b c} {d e} {f g}}
! 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} testevalex {
set a {{b c} {d e} {f g}}
! 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} testevalex {
set a {{b c} {d e} {f g}}
! 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} testevalex {
set a {{b c} {d e} {f g}}
! 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} testevalex {
set a {{b c} {d e} {f g}}
! 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} testevalex {
set a x
! list [testevalex {lset a y}] $a
} {y y}
! test lset-9.2 {lset, not compiled, entire variable} testevalex {
set a x
! list [testevalex {lset a {} y}] $a
} {y y}
! test lset-10.1 {lset, not compiled, shared data} testevalex {
set row {p q}
set a [list $row $row]
! 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} testevalex {
set row {p q}
set a [list $row $row]
! 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} testevalex {
set a {{b c} {d e}}
! 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} testevalex {
set a {{b c} {d e}}
! 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} testevalex {
set a {{b c} {d e}}
! 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} testevalex {
set a {{b c} {d e}}
! 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} testevalex {
set a {{b c} {d e}}
! 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} testevalex {
set a {{b c} {d e}}
! 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} testevalex {
set a {{b c} {d e}}
! 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} testevalex {
set a {{b c} {d e}}
! 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} 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 } {
! 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} testevalex {
set a 0
! list [testevalex {lset a $a $a $a $a {gag me}}] $a
} {{{{{{gag me}}}}} {{{{{gag me}}}}}}
! test lset-13.1 {lset, not compiled, shimmering hell} testevalex {
set a [list 0]
! list [testevalex {lset a $a $a $a $a {gag me}}] $a
} {{{{{{gag me}}}}} {{{{{gag me}}}}}}
! test lset-13.2 {lset, not compiled, shimmering hell} testevalex {
set a [list 0 0 0 0]
! 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?} testevalex {
set a { { 1 2 } { 3 4 } }
! 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?} testevalex {
set a { { 1 2 } { 3 4 } }
! catch { testevalex {lset a 1 5 5} }
list $a [lindex $a 1]
} "{ { 1 2 } { 3 4 } } { 3 4 }"
Index: tests/namespace-old.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/namespace-old.test,v
retrieving revision 1.6
diff -c -r1.6 namespace-old.test
*** tests/namespace-old.test 7 Apr 2001 02:11:19 -0000 1.6
--- tests/namespace-old.test 7 Nov 2003 13:27:01 -0000
***************
*** 22,28 ****
}
# Clear out any namespaces called test_ns_*
! catch {eval namespace delete [namespace children :: test_ns_*]}
test namespace-old-1.1 {usage for "namespace" command} {
list [catch {namespace} msg] $msg
--- 22,28 ----
}
# Clear out any namespaces called 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,258 ****
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?]
}
}
list [catch $cmd msg] $msg [namespace children test_ns_delete]
--- 251,258 ----
test namespace-old-4.4 {command "namespace delete" handles multiple args} {
set cmd {
namespace eval test_ns_delete {
! namespace delete \
! {expand}[namespace children [namespace current] ns?]
}
}
list [catch $cmd msg] $msg [namespace children test_ns_delete]
Index: tests/namespace.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/namespace.test,v
retrieving revision 1.22
diff -c -r1.22 namespace.test
*** tests/namespace.test 29 Sep 2003 14:37:14 -0000 1.22
--- tests/namespace.test 7 Nov 2003 13:27:01 -0000
***************
*** 19,25 ****
}
# Clear out any namespaces called test_ns_*
! catch {eval namespace delete [namespace children :: test_ns_*]}
test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {
namespace children :: test_ns_*
--- 19,25 ----
}
# Clear out any namespaces called test_ns_*
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {
namespace children :: test_ns_*
***************
*** 79,85 ****
} {123}
test namespace-6.1 {Tcl_CreateNamespace} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
list [lsort [namespace children :: test_ns_*]] \
[namespace eval test_ns_1 {namespace current}] \
[namespace eval test_ns_2 {namespace current}] \
--- 79,85 ----
} {123}
test namespace-6.1 {Tcl_CreateNamespace} {
! 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,104 ****
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_*]}
namespace eval test_ns_1:: {
namespace eval test_ns_2:: {}
namespace eval test_ns_3:: {}
--- 98,104 ----
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 {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_1:: {
namespace eval test_ns_2:: {}
namespace eval test_ns_3:: {}
***************
*** 116,122 ****
} {::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_*]}
namespace eval test_ns_1 {
proc p {} {
namespace delete [namespace current]
--- 116,122 ----
} {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_2}
test namespace-7.1 {Tcl_DeleteNamespace, active call frames in ns} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
proc p {} {
namespace delete [namespace current]
***************
*** 161,167 ****
[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_*]}
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] \
--- 161,167 ----
[interp delete test_interp]
} {{::test_ns_1 27} {} 1 {invalid command name "set"} {}}
test namespace-8.2 {TclTeardownNamespace, remove deleted ns from parent} {
! 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,175 ****
[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_*]}
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,175 ----
[namespace children test_ns_1]
} {::test_ns_1::test_ns_2 {} {}}
test namespace-8.3 {TclTeardownNamespace, delete child namespaces} {
! 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,185 ****
[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_*]}
namespace eval test_ns_export {
namespace export cmd1 cmd2
proc cmd1 {args} {return "cmd1: $args"}
--- 179,185 ----
[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 {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1 cmd2
proc cmd1 {args} {return "cmd1: $args"}
***************
*** 195,201 ****
} [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_*]}
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} {
--- 195,201 ----
} [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 {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,211 ****
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_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
--- 205,211 ----
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 {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
***************
*** 227,233 ****
}
} {cmd1: 555}
test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
--- 227,233 ----
}
} {cmd1: 555}
test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
***************
*** 245,251 ****
} {{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_*]}
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} {
--- 245,251 ----
} {{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 {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,277 ****
} [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_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
--- 271,277 ----
} [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 {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
***************
*** 295,301 ****
} {{cmd1: 123} ::test_ns_export::cmd1}
test namespace-12.1 {InvokeImportedCmd} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {namespace current}
--- 295,301 ----
} {{cmd1: 123} ::test_ns_export::cmd1}
test namespace-12.1 {InvokeImportedCmd} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {namespace current}
***************
*** 316,322 ****
} {::test_ns_import::cmd1 {}}
test namespace-14.1 {TclGetNamespaceForQualName, absolute names} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
variable v 10
namespace eval test_ns_1::test_ns_2 {
variable v 20
--- 316,322 ----
} {::test_ns_import::cmd1 {}}
test namespace-14.1 {TclGetNamespaceForQualName, absolute names} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
variable v 10
namespace eval test_ns_1::test_ns_2 {
variable v 20
***************
*** 394,400 ****
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_*]}
namespace eval test_ns_1 {
variable {}
set test_ns_1::(x) y
--- 394,400 ----
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 {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
variable {}
set test_ns_1::(x) y
***************
*** 402,413 ****
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_*]}
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_*]}
namespace eval test_ns_delete {
namespace eval test_ns_delete2 {}
proc cmd {args} {namespace current}
--- 402,413 ----
set test_ns_1::(x)
} y
test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} {
! 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 {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_delete {
namespace eval test_ns_delete2 {}
proc cmd {args} {namespace current}
***************
*** 434,440 ****
} {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_*]}
namespace eval test_ns_1 {
proc cmd {args} {return "[namespace current]::cmd: $args"}
variable v "::test_ns_1::cmd"
--- 434,440 ----
} {1 {unknown namespace "test_ns_delete2" in namespace delete command}}
test namespace-16.1 {Tcl_FindCommand, absolute name found} {
! 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,508 ****
catch {unset x}
test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
set x 314159
namespace eval test_ns_1 {
set ::x
--- 502,508 ----
catch {unset x}
test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
set x 314159
namespace eval test_ns_1 {
set ::x
***************
*** 565,571 ****
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_*]}
proc foo {} {return "global foo"}
namespace eval test_ns_1 {
proc trigger {} {
--- 565,571 ----
catch {unset l}
catch {rename foo {}}
test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
proc foo {} {return "global foo"}
namespace eval test_ns_1 {
proc trigger {} {
***************
*** 606,612 ****
catch {rename foo {}}
test namespace-19.1 {GetNamespaceFromObj, global name found} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
namespace children ::test_ns_1
} {::test_ns_1::test_ns_2}
--- 606,612 ----
catch {rename foo {}}
test namespace-19.1 {GetNamespaceFromObj, global name found} {
! 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,642 ****
} {{} ::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_*]}
list [catch {namespace} msg] $msg
} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}}
test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} {
--- 636,642 ----
} {{} ::test_ns_1::test_ns_2::test_ns_3}
test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} {
! 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,653 ****
} {}
test namespace-21.1 {NamespaceChildrenCmd, no args} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
expr {[string first ::test_ns_1 [namespace children]] != -1}
} {1}
--- 647,653 ----
} {}
test namespace-21.1 {NamespaceChildrenCmd, no args} {
! 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,685 ****
} [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_*]}
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"}}
--- 679,685 ----
} [lsort {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo}]
test namespace-22.1 {NamespaceCodeCmd, bad args} {
! 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,719 ****
} {42}
test namespace-23.1 {NamespaceCurrentCmd, bad args} {
! catch {eval namespace delete [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"}}
--- 713,719 ----
} {42}
test namespace-23.1 {NamespaceCurrentCmd, bad args} {
! 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,733 ****
} {::test_ns_1::test_ns_2}
test namespace-24.1 {NamespaceDeleteCmd, no args} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
namespace delete
} {}
test namespace-24.2 {NamespaceDeleteCmd, one arg} {
--- 727,733 ----
} {::test_ns_1::test_ns_2}
test namespace-24.1 {NamespaceDeleteCmd, no args} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
namespace delete
} {}
test namespace-24.2 {NamespaceDeleteCmd, one arg} {
***************
*** 743,749 ****
} {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_*]}
list [catch {namespace eval} msg] $msg
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-25.2 {NamespaceEvalCmd, bad args} {
--- 743,749 ----
} {1 {unknown namespace "::test_ns_foo" in namespace delete command}}
test namespace-25.1 {NamespaceEvalCmd, bad args} {
! 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,787 ****
catch {unset v}
test namespace-26.1 {NamespaceExportCmd, no args and new ns} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
namespace export
} {}
test namespace-26.2 {NamespaceExportCmd, just -clear arg} {
--- 781,787 ----
catch {unset v}
test namespace-26.1 {NamespaceExportCmd, no args and new ns} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
namespace export
} {}
test namespace-26.2 {NamespaceExportCmd, just -clear arg} {
***************
*** 830,836 ****
} [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_*]}
namespace forget
} {}
test namespace-27.2 {NamespaceForgetCmd, args must be valid namespaces} {
--- 830,836 ----
} [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}]
test namespace-27.1 {NamespaceForgetCmd, no args} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
namespace forget
} {}
test namespace-27.2 {NamespaceForgetCmd, args must be valid namespaces} {
***************
*** 850,856 ****
} {::test_ns_2::cmd2}
test namespace-28.1 {NamespaceImportCmd, no args} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
namespace import
} {}
test namespace-28.2 {NamespaceImportCmd, no args and just "-force"} {
--- 850,856 ----
} {::test_ns_2::cmd2}
test namespace-28.1 {NamespaceImportCmd, no args} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
namespace import
} {}
test namespace-28.2 {NamespaceImportCmd, no args and just "-force"} {
***************
*** 870,876 ****
} {::test_ns_2::cmd2}
test namespace-29.1 {NamespaceInscopeCmd, bad args} {
! catch {eval namespace delete [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} {
--- 870,876 ----
} {::test_ns_2::cmd2}
test namespace-29.1 {NamespaceInscopeCmd, bad args} {
! 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,901 ****
} {{::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_*]}
list [catch {namespace origin} msg] $msg
} {1 {wrong # args: should be "namespace origin name"}}
test namespace-30.2 {NamespaceOriginCmd, bad args} {
--- 895,901 ----
} {{::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 {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,934 ****
} {::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_*]}
list [catch {namespace parent a b} msg] $msg
} {1 {wrong # args: should be "namespace parent ?name?"}}
test namespace-31.2 {NamespaceParentCmd, no args} {
--- 928,934 ----
} {::foreach ::test_ns_2::p ::test_ns_1::cmd1 ::test_ns_1::cmd2}
test namespace-31.1 {NamespaceParentCmd, bad args} {
! 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,955 ****
} {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_*]}
list [catch {namespace qualifiers} msg] $msg
} {1 {wrong # args: should be "namespace qualifiers string"}}
test namespace-32.2 {NamespaceQualifiersCmd, bad args} {
--- 949,955 ----
} {1 {unknown namespace "test_ns_1::test_ns_foo" in namespace parent command}}
test namespace-32.1 {NamespaceQualifiersCmd, bad args} {
! 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,981 ****
} {foo}
test namespace-33.1 {NamespaceTailCmd, bad args} {
! catch {eval namespace delete [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} {
--- 975,981 ----
} {foo}
test namespace-33.1 {NamespaceTailCmd, bad args} {
! 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,1007 ****
} {}
test namespace-34.1 {NamespaceWhichCmd, bad args} {
! catch {eval namespace delete [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} {
--- 1001,1007 ----
} {}
test namespace-34.1 {NamespaceWhichCmd, bad args} {
! 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,1060 ****
} {::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_*]}
namespace eval test_ns_1 {
proc p {} {
namespace delete [namespace current]
--- 1054,1060 ----
} {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}}
test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
proc p {} {
namespace delete [namespace current]
***************
*** 1077,1083 ****
catch {unset x}
catch {unset y}
test namespace-36.1 {DupNsNameInternalRep} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1 {}
set x "::test_ns_1"
list [namespace parent $x] [set y $x] [namespace parent $y]
--- 1077,1083 ----
catch {unset x}
catch {unset y}
test namespace-36.1 {DupNsNameInternalRep} {
! 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,1092 ****
catch {unset y}
test namespace-37.1 {SetNsNameFromAny, ns name found} {
! catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
namespace eval test_ns_1 {
namespace children ::test_ns_1
--- 1086,1092 ----
catch {unset y}
test namespace-37.1 {SetNsNameFromAny, ns name found} {
! 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,1112 ****
} {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_*]}
;# 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_*]}
namespace eval ::test_ns_z::test_me { variable foo }
list [namespace exists ::] \
[namespace exists ::bogus_namespace] \
--- 1099,1112 ----
} {1 {unknown namespace "::test_ns_1::test_ns_foo" in namespace children command}}
test namespace-38.1 {UpdateStringOfNsName} {
! 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 {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval ::test_ns_z::test_me { variable foo }
list [namespace exists ::] \
[namespace exists ::bogus_namespace] \
***************
*** 1309,1318 ****
namespace ensemble create -subcommands {b c}
}
}
! test namespace-43.3 {ensembles: list-driven} {
! eval $SETUP
namespace delete ns
! } {}
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}
--- 1309,1317 ----
namespace ensemble create -subcommands {b c}
}
}
! 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,1344 ****
namespace ensemble create -subcommands {b c} -map {c ::ns::d}
}
}
! test namespace-43.8 {ensembles: list-and-map-driven} {
! eval $SETUP
namespace delete ns
! } {}
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}
--- 1334,1342 ----
namespace ensemble create -subcommands {b c} -map {c ::ns::d}
}
}
! 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,1368 ****
namespace ensemble create -prefixes off
}
}
! test namespace-43.13 {ensembles: turn off prefixes} {
! eval $SETUP
namespace delete ns
! } {}
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}
--- 1357,1365 ----
namespace ensemble create -prefixes off
}
}
! 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,1641 ****
catch {unset l}
catch {unset msg}
catch {unset trigger}
! eval namespace delete [namespace children :: test_ns_*]
::tcltest::cleanupTests
return
--- 1633,1638 ----
catch {unset l}
catch {unset msg}
catch {unset trigger}
! namespace delete {expand}[namespace children :: test_ns_*]
::tcltest::cleanupTests
return
Index: tests/parse.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/parse.test,v
retrieving revision 1.16
diff -c -r1.16 parse.test
*** tests/parse.test 24 Jul 2003 16:05:24 -0000 1.16
--- tests/parse.test 7 Nov 2003 13:27:01 -0000
***************
*** 10,148 ****
#
# RCS: @(#) $Id: parse.test,v 1.16 2003/07/24 16:05:24 dgp Exp $
! if {[lsearch [namespace children] ::tcltest] == -1} {
! package require tcltest
! namespace import -force ::tcltest::*
}
! 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
! }
! test parse-1.1 {Tcl_ParseCommand procedure, computing string length} {
testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
! test parse-1.2 {Tcl_ParseCommand procedure, computing string length} {
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} {
testparser " \n\t foo" 0
} {- foo 1 simple foo 1 text foo 0 {}}
! test parse-1.4 {Tcl_ParseCommand procedure, leading space} {
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} {
testparser " \\\n foo" 0
} {- foo 1 simple foo 1 text foo 0 {}}
! test parse-1.6 {Tcl_ParseCommand procedure, backslash-newline in leading space} {
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} {
testparser " \\\n" 0
} {- {} 0 {}}
! test parse-1.8 {Tcl_ParseCommand procedure, eof in leading space} {
testparser " foo" 3
} {- {} 0 { foo}}
! test parse-2.1 {Tcl_ParseCommand procedure, comments} {
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} {
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} {
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} {
testparser "# \\\n" 0
} {\#\ \ \ \\\n {} 0 {}}
! test parse-2.5 {Tcl_ParseCommand procedure, eof in comment} {
testparser " # foo bar\nfoo" 8
} {{# foo b} {} 0 {ar
foo}}
! test parse-3.1 {Tcl_ParseCommand procedure, parsing words, skipping space} {
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} {
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} {
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} {
testparser "foo " 5
} {- {foo } 1 simple foo 1 text foo 0 { }}
! test parse-3.5 {Tcl_ParseCommand procedure, quoted words} {
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} {
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} {
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} {
testparser {foo} 0
} {- foo 1 simple foo 1 text foo 0 {}}
! test parse-4.2 {Tcl_ParseCommand procedure, simple words} {
testparser {{abc}} 0
} {- {{abc}} 1 simple {{abc}} 1 text abc 0 {}}
! test parse-4.3 {Tcl_ParseCommand procedure, simple words} {
testparser {"c d"} 0
} {- {"c d"} 1 simple {"c d"} 1 text {c d} 0 {}}
! test parse-4.4 {Tcl_ParseCommand procedure, simple words} {
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} {
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} {
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} {
testparser "{abc}\\\n" 0
} {- \{abc\}\\\n 1 simple {{abc}} 1 text abc 0 {}}
! test parse-5.2 {Tcl_ParseCommand procedure, backslash-newline terminates word} {
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} {
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} {
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} {
testparser "\"foo\" bar" 5
} {- {"foo"} 1 simple {"foo"} 1 text foo 0 { bar}}
! test parse-5.6 {Tcl_ParseCommand procedure, junk after close quote} {
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} {
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} {
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} {
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} {
# 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 \"
--- 10,155 ----
#
# RCS: @(#) $Id: parse.test,v 1.16 2003/07/24 16:05:24 dgp Exp $
! if {[catch {package require tcltest 2.0.2}]} {
! puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
! 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} 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} 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} testparser {
testparser " \n\t foo" 0
} {- foo 1 simple foo 1 text foo 0 {}}
! 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} 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} 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} testparser {
testparser " \\\n" 0
} {- {} 0 {}}
! 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} 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} 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} 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} testparser {
testparser "# \\\n" 0
} {\#\ \ \ \\\n {} 0 {}}
! 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} 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} 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} 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} testparser {
testparser "foo " 5
} {- {foo } 1 simple foo 1 text foo 0 { }}
! 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} 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} 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} testparser {
testparser {foo} 0
} {- foo 1 simple foo 1 text foo 0 {}}
! 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} 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} 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} 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} 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} 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} 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} 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} 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} 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} 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} 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} 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} 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} 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,174 ****
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} {
testparser {""} 0
} {- {""} 1 simple {""} 1 text {} 0 {}}
! test parse-6.2 {ParseTokens procedure, simple range} {
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} {
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} {
list [catch {testparser {$x([a )} 0} msg] $msg
} {1 {missing close-bracket}}
! test parse-6.5 {ParseTokens procedure, command substitution} {
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} {
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} {
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")
--- 157,240 ----
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-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} 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} 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} testparser {
list [catch {testparser {$x([a )} 0} msg] $msg
} {1 {missing close-bracket}}
! 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} 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} 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,269 ****
expr 1+1
#this is a comment ]}
} {0}
! test parse-6.11 {ParseTokens procedure, memory allocation for big nested command} {
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} {
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} {
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} {
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} {
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} {
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} {
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 for Bug 681841
list [catch {testparser {[a]} 2} msg] $msg
} {1 {missing close-bracket}}
! test parse-7.1 {Tcl_FreeParse and ExpandTokenArray procedures} {
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} {
testevalobjv 0 concat this is a test
} {this is a test}
! test parse-8.2 {Tcl_EvalObjv procedure, unknown commands} {
! rename unknown unknown.old
set x [catch {testevalobjv 10 asdf poiu} msg]
! 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 {
return "unknown $args"
}
set x [catch {testevalobjv 0 asdf poiu} msg]
! 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 {
error "I don't like that command"
}
set x [catch {testevalobjv 0 asdf poiu} msg]
! 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} {
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} {
proc x {} {
set y 23
set z [testevalobjv 1 set y]
return [list $z $y]
}
! catch {unset y}
! set y 16
x
! } {16 23}
! test parse-8.8 {Tcl_EvalObjv procedure, async handlers} {
proc async1 {result code} {
! global aresult acode
set aresult $result
set acode $code
return "new result"
--- 251,344 ----
expr 1+1
#this is a comment ]}
} {0}
! 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} 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} 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} 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} 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} 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} 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} 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} 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} testevalobjv {
testevalobjv 0 concat this is a test
} {this is a test}
! 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
list $x $msg
} {1 {invalid command name "asdf"}}
! 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
list $x $msg
} {0 {unknown asdf poiu}}
! 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
list $x $msg
} {1 {I don't like that command}}
! 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} -constraints {
! testevalobjv
! } -setup {
proc x {} {
set y 23
set z [testevalobjv 1 set y]
return [list $z $y]
}
! set ::y 16
! } -cleanup {
! unset ::y
! } -body {
x
! } -result {16 23}
! test parse-8.8 {Tcl_EvalObjv procedure, async handlers} -constraints {
! testevalobjv testasync
! } -setup {
! variable ::aresult
! variable ::acode
proc async1 {result code} {
! variable ::aresult
! variable ::acode
set aresult $result
set acode $code
return "new result"
***************
*** 271,285 ****
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]
testasync delete
! set x
! } {0 {new result} 0 original}
! test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} {
list [catch {testevalobjv 0 error message} msg] $msg
} {1 message}
! test parse-9.1 {Tcl_LogCommandInfo, line numbers} {
catch {unset x}
list [catch {testevalex {for {} 1 {} {
--- 346,361 ----
set handler1 [testasync create async1]
set aresult xxx
set acode yyy
! } -cleanup {
testasync delete
! } -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} testevalex {
catch {unset x}
list [catch {testevalex {for {} 1 {} {
***************
*** 305,568 ****
# asdf
set x
}}"}}
! test parse-9.2 {Tcl_LogCommandInfo, truncating long commands} {
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} {
testevalex {concat test}
} {test}
! test parse-10.2 {Tcl_EvalTokens, backslash sequences} {
testevalex {concat test\063\062test}
} {test32test}
! test parse-10.3 {Tcl_EvalTokens, nested commands} {
testevalex {concat [expr 2 + 6]}
} {8}
! test parse-10.4 {Tcl_EvalTokens, nested commands} {
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} {
set a hello
testevalex {concat $a}
} {hello}
! test parse-10.6 {Tcl_EvalTokens, array variables} {
catch {unset a}
set a(12) 46
testevalex {concat $a(12)}
} {46}
! test parse-10.7 {Tcl_EvalTokens, array variables} {
catch {unset a}
set a(12) 46
testevalex {concat $a(1[expr 3 - 1])}
} {46}
! test parse-10.8 {Tcl_EvalTokens, array variables} {
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} {
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} {
set a 123
testevalex {concat $a}
} {123}
! test parse-10.11 {Tcl_EvalTokens, object values} {
set a 123
testevalex {concat $a$a$a}
} {123123123}
! test parse-10.12 {Tcl_EvalTokens, object values} {
testevalex {concat [expr 2][expr 4][expr 6]}
} {246}
! test parse-10.13 {Tcl_EvalTokens, string values} {
testevalex {concat {a" b"}}
} {a" b"}
! test parse-10.14 {Tcl_EvalTokens, string values} {
set a 111
testevalex {concat x$a.$a.$a}
} {x111.111.111}
! test parse-11.1 {Tcl_EvalEx, TCL_EVAL_GLOBAL flag} {
proc x {} {
set y 777
set z [testevalex "set y" global]
return [list $z $y]
}
! catch {unset y}
! set y 321
x
! } {321 777}
! test parse-11.2 {Tcl_EvalEx, error while parsing} {
list [catch {testevalex {concat "abc}} msg] $msg
} {1 {missing "}}
! test parse-11.3 {Tcl_EvalEx, error while collecting words} {
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} {
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} {
list [catch {testevalex {break}} msg] $msg
} {3 {}}
! test parse-11.6 {Tcl_EvalEx, freeing memory} {
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} {
list [testevalex {set a b; set c d}] $a $c
} {d b d}
! test parse-11.8 {Tcl_EvalEx, multiple commands in script} {
list [testevalex {
set a b
set c d
}] $a $c
} {d b d}
! test parse-11.9 {Tcl_EvalEx, freeing memory after error} {
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} {
testevalex {concat xyz; }
} {xyz}
! test parse-11.11 {Tcl_EvalTokens, empty commands} {
testevalex "concat abc; ; # this is a comment\n"
} {abc}
! test parse-11.12 {Tcl_EvalTokens, empty commands} {
testevalex {}
} {}
! test parse-12.1 {Tcl_ParseVarName procedure, initialization} {
list [catch {testparsevarname {$a([first second])} 8 0} msg] $msg
} {1 {missing close-bracket}}
! test parse-12.2 {Tcl_ParseVarName procedure, initialization} {
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} {
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} {
testparsevarname {$abcd} 0 0
} {- {} 0 variable {$abcd} 1 text abcd 0 {}}
! test parse-12.5 {Tcl_ParseVarName procedure, just a dollar sign} {
testparsevarname {$abcd} 1 0
} {- {} 0 text {$} 0 abcd}
! test parse-12.6 {Tcl_ParseVarName procedure, braced variable name} {
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} {
testparser "\$\{\{\} " 0
} {- \$\{\{\}\ 1 word \$\{\{\} 2 variable \$\{\{\} 1 text \{ 0 {}}
! test parse-12.8 {Tcl_ParseVarName procedure, missing close brace} {
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} {
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} {
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} {
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} {
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 ::} {
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} {
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. ::} {
testparsevarname {$ab:cd} 0 0
} {- {} 0 variable {$ab} 1 text ab 0 :cd}
! test parse-12.16 {Tcl_ParseVarName procedure, eof in ::} {
testparsevarname {$ab::cd} 4 0
} {- {} 0 variable {$ab} 1 text ab 0 ::cd}
! test parse-12.17 {Tcl_ParseVarName procedure, eof in ::} {
testparsevarname {$ab:::cd} 5 0
} {- {} 0 variable {$ab::} 1 text ab:: 0 :cd}
! test parse-12.18 {Tcl_ParseVarName procedure, no variable name} {
testparser {$$ $.} 0
} {- {$$ $.} 2 word {$$} 2 text {$} 0 text {$} 0 word {$.} 2 text {$} 0 text . 0 {}}
! test parse-12.19 {Tcl_ParseVarName procedure, EOF before (} {
testparsevarname {$ab(cd)} 3 0
} {- {} 0 variable {$ab} 1 text ab 0 (cd)}
! test parse-12.20 {Tcl_ParseVarName procedure, array reference} {
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} {
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} {
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} {
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} {
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} {
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} {
set abc 24
testparsevar {$abc.fg}
} {24 .fg}
! test parse-13.2 {Tcl_ParseVar procedure, no variable name} {
testparsevar {$}
} {{$} {}}
! test parse-13.3 {Tcl_ParseVar procedure, no variable name} {
testparsevar {$.123}
} {{$} .123}
! test parse-13.4 {Tcl_ParseVar procedure, error looking up variable} {
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} {
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} {
testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
! test parse-14.2 {Tcl_ParseBraces procedure, computing string length} {
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} {
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} {
testparser {foo {{}}} 0
} {- {foo {{}}} 2 simple foo 1 text foo 0 simple {{{}}} 1 text {{}} 0 {}}
! test parse-14.5 {Tcl_ParseBraces procedure, nested braces} {
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} {
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} {
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} {
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} {
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} {
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} {
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} {
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} {
testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
! test parse-15.2 {Tcl_ParseQuotedString procedure, computing string length} {
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} {
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} {
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")
--- 381,648 ----
# asdf
set x
}}"}}
! 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} testevalex {
testevalex {concat test}
} {test}
! test parse-10.2 {Tcl_EvalTokens, backslash sequences} testevalex {
testevalex {concat test\063\062test}
} {test32test}
! test parse-10.3 {Tcl_EvalTokens, nested commands} testevalex {
testevalex {concat [expr 2 + 6]}
} {8}
! 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} testevalex {
set a hello
testevalex {concat $a}
} {hello}
! 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} testevalex {
catch {unset a}
set a(12) 46
testevalex {concat $a(1[expr 3 - 1])}
} {46}
! 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} 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} testevalex {
set a 123
testevalex {concat $a}
} {123}
! 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} testevalex {
testevalex {concat [expr 2][expr 4][expr 6]}
} {246}
! test parse-10.13 {Tcl_EvalTokens, string values} testevalex {
testevalex {concat {a" b"}}
} {a" b"}
! 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} -constraints {
! testevalex
! } -setup {
proc x {} {
set y 777
set z [testevalex "set y" global]
return [list $z $y]
}
! set ::y 321
! } -cleanup {
! unset ::y
! } -body {
x
! } -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} 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} 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} testevalex {
list [catch {testevalex {break}} msg] $msg
} {3 {}}
! 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} testevalex {
list [testevalex {set a b; set c d}] $a $c
} {d b d}
! 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} 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} testevalex {
testevalex {concat xyz; }
} {xyz}
! 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} testevalex {
testevalex {}
} {}
! 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} 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} 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} testparsevarname {
testparsevarname {$abcd} 0 0
} {- {} 0 variable {$abcd} 1 text abcd 0 {}}
! 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} 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} testparser {
testparser "\$\{\{\} " 0
} {- \$\{\{\}\ 1 word \$\{\{\} 2 variable \$\{\{\} 1 text \{ 0 {}}
! 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} 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} 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} 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} 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 ::} 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} 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. ::} testparsevarname {
testparsevarname {$ab:cd} 0 0
} {- {} 0 variable {$ab} 1 text ab 0 :cd}
! 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 ::} testparsevarname {
testparsevarname {$ab:::cd} 5 0
} {- {} 0 variable {$ab::} 1 text ab:: 0 :cd}
! 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 (} testparsevarname {
testparsevarname {$ab(cd)} 3 0
} {- {} 0 variable {$ab} 1 text ab 0 (cd)}
! 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} 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} 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} 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} 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} 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} testparsevar {
set abc 24
testparsevar {$abc.fg}
} {24 .fg}
! test parse-13.2 {Tcl_ParseVar procedure, no variable name} testparsevar {
testparsevar {$}
} {{$} {}}
! 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} 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} 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} 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} 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} 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} 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} 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} 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} 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} 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} 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} 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} 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} 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} 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} 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} 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} 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,723 ****
info complete "abc\\\n"
} 0
test parse-15.51 {CommandComplete procedure} "
! info complete \"\\{abc\\}\\{\"
" 1
test parse-15.52 {CommandComplete procedure} {
info complete "\"abc\"("
} 1
test parse-15.53 {CommandComplete procedure} "
! info complete \" # {\"
" 1
test parse-15.54 {CommandComplete procedure} "
! info complete \"foo bar;# {\"
" 1
test parse-15.55 {CommandComplete procedure} {
info complete "set x [bytestring \0]; puts hi"
--- 788,803 ----
info complete "abc\\\n"
} 0
test parse-15.51 {CommandComplete procedure} "
! info complete \"\\\{abc\\\}\\\{\"
" 1
test parse-15.52 {CommandComplete procedure} {
info complete "\"abc\"("
} 1
test parse-15.53 {CommandComplete procedure} "
! info complete \" # \{\"
" 1
test parse-15.54 {CommandComplete procedure} "
! info complete \"foo bar;# \{\"
" 1
test parse-15.55 {CommandComplete procedure} {
info complete "set x [bytestring \0]; puts hi"
***************
*** 853,859 ****
set a
} 1
! # cleanup
! catch {unset a}
! ::tcltest::cleanupTests
return
--- 933,940 ----
set a
} 1
! cleanupTests
! }
!
! namespace delete ::tcl::test::parse
return
Index: tests/pkg.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/pkg.test,v
retrieving revision 1.10
diff -c -r1.10 pkg.test
*** tests/pkg.test 27 Jun 2003 17:22:41 -0000 1.10
--- tests/pkg.test 7 Nov 2003 13:27:01 -0000
***************
*** 25,31 ****
interp eval $i [list namespace import -force ::tcltest::*]
interp eval $i {
! eval package forget [package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
--- 25,31 ----
interp eval $i [list namespace import -force ::tcltest::*]
interp eval $i {
! package forget {expand}[package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
Index: tests/pkgMkIndex.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/pkgMkIndex.test,v
retrieving revision 1.24
diff -c -r1.24 pkgMkIndex.test
*** tests/pkgMkIndex.test 24 Jul 2003 08:45:09 -0000 1.24
--- tests/pkgMkIndex.test 7 Nov 2003 13:27:01 -0000
***************
*** 89,95 ****
set ver [lindex $args 2]
set ::PKGS($pkg:$ver) [lindex $args 3]
} else {
! return [eval package_original $args]
}
}
array set ::PKGS {}
--- 89,95 ----
set ver [lindex $args 2]
set ::PKGS($pkg:$ver) [lindex $args 3]
} else {
! return [package_original {expand}$args]
}
}
array set ::PKGS {}
***************
*** 148,154 ****
# 1: the error result if element 0 was 1
proc pkgtest::createIndex { args } {
! set parsed [eval parseArgs $args]
set options [lindex $parsed 0]
set dirPath [lindex $parsed 1]
set patternList [lindex $parsed 2]
--- 148,154 ----
# 1: the error result if element 0 was 1
proc pkgtest::createIndex { args } {
! set parsed [parseArgs {expand}$args]
set options [lindex $parsed 0]
set dirPath [lindex $parsed 1]
set patternList [lindex $parsed 2]
***************
*** 157,163 ****
if {[catch {
file delete [file join $dirPath pkgIndex.tcl]
! eval pkg_mkIndex $options [list $dirPath] $patternList
} err]} {
return [list 1 $err]
}
--- 157,163 ----
if {[catch {
file delete [file join $dirPath pkgIndex.tcl]
! pkg_mkIndex {expand}$options $dirPath {expand}$patternList
} err]} {
return [list 1 $err]
}
***************
*** 231,237 ****
proc pkgtest::runCreatedIndex {rv args} {
if {[lindex $rv 0] == 0} {
! set parsed [eval parseArgs $args]
set dirPath [lindex $parsed 1]
set idxFile [file join $dirPath pkgIndex.tcl]
--- 231,237 ----
proc pkgtest::runCreatedIndex {rv args} {
if {[lindex $rv 0] == 0} {
! set parsed [parseArgs {expand}$args]
set dirPath [lindex $parsed 1]
set idxFile [file join $dirPath pkgIndex.tcl]
***************
*** 248,255 ****
return $result
}
proc pkgtest::runIndex { args } {
! set rv [eval createIndex $args]
! return [eval [list runCreatedIndex $rv] $args]
}
# If there is no match to the patterns, make sure the directory hasn't
--- 248,255 ----
return $result
}
proc pkgtest::runIndex { 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
Index: tests/proc.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/proc.test,v
retrieving revision 1.11
diff -c -r1.11 proc.test
*** tests/proc.test 11 Dec 2002 21:29:52 -0000 1.11
--- tests/proc.test 7 Nov 2003 13:27:01 -0000
***************
*** 20,32 ****
namespace import -force ::tcltest::*
}
! catch {eval namespace delete [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_*]}
namespace eval test_ns_1 {
namespace eval baz {}
}
--- 20,32 ----
namespace import -force ::tcltest::*
}
! 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 {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
namespace eval baz {}
}
***************
*** 38,48 ****
[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_*]}
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_*]}
proc :: {} {
return "empty called"
}
--- 38,48 ----
[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 {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 {namespace delete {expand}[namespace children :: test_ns_*]}
proc :: {} {
return "empty called"
}
***************
*** 52,58 ****
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_*]}
namespace eval test_ns_1 {
namespace eval baz {
proc p {} {
--- 52,58 ----
return "empty called"
}}
test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} {
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
namespace eval baz {
proc p {} {
***************
*** 64,70 ****
[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_*]}
namespace eval test_ns_1::baz {}
namespace eval test_ns_1 {
proc baz::p {} {
--- 64,70 ----
[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 {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_1::baz {}
namespace eval test_ns_1 {
proc baz::p {} {
***************
*** 76,82 ****
[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_*]}
namespace eval test_ns_1 {
proc q: {} {return "q:"}
proc value:at: {} {return "value:at:"}
--- 76,82 ----
[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 {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
proc q: {} {return "q:"}
proc value:at: {} {return "value:at:"}
***************
*** 103,115 ****
} {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 {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_*]}
namespace eval test_ns_1 {
namespace eval baz {
proc p {} {return "p in [namespace current]"}
--- 103,115 ----
} {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 {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 {namespace delete {expand}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
namespace eval baz {
proc p {} {return "p in [namespace current]"}
***************
*** 118,124 ****
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_*]}
namespace eval test_ns_1::baz {}
namespace eval test_ns_1 {
proc baz::p {} {return "p in [namespace current]"}
--- 118,124 ----
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 {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,151 ****
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 {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_*]}
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_*]}
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 {rename p ""}
proc p {} {return "p in [namespace current]"}
namespace eval test_ns_1::baz {
--- 126,151 ----
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 {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 {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 {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 {namespace delete {expand}[namespace children :: test_ns_*]}
catch {rename p ""}
proc p {} {return "p in [namespace current]"}
namespace eval test_ns_1::baz {
***************
*** 153,159 ****
}
} {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 {rename p ""}
namespace eval test_ns_1::baz {
proc p {} {return "p in [namespace current]"}
--- 153,159 ----
}
} {p in ::}
test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} {
! 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,172 ****
list [catch {p} msg] $msg
} {1 {wrong # args: should be "p x"}}
! catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename {} ""}
catch {unset msg}
--- 166,172 ----
list [catch {p} msg] $msg
} {1 {wrong # args: should be "p x"}}
! catch {namespace delete {expand}[namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename {} ""}
catch {unset msg}
Index: tests/reg.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/reg.test,v
retrieving revision 1.18
diff -c -r1.18 reg.test
*** tests/reg.test 6 Oct 2003 14:32:22 -0000 1.18
--- tests/reg.test 7 Nov 2003 13:27:01 -0000
***************
*** 231,240 ****
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]
return
}
--- 231,238 ----
if {$amp >= 0} {
set f [string range $flags 0 [expr $amp - 1]]
append f [string range $flags [expr $amp + 1] end]
! f [linsert $testid end ARE] ${f} $re $target {expand}$args
! f [linsert $testid end BRE] ${f}b $re $target {expand}$args
return
}
***************
*** 283,292 ****
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]
return
}
--- 281,292 ----
if {$amp >= 0} {
set f [string range $flags 0 [expr $amp - 1]]
append f [string range $flags [expr $amp + 1] end]
! 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,344 ****
# match expected (no missing, empty, or ambiguous submatches)
# m testno flags re target mat submat ...
proc m {args} {
! eval matchexpected [linsert $args 0 [list]]
}
# match expected (full fanciness)
# i testno flags re target mat submat ...
proc i {args} {
! eval matchexpected [linsert $args 0 [list "-indices"]]
}
# partial match expected
--- 332,344 ----
# match expected (no missing, empty, or ambiguous submatches)
# m testno flags re target mat submat ...
proc m {args} {
! matchexpected {} {expand}$args
}
# match expected (full fanciness)
# i testno flags re target mat submat ...
proc i {args} {
! matchexpected -indices {expand}$args
}
# partial match expected
***************
*** 347,353 ****
proc p {args} {
set f [lindex $args 1] ;# add ! flag
set args [lreplace $args 1 1 "!$f"]
! eval matchexpected [linsert $args 0 [list "-indices"]]
}
# test is a knownBug
--- 347,353 ----
proc p {args} {
set f [lindex $args 1] ;# add ! flag
set args [lreplace $args 1 1 "!$f"]
! matchexpected -indices {expand}$args
}
# test is a knownBug
Index: tests/trace.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/trace.test,v
retrieving revision 1.32
diff -c -r1.32 trace.test
*** tests/trace.test 29 Sep 2003 21:28:09 -0000 1.32
--- tests/trace.test 7 Nov 2003 13:27:02 -0000
***************
*** 1346,1352 ****
} {}
proc traceDelete {cmd old new op} {
! eval trace remove command $cmd [lindex [trace info command $cmd] 0]
global info
set info [list $old $new $op]
}
--- 1346,1352 ----
} {}
proc traceDelete {cmd old new op} {
! trace remove command $cmd {expand}[lindex [trace info command $cmd] 0]
global info
set info [list $old $new $op]
}
***************
*** 1602,1608 ****
{factorial 3} 0 6 leave}
proc traceDelete {cmd args} {
! eval trace remove execution $cmd [lindex [trace info execution $cmd] 0]
global info
set info $args
}
--- 1602,1608 ----
{factorial 3} 0 6 leave}
proc traceDelete {cmd args} {
! trace remove execution $cmd {expand}[lindex [trace info execution $cmd] 0]
global info
set info $args
}
Index: tests/upvar.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/upvar.test,v
retrieving revision 1.7
diff -c -r1.7 upvar.test
*** tests/upvar.test 10 Apr 2000 17:19:05 -0000 1.7
--- tests/upvar.test 7 Nov 2003 13:27:02 -0000
***************
*** 320,326 ****
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 {rename MakeLink ""}
namespace eval ::test_ns_1 {}
proc MakeLink {a} {
--- 320,326 ----
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 {namespace delete {expand}[namespace children :: test_ns_*]}
catch {rename MakeLink ""}
namespace eval ::test_ns_1 {}
proc MakeLink {a} {
Index: tests/winConsole.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/winConsole.test,v
retrieving revision 1.5
diff -c -r1.5 winConsole.test
*** tests/winConsole.test 10 Apr 2000 17:19:06 -0000 1.5
--- tests/winConsole.test 7 Nov 2003 13:27:02 -0000
***************
*** 39,45 ****
#cleanup the fileevent
fileevent stdin readable {}
! eval fconfigure stdin $oldmode
set result
--- 39,45 ----
#cleanup the fileevent
fileevent stdin readable {}
! fconfigure stdin {expand}$oldmode
set result
Index: tests/winFCmd.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/winFCmd.test,v
retrieving revision 1.22
diff -c -r1.22 winFCmd.test
*** tests/winFCmd.test 16 Sep 2003 14:56:08 -0000 1.22
--- tests/winFCmd.test 7 Nov 2003 13:27:02 -0000
***************
*** 39,45 ****
set x [glob -directory $p tf* td*]
}
if {$x != ""} {
! catch {eval file delete -force -- $x}
}
}
}
--- 39,45 ----
set x [glob -directory $p tf* td*]
}
if {$x != ""} {
! catch {file delete -force -- {expand}$x}
}
}
}
