summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--doc/string.n5
-rw-r--r--generic/regc_nfa.c2
-rw-r--r--generic/tclAssembly.c4
-rw-r--r--generic/tclCmdIL.c12
-rw-r--r--generic/tclCompCmdsGR.c60
-rw-r--r--generic/tclCompile.c13
-rw-r--r--generic/tclCompile.h7
-rw-r--r--generic/tclDictObj.c4
-rw-r--r--generic/tclExecute.c185
-rw-r--r--generic/tclIO.c2
-rw-r--r--generic/tclIORChan.c63
-rw-r--r--generic/tclOO.c7
-rw-r--r--generic/tclPathObj.c18
-rw-r--r--generic/tclTest.c55
-rw-r--r--generic/tclVar.c3
-rw-r--r--generic/tclZlib.c9
-rw-r--r--tests/all.tcl3
-rw-r--r--tests/chanio.test16
-rw-r--r--tests/cmdAH.test10
-rw-r--r--tests/fCmd.test86
-rw-r--r--tests/io.test14
-rw-r--r--tests/ioCmd.test4
-rw-r--r--tests/ioTrans.test4
-rw-r--r--tests/oo.test13
-rw-r--r--tests/parse.test29
-rw-r--r--tests/parseExpr.test5
-rw-r--r--tests/parseOld.test13
-rw-r--r--tests/socket.test9
-rw-r--r--tests/stringObj.test19
-rw-r--r--tests/subst.test12
-rw-r--r--tests/tcltest.test36
-rw-r--r--tests/unixFCmd.test2
-rw-r--r--tests/utf.test124
-rw-r--r--tests/util.test5
-rw-r--r--tests/winFCmd.test46
-rw-r--r--unix/tclUnixNotfy.c4
-rw-r--r--unix/tclUnixPipe.c6
-rw-r--r--unix/tclUnixTest.c24
-rw-r--r--unix/tclXtTest.c19
-rw-r--r--win/tclWinFile.c5
-rw-r--r--win/tclWinTest.c47
41 files changed, 647 insertions, 357 deletions
diff --git a/doc/string.n b/doc/string.n
index 163abdd..72a69ff 100644
--- a/doc/string.n
+++ b/doc/string.n
@@ -131,8 +131,9 @@ Any Unicode printing character, including space.
.IP \fBpunct\fR 12
Any Unicode punctuation character.
.IP \fBspace\fR 12
-Any Unicode whitespace character, zero width space (U+200b),
-word joiner (U+2060) and zero width no-break space (U+feff) (=BOM).
+Any Unicode whitespace character, mongolian vowel separator
+(U+180e), zero width space (U+200b), word joiner (U+2060) or
+zero width no-break space (U+feff) (=BOM).
.IP \fBtrue\fR 12
Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
true.
diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c
index 42489dd..1f0583e 100644
--- a/generic/regc_nfa.c
+++ b/generic/regc_nfa.c
@@ -1345,7 +1345,7 @@ fixempties(
for (s = nfa->states; s != NULL && !NISERR(); s = nexts) {
nexts = s->next;
/* Ensure tmp fields are clear for next step */
- assert(s->tmp = NULL);
+ assert(s->tmp == NULL);
if (s->flag || s->nins != 1) {
continue;
}
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index d1866c8..6d5676b 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -410,6 +410,10 @@ static const TalInstDesc TalInstructionTable[] = {
{"lappendArray", ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8
| INST_LAPPEND_ARRAY4),2, 1},
{"lappendArrayStk", ASSEM_1BYTE, INST_LAPPEND_ARRAY_STK, 3, 1},
+ {"lappendList", ASSEM_LVT4, INST_LAPPEND_LIST, 1, 1},
+ {"lappendListArray",ASSEM_LVT4, INST_LAPPEND_LIST_ARRAY,2, 1},
+ {"lappendListArrayStk", ASSEM_1BYTE,INST_LAPPEND_LIST_ARRAY_STK, 3, 1},
+ {"lappendListStk", ASSEM_1BYTE, INST_LAPPEND_LIST_STK, 2, 1},
{"lappendStk", ASSEM_1BYTE, INST_LAPPEND_STK, 2, 1},
{"le", ASSEM_1BYTE, INST_LE, 2, 1},
{"lindexMulti", ASSEM_LINDEX_MULTI,
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index db216e5..d723e4b 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -1287,6 +1287,7 @@ TclInfoFrame(
"eval", "eval", "eval", "precompiled", "source", "proc"
};
Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL;
+ int needsFree = -1;
/*
* Pull the information and construct the dictionary to return, as list.
@@ -1360,6 +1361,9 @@ TclInfoFrame(
}
ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL));
+ if (fPtr->cmdObj && framePtr->cmdObj == NULL) {
+ needsFree = lc - 1;
+ }
TclStackFree(interp, fPtr);
break;
}
@@ -1447,7 +1451,11 @@ TclInfoFrame(
}
}
- return Tcl_NewListObj(lc, lv);
+ tmpObj = Tcl_NewListObj(lc, lv);
+ if (needsFree >= 0) {
+ Tcl_DecrRefCount(lv[needsFree]);
+ }
+ return tmpObj;
}
/*
@@ -2655,7 +2663,7 @@ Tcl_LrepeatObjCmd(
* number of times.
*/
- CLANG_ASSERT(dataArray);
+ CLANG_ASSERT(dataArray || totalElems == 0 );
if (objc == 1) {
register Tcl_Obj *tmpPtr = objv[0];
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index b3e273f..166fea0 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -868,28 +868,16 @@ TclCompileLappendCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
- int isScalar, localIndex, numWords, i, fwd, offsetFwd;
+ int isScalar, localIndex, numWords, i;
DefineLineInformation; /* TIP #280 */
- /*
- * If we're not in a procedure, don't compile.
- */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
/* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords == 1) {
return TCL_ERROR;
}
- if (numWords != 3) {
- /*
- * LAPPEND instructions currently only handle one value, but we can
- * handle some multi-value cases by stringing them together.
- */
+ if (numWords != 3 || envPtr->procPtr == NULL) {
goto lappendMultiple;
}
@@ -943,42 +931,28 @@ TclCompileLappendCmd(
return TCL_OK;
lappendMultiple:
- /*
- * Can only handle the case where we are appending to a local scalar when
- * there are multiple values to append. Fortunately, this is common.
- */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
+ PushVarNameWord(interp, varTokenPtr, envPtr, 0,
&localIndex, &isScalar, 1);
- if (!isScalar || localIndex < 0) {
- return TCL_ERROR;
- }
-
- /*
- * Definitely appending to a local scalar; generate the words and append
- * them.
- */
-
valueTokenPtr = TokenAfter(varTokenPtr);
for (i = 2 ; i < numWords ; i++) {
CompileWord(envPtr, valueTokenPtr, interp, i);
valueTokenPtr = TokenAfter(valueTokenPtr);
}
- TclEmitInstInt4( INST_LIST, numWords-2, envPtr);
- TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr);
- offsetFwd = CurrentOffset(envPtr);
- TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr);
- Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr);
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- fwd = CurrentOffset(envPtr) - offsetFwd;
- TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
- Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
-
+ TclEmitInstInt4( INST_LIST, numWords-2, envPtr);
+ if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_LAPPEND_LIST_STK, envPtr);
+ } else {
+ TclEmitInstInt4(INST_LAPPEND_LIST, localIndex, envPtr);
+ }
+ } else {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_LAPPEND_LIST_ARRAY_STK, envPtr);
+ } else {
+ TclEmitInstInt4(INST_LAPPEND_LIST_ARRAY, localIndex,envPtr);
+ }
+ }
return TCL_OK;
}
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 347e3f0..838b195 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -650,6 +650,19 @@ InstructionDesc const tclInstructionTable[] = {
* satisfy the class check (standard definition of "all").
* Stack: ... stringValue => ... boolean */
+ {"lappendList", 5, 0, 1, {OPERAND_LVT4}},
+ /* Lappend list to scalar variable at op4 in frame.
+ * Stack: ... list => ... listVarContents */
+ {"lappendListArray", 5, -1, 1, {OPERAND_LVT4}},
+ /* Lappend list to array element; array at op4.
+ * Stack: ... elem list => ... listVarContents */
+ {"lappendListArrayStk", 1, -2, 0, {OPERAND_NONE}},
+ /* Lappend list to array element.
+ * Stack: ... arrayName elem list => ... listVarContents */
+ {"lappendListStk", 1, -1, 0, {OPERAND_NONE}},
+ /* Lappend list to general variable.
+ * Stack: ... varName list => ... listVarContents */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 5665ca9..fa4a360 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -799,8 +799,13 @@ typedef struct ByteCode {
#define INST_TRY_CVT_TO_BOOLEAN 183
#define INST_STR_CLASS 184
+#define INST_LAPPEND_LIST 185
+#define INST_LAPPEND_LIST_ARRAY 186
+#define INST_LAPPEND_LIST_ARRAY_STK 187
+#define INST_LAPPEND_LIST_STK 188
+
/* The last opcode */
-#define LAST_INST_OPCODE 184
+#define LAST_INST_OPCODE 188
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 3c0ddd8..15fbe1e 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -405,6 +405,7 @@ DupDictInternalRep(
*/
DICT(copyPtr) = newDict;
+ copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
copyPtr->typePtr = &tclDictType;
}
@@ -720,6 +721,7 @@ SetDictFromAny(
dict->chain = NULL;
dict->refcount = 1;
DICT(objPtr) = dict;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclDictType;
return TCL_OK;
@@ -1390,6 +1392,7 @@ Tcl_NewDictObj(void)
dict->chain = NULL;
dict->refcount = 1;
DICT(dictPtr) = dict;
+ dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
dictPtr->typePtr = &tclDictType;
return dictPtr;
#endif
@@ -1439,6 +1442,7 @@ Tcl_DbNewDictObj(
dict->chain = NULL;
dict->refcount = 1;
DICT(dictPtr) = dict;
+ dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
dictPtr->typePtr = &tclDictType;
return dictPtr;
#else /* !TCL_MEM_DEBUG */
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index d8c5935..2098e50 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2204,10 +2204,6 @@ TEBCresume(
} else {
/* resume from invocation */
CACHE_STACK_INFO();
- if (iPtr->execEnvPtr->rewind) {
- result = TCL_ERROR;
- goto abnormalReturn;
- }
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
if (bcFramePtr->cmdObj) {
@@ -2219,6 +2215,10 @@ TEBCresume(
if (iPtr->flags & INTERP_DEBUG_FRAME) {
TclArgumentBCRelease(interp, bcFramePtr);
}
+ if (iPtr->execEnvPtr->rewind) {
+ result = TCL_ERROR;
+ goto abnormalReturn;
+ }
if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
iPtr->flags |= ERR_ALREADY_LOGGED;
codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;
@@ -3347,7 +3347,7 @@ TEBCresume(
*/
{
- int storeFlags;
+ int storeFlags, len;
case INST_STORE_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -3587,6 +3587,171 @@ TEBCresume(
#endif
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(pcAdjustment, cleanup, 1);
+
+ case INST_LAPPEND_LIST:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ valuePtr = OBJ_AT_TOS;
+ varPtr = LOCAL(opnd);
+ cleanup = 1;
+ pcAdjustment = 5;
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
+ if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
+ != TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ if (TclIsVarDirectReadable(varPtr)
+ && TclIsVarDirectWritable(varPtr)) {
+ goto lappendListDirect;
+ }
+ arrayPtr = NULL;
+ part1Ptr = part2Ptr = NULL;
+ goto lappendListPtr;
+
+ case INST_LAPPEND_LIST_ARRAY:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ valuePtr = OBJ_AT_TOS;
+ part1Ptr = NULL;
+ part2Ptr = OBJ_UNDER_TOS;
+ arrayPtr = LOCAL(opnd);
+ cleanup = 2;
+ pcAdjustment = 5;
+ while (TclIsVarLink(arrayPtr)) {
+ arrayPtr = arrayPtr->value.linkPtr;
+ }
+ TRACE(("%u \"%.30s\" \"%.30s\" => ",
+ opnd, O2S(part2Ptr), O2S(valuePtr)));
+ if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
+ != TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)
+ && !WriteTraced(arrayPtr)) {
+ varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
+ if (varPtr && TclIsVarDirectReadable(varPtr)
+ && TclIsVarDirectWritable(varPtr)) {
+ goto lappendListDirect;
+ }
+ }
+ varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
+ TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd);
+ if (varPtr == NULL) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ goto lappendListPtr;
+
+ case INST_LAPPEND_LIST_ARRAY_STK:
+ pcAdjustment = 1;
+ cleanup = 3;
+ valuePtr = OBJ_AT_TOS;
+ part2Ptr = OBJ_UNDER_TOS; /* element name */
+ part1Ptr = OBJ_AT_DEPTH(2); /* array name */
+ TRACE(("\"%.30s(%.30s)\" \"%.30s\" => ",
+ O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr)));
+ goto lappendList;
+
+ case INST_LAPPEND_LIST_STK:
+ pcAdjustment = 1;
+ cleanup = 2;
+ valuePtr = OBJ_AT_TOS;
+ part2Ptr = NULL;
+ part1Ptr = OBJ_UNDER_TOS; /* variable name */
+ TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(valuePtr)));
+ goto lappendList;
+
+ lappendListDirect:
+ objResultPtr = varPtr->value.objPtr;
+ if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ if (Tcl_IsShared(objResultPtr)) {
+ Tcl_Obj *newValue = Tcl_DuplicateObj(objResultPtr);
+
+ TclDecrRefCount(objResultPtr);
+ varPtr->value.objPtr = objResultPtr = newValue;
+ Tcl_IncrRefCount(newValue);
+ }
+ if (Tcl_ListObjReplace(interp, objResultPtr, len, 0, objc, objv)
+ != TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(pcAdjustment, cleanup, 1);
+
+ lappendList:
+ opnd = -1;
+ if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
+ != TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ DECACHE_STACK_INFO();
+ varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
+ TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr);
+ CACHE_STACK_INFO();
+ if (!varPtr) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+
+ lappendListPtr:
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)++;
+ }
+ if (arrayPtr && TclIsVarInHash(arrayPtr)) {
+ VarHashRefCount(arrayPtr)++;
+ }
+ DECACHE_STACK_INFO();
+ objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr,
+ part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd);
+ CACHE_STACK_INFO();
+ if (TclIsVarInHash(varPtr)) {
+ VarHashRefCount(varPtr)--;
+ }
+ if (arrayPtr && TclIsVarInHash(arrayPtr)) {
+ VarHashRefCount(arrayPtr)--;
+ }
+
+ {
+ int createdNewObj = 0;
+
+ if (!objResultPtr) {
+ objResultPtr = valuePtr;
+ } else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ } else {
+ if (Tcl_IsShared(objResultPtr)) {
+ objResultPtr = Tcl_DuplicateObj(objResultPtr);
+ createdNewObj = 1;
+ }
+ if (Tcl_ListObjReplace(interp, objResultPtr, len,0, objc,objv)
+ != TCL_OK) {
+ goto errorInLappendListPtr;
+ }
+ }
+ DECACHE_STACK_INFO();
+ objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr,
+ part2Ptr, objResultPtr, TCL_LEAVE_ERR_MSG, opnd);
+ CACHE_STACK_INFO();
+ if (!objResultPtr) {
+ errorInLappendListPtr:
+ if (createdNewObj) {
+ TclDecrRefCount(objResultPtr);
+ }
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ }
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(pcAdjustment, cleanup, 1);
}
/*
@@ -5601,6 +5766,7 @@ TEBCresume(
((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0;
}
Tcl_InvalidateStringRep(objResultPtr);
+ TclDecrRefCount(value3Ptr);
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
} else {
@@ -5627,6 +5793,7 @@ TEBCresume(
((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0;
}
Tcl_InvalidateStringRep(valuePtr);
+ TclDecrRefCount(value3Ptr);
TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -7474,6 +7641,14 @@ TEBCresume(
searchPtr = ckalloc(sizeof(Tcl_DictSearch));
if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
&valuePtr, &done) != TCL_OK) {
+
+ /*
+ * dictPtr is no longer on the stack, and we're not
+ * moving it into the intrep of an iterator. We need
+ * to drop the refcount [Tcl Bug 9b352768e6].
+ */
+
+ Tcl_DecrRefCount(dictPtr);
ckfree(searchPtr);
TRACE_ERROR(interp);
goto gotError;
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 1938173..256b411 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -5446,7 +5446,7 @@ Tcl_ReadRaw(
if (bytesToRead > 0) {
- int nread = ChanRead(chanPtr, readBuf+copied, bytesToRead);
+ int nread = ChanRead(chanPtr, readBuf, bytesToRead);
if (nread > 0) {
/* Successful read (short is OK) - add to bytes copied */
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index ff602c6..3506a44 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -436,6 +436,7 @@ static ReflectedChannelMap * GetReflectedChannelMap(Tcl_Interp *interp);
static void DeleteReflectedChannelMap(ClientData clientData,
Tcl_Interp *interp);
static int ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj *resObj);
+static void MarkDead(ReflectedChannel *rcPtr);
/*
* Global constant strings (messages). ==================
@@ -1146,7 +1147,6 @@ ReflectClose(
if (result != TCL_OK) {
FreeReceivedError(&p);
}
- return EOK;
}
#endif
@@ -1217,17 +1217,14 @@ ReflectClose(
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
+ }
#endif
-
- tctPtr = ((Channel *)rcPtr->chan)->typePtr;
- if (tctPtr && tctPtr != &tclRChannelType) {
+ tctPtr = ((Channel *)rcPtr->chan)->typePtr;
+ if (tctPtr && tctPtr != &tclRChannelType) {
ckfree((char *)tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
- }
- Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
-#ifdef TCL_THREADS
}
-#endif
+ Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
return (result == TCL_OK) ? EOK : EINVAL;
}
@@ -2192,9 +2189,15 @@ FreeReflectedChannel(
Channel *chanPtr = (Channel *) rcPtr->chan;
Tcl_Release(chanPtr);
- Tcl_DecrRefCount(rcPtr->name);
- Tcl_DecrRefCount(rcPtr->methods);
- Tcl_DecrRefCount(rcPtr->cmd);
+ if (rcPtr->name) {
+ Tcl_DecrRefCount(rcPtr->name);
+ }
+ if (rcPtr->methods) {
+ Tcl_DecrRefCount(rcPtr->methods);
+ }
+ if (rcPtr->cmd) {
+ Tcl_DecrRefCount(rcPtr->cmd);
+ }
ckfree(rcPtr);
}
@@ -2460,6 +2463,28 @@ GetReflectedChannelMap(
*/
static void
+MarkDead(
+ ReflectedChannel *rcPtr)
+{
+ if (rcPtr->dead) {
+ return;
+ }
+ if (rcPtr->name) {
+ Tcl_DecrRefCount(rcPtr->name);
+ rcPtr->name = NULL;
+ }
+ if (rcPtr->methods) {
+ Tcl_DecrRefCount(rcPtr->methods);
+ rcPtr->methods = NULL;
+ }
+ if (rcPtr->cmd) {
+ Tcl_DecrRefCount(rcPtr->cmd);
+ rcPtr->cmd = NULL;
+ }
+ rcPtr->dead = 1;
+}
+
+static void
DeleteReflectedChannelMap(
ClientData clientData, /* The per-interpreter data structure. */
Tcl_Interp *interp) /* The interpreter being deleted. */
@@ -2494,7 +2519,7 @@ DeleteReflectedChannelMap(
chan = Tcl_GetHashValue(hPtr);
rcPtr = Tcl_GetChannelInstanceData(chan);
- rcPtr->dead = 1;
+ MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&rcmPtr->map);
@@ -2577,7 +2602,7 @@ DeleteReflectedChannelMap(
continue;
}
- rcPtr->dead = 1;
+ MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
#endif
@@ -2724,7 +2749,7 @@ DeleteThreadReflectedChannelMap(
Tcl_Channel chan = Tcl_GetHashValue(hPtr);
ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan);
- rcPtr->dead = 1;
+ MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
ckfree(rcmPtr);
@@ -2907,8 +2932,6 @@ ForwardProc(
* No parameters/results.
*/
- const Tcl_ChannelType *tctPtr;
-
if (InvokeTclMethod(rcPtr, METH_FINAL, NULL, NULL, &resObj)!=TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
}
@@ -2932,13 +2955,7 @@ ForwardProc(
hPtr = Tcl_FindHashEntry(&rcmPtr->map,
Tcl_GetChannelName(rcPtr->chan));
Tcl_DeleteHashEntry(hPtr);
-
- tctPtr = ((Channel *)rcPtr->chan)->typePtr;
- if (tctPtr && tctPtr != &tclRChannelType) {
- ckfree((char *)tctPtr);
- ((Channel *)rcPtr->chan)->typePtr = NULL;
- }
- Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
+ MarkDead(rcPtr);
break;
}
diff --git a/generic/tclOO.c b/generic/tclOO.c
index de00733..02e00c9 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -1008,6 +1008,12 @@ ReleaseClassContents(
}
if (!Deleted(instancePtr)) {
Tcl_DeleteCommandFromToken(interp, instancePtr->command);
+ /*
+ * Tcl_DeleteCommandFromToken() may have done to whole
+ * job for us. Roll back and check again.
+ */
+ i--;
+ continue;
}
DelRef(instancePtr);
}
@@ -1280,6 +1286,7 @@ TclOORemoveFromInstances(
removeInstance:
if (Deleted(clsPtr->thisPtr)) {
+ DelRef(clsPtr->instances.list[i]);
clsPtr->instances.list[i] = NULL;
} else {
clsPtr->instances.num--;
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index fe6063f..99d576d 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -2437,19 +2437,13 @@ SetFsPathFromAny(
}
TclDecrRefCount(parts);
} else {
- /*
- * Simple case. "rest" is relative path. Just join it. The
- * "rest" object will be freed when Tcl_FSJoinToPath returns
- * (unless something else claims a refCount on it).
- */
-
- Tcl_Obj *joined;
- Tcl_Obj *rest = Tcl_NewStringObj(name+split+1, -1);
+ Tcl_Obj *pair[2];
- Tcl_IncrRefCount(transPtr);
- joined = Tcl_FSJoinToPath(transPtr, 1, &rest);
- TclDecrRefCount(transPtr);
- transPtr = joined;
+ pair[0] = transPtr;
+ pair[1] = Tcl_NewStringObj(name+split+1, -1);
+ transPtr = TclJoinPath(2, pair);
+ Tcl_DecrRefCount(pair[0]);
+ Tcl_DecrRefCount(pair[1]);
}
}
} else {
diff --git a/generic/tclTest.c b/generic/tclTest.c
index a27c95a..0f4b6d4 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -201,8 +201,9 @@ static int EncodingFromUtfProc(ClientData clientData,
int *dstCharsPtr);
static void ExitProcEven(ClientData clientData);
static void ExitProcOdd(ClientData clientData);
-static int GetTimesCmd(ClientData clientData,
- Tcl_Interp *interp, int argc, const char **argv);
+static int GetTimesObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static void MainLoop(void);
static int NoopCmd(ClientData clientData,
Tcl_Interp *interp, int argc, const char **argv);
@@ -219,6 +220,9 @@ static void SpecialFree(char *blockPtr);
static int StaticInitProc(Tcl_Interp *interp);
static int TestasyncCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
+static int TestbytestringObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static int TestcmdinfoCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestcmdtokenCmd(ClientData dummy,
@@ -556,9 +560,10 @@ Tcltest_Init(
* Create additional commands and math functions for testing Tcl.
*/
- Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL);
Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
@@ -4717,7 +4722,7 @@ TestgetvarfullnameCmd(
/*
*----------------------------------------------------------------------
*
- * GetTimesCmd --
+ * GetTimesObjCmd --
*
* This procedure implements the "gettimes" command. It is used for
* computing the time needed for various basic operations such as reading
@@ -4733,11 +4738,11 @@ TestgetvarfullnameCmd(
*/
static int
-GetTimesCmd(
+GetTimesObjCmd(
ClientData unused, /* Unused. */
Tcl_Interp *interp, /* The current interpreter. */
- int argc, /* The number of arguments. */
- const char **argv) /* The argument strings. */
+ int notused1, /* Number of arguments. */
+ Tcl_Obj *const notused2[]) /* The argument objects. */
{
Interp *iPtr = (Interp *) interp;
int i, n;
@@ -4951,6 +4956,42 @@ NoopObjCmd(
/*
*----------------------------------------------------------------------
*
+ * TestbytestringObjCmd --
+ *
+ * This object-based procedure constructs a string which can
+ * possibly contain invalid UTF-8 bytes.
+ *
+ * Results:
+ * Returns the TCL_OK result code.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestbytestringObjCmd(
+ ClientData unused, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ int n;
+ const char *p;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "bytearray");
+ return TCL_ERROR;
+ }
+ p = (const char *)Tcl_GetByteArrayFromObj(objv[1], &n);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestsetCmd --
*
* Implements the "testset{err,noerr}" cmds that are used when testing
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 4694cd8..5e3157e 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -1958,6 +1958,9 @@ TclPtrSetVar(
Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */
}
Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
+ if (newValuePtr->refCount == 0) {
+ Tcl_DecrRefCount(newValuePtr);
+ }
}
}
} else if (newValuePtr != oldValuePtr) {
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 2e27303..06e18fe 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -643,7 +643,6 @@ Tcl_ZlibStreamInit(
int e;
ZlibStreamHandle *zshPtr = NULL;
Tcl_DString cmdname;
- Tcl_CmdInfo cmdinfo;
GzipHeader *gzHeaderPtr = NULL;
switch (mode) {
@@ -769,8 +768,8 @@ Tcl_ZlibStreamInit(
Tcl_DStringInit(&cmdname);
TclDStringAppendLiteral(&cmdname, "::tcl::zlib::streamcmd_");
TclDStringAppendObj(&cmdname, Tcl_GetObjResult(interp));
- if (Tcl_GetCommandInfo(interp, Tcl_DStringValue(&cmdname),
- &cmdinfo) == 1) {
+ if (Tcl_FindCommand(interp, Tcl_DStringValue(&cmdname),
+ NULL, 0) != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"BUG: Stream command name already exists", -1));
Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL);
@@ -2911,6 +2910,10 @@ ZlibTransformClose(
* Release all memory.
*/
+ if (cd->compDictObj) {
+ Tcl_DecrRefCount(cd->compDictObj);
+ cd->compDictObj = NULL;
+ }
Tcl_DStringFree(&cd->decompressed);
if (cd->inBuffer) {
diff --git a/tests/all.tcl b/tests/all.tcl
index 05d3024..0a6f57f 100644
--- a/tests/all.tcl
+++ b/tests/all.tcl
@@ -15,5 +15,8 @@ package require Tcl 8.5
package require tcltest 2.2
namespace import tcltest::*
configure {*}$argv -testdir [file dir [info script]]
+if {[singleProcess]} {
+ interp debug {} -frame 1
+}
runAllTests
proc exit args {}
diff --git a/tests/chanio.test b/tests/chanio.test
index e53f059..2738fc6 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -13,10 +13,16 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[catch {package require tcltest 2}]} {
- chan puts stderr "Skipping tests in [info script]. tcltest 2 required."
- return
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2
+ namespace import -force ::tcltest::*
}
+
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
+testConstraint testbytestring [llength [info commands testbytestring]]
+
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
@@ -7426,11 +7432,11 @@ test chan-io-59.1 {Thread reference of channels} {testmainthread testchannel} {
string equal $result [testmainthread]
} {1}
-test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent} {
+test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
chan puts $out {
- chan puts [encoding convertfrom identity \xe2]
+ chan puts [testbytestring \xe2]
exit 1
}
proc readit {pipe} {
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 04a86fa..64cfeba 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -829,13 +829,13 @@ test cmdAH-16.1 {Tcl_FileObjCmd: readable} {
}
test cmdAH-16.2 {Tcl_FileObjCmd: readable} {
-constraints testchmod
- -setup {testchmod 0444 $gorpfile}
+ -setup {testchmod 0o444 $gorpfile}
-body {file readable $gorpfile}
-result 1
}
test cmdAH-16.3 {Tcl_FileObjCmd: readable} {
-constraints {unix notRoot testchmod}
- -setup {testchmod 0333 $gorpfile}
+ -setup {testchmod 0o333 $gorpfile}
-body {file readable $gorpfile}
-result 0
}
@@ -848,13 +848,13 @@ test cmdAH-17.1 {Tcl_FileObjCmd: writable} {
}
test cmdAH-17.2 {Tcl_FileObjCmd: writable} {
-constraints {notRoot testchmod}
- -setup {testchmod 0555 $gorpfile}
+ -setup {testchmod 0o555 $gorpfile}
-body {file writable $gorpfile}
-result 0
}
test cmdAH-17.3 {Tcl_FileObjCmd: writable} {
-constraints testchmod
- -setup {testchmod 0222 $gorpfile}
+ -setup {testchmod 0o222 $gorpfile}
-body {file writable $gorpfile}
-result 1
}
@@ -873,7 +873,7 @@ test cmdAH-18.2 {Tcl_FileObjCmd: executable} {notRoot} {
test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} {
# Only on unix will setting the execute bit on a regular file cause that
# file to be executable.
- testchmod 0775 $gorpfile
+ testchmod 0o775 $gorpfile
file exe $gorpfile
} 1
test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body {
diff --git a/tests/fCmd.test b/tests/fCmd.test
index 5836e00..c8264b2 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -128,7 +128,7 @@ proc checkcontent {file matchString} {
}
proc openup {path} {
- testchmod 777 $path
+ testchmod 0o777 $path
if {[file isdirectory $path]} {
catch {
foreach p [glob -directory $path *] {
@@ -362,10 +362,10 @@ test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} -setup {
cleanup
} -constraints {unix notRoot testchmod} -returnCodes error -body {
file mkdir td1/td2/td3
- testchmod 000 td1/td2
+ testchmod 0 td1/td2
file mkdir td1/td2/td3/td4
} -cleanup {
- testchmod 755 td1/td2
+ testchmod 0o755 td1/td2
cleanup
} -result {can't create directory "td1/td2/td3": permission denied}
test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} -setup {
@@ -505,11 +505,11 @@ test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} -setup {
cleanup
} -constraints {unix notRoot testchmod} -body {
file mkdir td1
- testchmod 000 td1
+ testchmod 0 td1
createfile tf1
file rename tf1 td1
} -returnCodes error -cleanup {
- testchmod 755 td1
+ testchmod 0o755 td1
} -result {error renaming "tf1" to "td1/tf1": permission denied}
test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} -setup {
cleanup
@@ -785,7 +785,7 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} -setup {
} -constraints {notRoot testchmod} -body {
createfile tf1
createfile tf2
- testchmod 444 tf2
+ testchmod 0o444 tf2
file rename tf1 tf3
file rename tf2 tf4
list [lsort [glob tf*]] [file writable tf3] [file writable tf4]
@@ -794,7 +794,7 @@ test fCmd-9.4.a {file rename: comprehensive: dir to new name} -setup {
cleanup
} -constraints {win win2000orXP testchmod} -body {
file mkdir td1 td2
- testchmod 555 td2
+ testchmod 0o555 td2
file rename td1 td3
file rename td2 td4
list [lsort [glob td*]] [file writable td3] [file writable td4]
@@ -805,7 +805,7 @@ test fCmd-9.4.b {file rename: comprehensive: dir to new name} -setup {
cleanup
} -constraints {unix notRoot testchmod notDarwin9} -body {
file mkdir td1 td2
- testchmod 555 td2
+ testchmod 0o555 td2
file rename td1 td3
file rename td2 td4
list [lsort [glob td*]] [file writable td3] [file writable td4]
@@ -817,7 +817,7 @@ test fCmd-9.5 {file rename: comprehensive: file to self} -setup {
} -constraints {notRoot testchmod} -body {
createfile tf1 tf1
createfile tf2 tf2
- testchmod 444 tf2
+ testchmod 0o444 tf2
file rename -force tf1 tf1
file rename -force tf2 tf2
list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2]
@@ -827,7 +827,7 @@ test fCmd-9.6.a {file rename: comprehensive: dir to self} -setup {
} -constraints {win win2000orXP testchmod} -body {
file mkdir td1
file mkdir td2
- testchmod 555 td2
+ testchmod 0o555 td2
file rename -force td1 .
file rename -force td2 .
list [lsort [glob td*]] [file writable td1] [file writable td2]
@@ -837,7 +837,7 @@ test fCmd-9.6.b {file rename: comprehensive: dir to self} -setup {
} -constraints {unix notRoot testchmod} -body {
file mkdir td1
file mkdir td2
- testchmod 555 td2
+ testchmod 0o555 td2
file rename -force td1 .
file rename -force td2 .
list [lsort [glob td*]] [file writable td1] [file writable td2]
@@ -855,10 +855,10 @@ test fCmd-9.7 {file rename: comprehensive: file to existing file} -setup {
createfile tfd2
createfile tfd3
createfile tfd4
- testchmod 444 tfs3
- testchmod 444 tfs4
- testchmod 444 tfd2
- testchmod 444 tfd4
+ testchmod 0o444 tfs3
+ testchmod 0o444 tfs4
+ testchmod 0o444 tfd2
+ testchmod 0o444 tfd4
set msg [list [catch {file rename tf1 tf2} msg] $msg]
file rename -force tfs1 tfd1
file rename -force tfs2 tfd2
@@ -882,11 +882,11 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup {
file mkdir [file join tdd3 tds3]
file mkdir [file join tdd4 tds4]
if {![testConstraint unix]} {
- testchmod 555 tds3
- testchmod 555 tds4
+ testchmod 0o555 tds3
+ testchmod 0o555 tds4
}
- testchmod 555 [file join tdd2 tds2]
- testchmod 555 [file join tdd4 tds4]
+ testchmod 0o555 [file join tdd2 tds2]
+ testchmod 0o555 [file join tdd4 tds4]
set msg [list [catch {file rename td1 td2} msg] $msg]
file rename -force tds1 tdd1
file rename -force tds2 tdd2
@@ -911,7 +911,7 @@ test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} -setup {
file mkdir [file join tdd1 tds1 xxx]
file mkdir [file join tdd2 tds2 xxx]
if {!([testConstraint unix] || [testConstraint winVista])} {
- testchmod 555 tds2
+ testchmod 0o555 tds2
}
set a1 [list [catch {file rename -force tds1 tdd1} msg] $msg]
set a2 [list [catch {file rename -force tds2 tdd2} msg] $msg]
@@ -929,7 +929,7 @@ test fCmd-9.10 {file rename: comprehensive: file to new name and dir} -setup {
createfile tf1
createfile tf2
file mkdir td1
- testchmod 444 tf2
+ testchmod 0o444 tf2
file rename tf1 [file join td1 tf3]
file rename tf2 [file join td1 tf4]
list [catch {glob tf*}] [lsort [glob -directory td1 t*]] \
@@ -942,7 +942,7 @@ test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} -setup {
file mkdir td2
file mkdir td3
if {!([testConstraint unix] || [testConstraint winVista])} {
- testchmod 555 td2
+ testchmod 0o555 td2
}
file rename td1 [file join td3 td3]
file rename td2 [file join td3 td4]
@@ -958,13 +958,13 @@ test fCmd-9.12 {file rename: comprehensive: target exists} -setup {
cleanup
} -constraints {notRoot testchmod notNetworkFilesystem} -body {
file mkdir [file join td1 td2] [file join td2 td1]
- testchmod 555 [file join td2 td1]
+ testchmod 0o555 [file join td2 td1]
file mkdir [file join td3 td4] [file join td4 td3]
file rename -force td3 td4
list [file exists td3] [file exists [file join td4 td3 td4]] \
[catch {file rename td1 td2} msg] $msg
} -cleanup {
- testchmod 755 [file join td2 td1]
+ testchmod 0o755 [file join td2 td1]
} -result [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}]
# Test can hit EEXIST or EBUSY, depending on underlying filesystem
test fCmd-9.13 {file rename: comprehensive: can't overwrite target} -setup {
@@ -1035,7 +1035,7 @@ test fCmd-10.2 {file copy: comprehensive: file to new name} -setup {
} -constraints {notRoot testchmod} -body {
createfile tf1 tf1
createfile tf2 tf2
- testchmod 444 tf2
+ testchmod 0o444 tf2
file copy tf1 tf3
file copy tf2 tf4
list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4]
@@ -1045,14 +1045,14 @@ test fCmd-10.3 {file copy: comprehensive: dir to new name} -setup {
} -constraints {unix notRoot testchmod} -body {
file mkdir [file join td1 tdx]
file mkdir [file join td2 tdy]
- testchmod 555 td2
+ testchmod 0o555 td2
file copy td1 td3
file copy td2 td4
list [lsort [glob td*]] [glob -directory td3 t*] \
[glob -directory td4 t*] [file writable td3] [file writable td4]
} -cleanup {
- testchmod 755 td2
- testchmod 755 td4
+ testchmod 0o755 td2
+ testchmod 0o755 td4
} -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0]
test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup {
cleanup
@@ -1060,14 +1060,14 @@ test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup {
# On Windows with ACLs, copying a directory is defined like this
file mkdir [file join td1 tdx]
file mkdir [file join td2 tdy]
- testchmod 555 td2
+ testchmod 0o555 td2
file copy td1 td3
file copy td2 td4
list [lsort [glob td*]] [glob -directory td3 t*] \
[glob -directory td4 t*] [file writable td3] [file writable td4]
} -cleanup {
- testchmod 755 td2
- testchmod 755 td4
+ testchmod 0o755 td2
+ testchmod 0o755 td4
} -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 1]
test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup {
cleanup
@@ -1082,10 +1082,10 @@ test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup {
createfile tfd2
createfile tfd3
createfile tfd4
- testchmod 444 tfs3
- testchmod 444 tfs4
- testchmod 444 tfd2
- testchmod 444 tfd4
+ testchmod 0o444 tfs3
+ testchmod 0o444 tfs4
+ testchmod 0o444 tfd2
+ testchmod 0o444 tfd4
set msg [list [catch {file copy tf1 tf2} msg] $msg]
file copy -force tfs1 tfd1
file copy -force tfs2 tfd2
@@ -1106,10 +1106,10 @@ test fCmd-10.5 {file copy: comprehensive: dir to empty dir} -setup {
file mkdir [file join tdd2 tds2]
file mkdir [file join tdd3 tds3]
file mkdir [file join tdd4 tds4]
- testchmod 555 tds3
- testchmod 555 tds4
- testchmod 555 [file join tdd2 tds2]
- testchmod 555 [file join tdd4 tds4]
+ testchmod 0o555 tds3
+ testchmod 0o555 tds4
+ testchmod 0o555 [file join tdd2 tds2]
+ testchmod 0o555 [file join tdd4 tds4]
set a1 [list [catch {file copy td1 td2} msg] $msg]
set a2 [list [catch {file copy -force tds1 tdd1} msg] $msg]
set a3 [catch {file copy -force tds2 tdd2}]
@@ -1124,7 +1124,7 @@ test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup {
file mkdir tds2
file mkdir [file join tdd1 tds1 xxx]
file mkdir [file join tdd2 tds2 xxx]
- testchmod 555 tds2
+ testchmod 0o555 tds2
set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg]
set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg]
list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2]
@@ -1135,7 +1135,7 @@ test fCmd-10.7 {file rename: comprehensive: file to new name and dir} -setup {
createfile tf1
createfile tf2
file mkdir td1
- testchmod 444 tf2
+ testchmod 0o444 tf2
file copy tf1 [file join td1 tf3]
file copy tf2 [file join td1 tf4]
list [lsort [glob tf*]] [lsort [glob -directory td1 t*]] \
@@ -1147,7 +1147,7 @@ test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} -setup {
file mkdir td1
file mkdir td2
file mkdir td3
- testchmod 555 td2
+ testchmod 0o555 td2
file copy td1 [file join td3 td3]
file copy td2 [file join td3 td4]
list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \
@@ -1160,7 +1160,7 @@ test fCmd-10.8.1 {file rename: comprehensive: dir to new name and dir} -setup {
file mkdir td1
file mkdir td2
file mkdir td3
- testchmod 555 td2
+ testchmod 0o555 td2
file copy td1 [file join td3 td3]
file copy td2 [file join td3 td4]
list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \
diff --git a/tests/io.test b/tests/io.test
index c3aaa86..bf5adb0 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -13,14 +13,16 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[catch {package require tcltest 2}]} {
- puts stderr "Skipping tests in [info script]. tcltest 2 required."
- return
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2
+ namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
+testConstraint testbytestring [llength [info commands testbytestring]]
+
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
@@ -4076,7 +4078,7 @@ test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} {
} {{hello
} {hello
}}
-test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} {
+test io-32.11.2 {Tcl_Read from a pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {chan configure stdout -translation crlf}
@@ -7860,12 +7862,12 @@ test io-59.1 {Thread reference of channels} {testmainthread testchannel} {
string equal $result [testmainthread]
} {1}
-test io-60.1 {writing illegal utf sequences} {openpipe fileevent} {
+test io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
puts $out {
- puts [encoding convertfrom identity \xe2]
+ puts [testbytestring \xe2]
exit 1
}
proc readit {pipe} {
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 8d35ec7..dcca1f5 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -2814,7 +2814,9 @@ test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \
update
}
LOG THREAD-LOOP-DONE
- thread::exit
+ #thread::exit
+ # Thread exits cause leaks; Use clean thread shutdown
+ set forever yourGirl
}
LOG MAIN_WAITING
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index c40621b..53078f7 100644
--- a/tests/ioTrans.test
+++ b/tests/ioTrans.test
@@ -1037,6 +1037,8 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces
} -constraints {testchannel} -match glob -body {
# Set up channel in thread
set chan [interp eval $ida $helperscript]
+ interp eval $ida [list ::variable tempchan [tempchan]]
+ interp transfer {} $::tempchan $ida
set chan [interp eval $ida {
proc foo {args} {
handle.initialize clear drain flush limit? read write
@@ -1045,7 +1047,7 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces
# Destroy interpreter during channel access.
suicide
}
- set chan [chan push [tempchan] foo]
+ set chan [chan push $tempchan foo]
fconfigure $chan -buffering none
set chan
}]
diff --git a/tests/oo.test b/tests/oo.test
index d63e931..fcd9818 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -258,6 +258,19 @@ test oo-1.18 {OO: create object in NS with same name as global cmd} -setup {
rename test-oo-1.18 {}
A destroy
} -result ::C
+test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup {
+ proc test-oo-1.18 {} return
+} -constraints memory -body {
+ leaktest {
+ oo::class create A
+ oo::class create B {superclass A}
+ oo::define B constructor {} {A create test-oo-1.18}
+ B create C
+ A destroy
+ }
+} -cleanup {
+ rename test-oo-1.18 {}
+} -result 0
test oo-1.19 {basic test of OO functionality: teardown order} -body {
oo::object create o
namespace delete [info object namespace o]
diff --git a/tests/parse.test b/tests/parse.test
index 01443c9..fe6026d 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -20,6 +20,7 @@ namespace eval ::tcl::test::parse {
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testparser [llength [info commands testparser]]
+testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testparsevarname [llength [info commands testparsevarname]]
@@ -29,8 +30,8 @@ testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevent [llength [info commands testevent]]
testConstraint memory [llength [info commands memory]]
-test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser {
- testparser [bytestring "foo\0 bar"] -1
+test parse-1.1 {Tcl_ParseCommand procedure, computing string length} {testparser testbytestring} {
+ testparser [testbytestring "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
@@ -301,9 +302,9 @@ test parse-6.15 {ParseTokens procedure, backslash-newline} testparser {
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.17 {ParseTokens procedure, null characters} {testparser testbytestring} {
+ testparser [testbytestring "foo\0zz"] 0
+} "- [testbytestring foo\0zz] 1 word [testbytestring foo\0zz] 3 text foo 0 text [testbytestring \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
@@ -700,8 +701,8 @@ test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup {
rename getbytes {}
} -result 0
-test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser {
- testparser [bytestring "foo\0 bar"] -1
+test parse-14.1 {Tcl_ParseBraces procedure, computing string length} {testparser testbytestring} {
+ testparser [testbytestring "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
@@ -737,8 +738,8 @@ 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
+test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} {testparser testbytestring} {
+ testparser [testbytestring "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
@@ -903,11 +904,11 @@ test parse-15.53 {CommandComplete procedure} "
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"
+test parse-15.55 {CommandComplete procedure} testbytestring {
+ info complete "set x [testbytestring \0]; puts hi"
} 1
-test parse-15.56 {CommandComplete procedure} {
- info complete "set x [bytestring \0]; \{"
+test parse-15.56 {CommandComplete procedure} testbytestring {
+ info complete "set x [testbytestring \0]; \{"
} 0
test parse-15.57 {CommandComplete procedure} {
info complete "# Comment should be complete command"
@@ -917,7 +918,7 @@ test parse-15.58 {CommandComplete procedure, memory leaks} {
} 1
test parse-15.59 {CommandComplete procedure} {
# Test for Tcl Bug 684744
- info complete [encoding convertfrom identity "\x00;if 1 \{"]
+ info complete [testbytestring "\x00;if 1 \{"]
} 0
test parse-15.60 {CommandComplete procedure} {
# Test for Tcl Bug 1968882
diff --git a/tests/parseExpr.test b/tests/parseExpr.test
index 714c45b..5c7986a 100644
--- a/tests/parseExpr.test
+++ b/tests/parseExpr.test
@@ -20,6 +20,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
# of "<<" are integers.
testConstraint testexprparser [llength [info commands testexprparser]]
+testConstraint testbytestring [llength [info commands testbytestring]]
# Big test for correct ordering of data in [expr]
@@ -81,8 +82,8 @@ testConstraint ieeeFloatingPoint [testIEEE]
######################################################################
-test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} testexprparser {
- testexprparser [bytestring "1+2\0 +3"] -1
+test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} {testexprparser testbytestring} {
+ testexprparser [testbytestring "1+2\0 +3"] -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} testexprparser {
testexprparser "1 + 2" -1
diff --git a/tests/parseOld.test b/tests/parseOld.test
index f3b1591..4c08b5d 100644
--- a/tests/parseOld.test
+++ b/tests/parseOld.test
@@ -20,6 +20,7 @@ namespace import ::tcltest::*
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testwordend [llength [info commands testwordend]]
+testConstraint testbytestring [llength [info commands testbytestring]]
# Save the argv value for restoration later
set savedArgv $argv
@@ -261,15 +262,15 @@ test parseOld-7.10 {backslash substitution} {
test parseOld-7.11 {backslash substitution} {
eval "list a \"b c\"\\\nd e"
} {a {b c} d e}
-test parseOld-7.12 {backslash substitution} {
+test parseOld-7.12 {backslash substitution} testbytestring {
list \ua2
-} [bytestring "\xc2\xa2"]
-test parseOld-7.13 {backslash substitution} {
+} [testbytestring "\xc2\xa2"]
+test parseOld-7.13 {backslash substitution} testbytestring {
list \u4e21
-} [bytestring "\xe4\xb8\xa1"]
-test parseOld-7.14 {backslash substitution} {
+} [testbytestring "\xe4\xb8\xa1"]
+test parseOld-7.14 {backslash substitution} testbytestring {
list \u4e2k
-} [bytestring "\xd3\xa2k"]
+} [testbytestring "\xd3\xa2k"]
# Semi-colon.
diff --git a/tests/socket.test b/tests/socket.test
index 2bd2731..c50730c 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -2036,6 +2036,7 @@ test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4}
} -cleanup {
close $fd
close $sock
+ removeFile script
} -result {{} ok {}}
test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} \
-constraints {socket supported_inet6 localhost_v6} \
@@ -2056,6 +2057,7 @@ test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6}
} -cleanup {
close $fd
close $sock
+ removeFile script
} -result {{} ok {}}
test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} \
-constraints {socket} \
@@ -2090,6 +2092,7 @@ test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IP
} -cleanup {
close $fd
close $sock
+ removeFile script
} -result {ok}
test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} \
-constraints {socket supported_inet6 localhost_v6} \
@@ -2115,6 +2118,7 @@ test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IP
} -cleanup {
close $fd
close $sock
+ removeFile script
} -result {ok}
test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} \
-constraints {socket} \
@@ -2151,6 +2155,7 @@ test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4}
} -cleanup {
close $fd
close $sock
+ removeFile script
} -result {{} ok}
test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} \
-constraints {socket supported_inet6 localhost_v6} \
@@ -2174,6 +2179,7 @@ test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6}
} -cleanup {
close $fd
close $sock
+ removeFile script
} -result {{} ok}
test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} \
-constraints {socket supported_inet localhost_v4} \
@@ -2200,6 +2206,7 @@ test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is I
} -cleanup {
close $fd
close $sock
+ removeFile script
} -result {{} ok}
test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} \
-constraints {socket supported_inet6 localhost_v6} \
@@ -2226,6 +2233,7 @@ test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is I
} -cleanup {
close $fd
close $sock
+ removeFile script
} -result {{} ok}
test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \
-constraints {socket} \
@@ -2309,6 +2317,7 @@ test socket-14.15 {blocking read on async socket should not trigger event handle
set x ok
fileevent $s writable {set x fail}
catch {read $s}
+ close $s
set x
} -result ok
diff --git a/tests/stringObj.test b/tests/stringObj.test
index 6f331d3..8209142 100644
--- a/tests/stringObj.test
+++ b/tests/stringObj.test
@@ -21,6 +21,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testobj [llength [info commands testobj]]
+testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testdstring [llength [info commands testdstring]]
test stringObj-1.1 {string type registration} testobj {
@@ -338,7 +339,7 @@ test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstr
# Because this test does not use \uXXXX notation below instead of
# hardcoding the values, it may fail in multibyte locales. However, we
# need to test that the parser produces untyped objects even when there
- # are high-ASCII characters in the input (like "ï"). I don't know what
+ # are high-ASCII characters in the input (like "ï"). I don't know what
# else to do but inline those characters here.
testdstring free
testdstring append "abc\u00ef\u00efdef" -1
@@ -347,7 +348,7 @@ test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstr
[testobj objtype $x] [testobj objtype $y]
} [list none "bc\u00EF\u00EFde" string string]
test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj {
- # set x "abcïïdef"
+ # set x "abcïïdef"
# Use \uXXXX notation below instead of hardcoding the values, otherwise
# the test will fail in multibyte locales.
set x "abc\u00EF\u00EFdef"
@@ -356,7 +357,7 @@ test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj {
[testobj objtype $x] [testobj objtype $y]
} [list string "bc\u00EF\u00EFde" string string]
test stringObj-10.4 {Tcl_GetRange with some mixed width chars} testobj {
- # set a "ïa¿b®cï¿d®"
+ # set a "ïa¿b®cï¿d®"
# Use \uXXXX notation below instead of hardcoding the values, otherwise
# the test will fail in multibyte locales.
set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE"
@@ -416,24 +417,24 @@ test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} testobj {
string length "\u00ae"
} 1
test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} testobj {
- # string length "○○"
+ # string length "○○"
# Use \uXXXX notation below instead of hardcoding the values, otherwise
# the test will fail in multibyte locales.
string length "\u00EF\u00BF\u00AE\u00EF\u00BF\u00AE"
} 6
test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} testobj {
- # set a "ïa¿b®cï¿d®"
+ # set a "ïa¿b®cï¿d®"
# Use \uXXXX notation below instead of hardcoding the values, otherwise
# the test will fail in multibyte locales.
set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE"
list [string length $a] [string length $a]
} {10 10}
-test stringObj-13.7 {Tcl_GetCharLength with identity nulls} testobj {
+test stringObj-13.7 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} {
# SF bug #684699
- string length [encoding convertfrom identity \x00]
+ string length [testbytestring \x00]
} 1
-test stringObj-13.8 {Tcl_GetCharLength with identity nulls} testobj {
- string length [encoding convertfrom identity \x01\x00\x02]
+test stringObj-13.8 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} {
+ string length [testbytestring \x01\x00\x02]
} 3
test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} testobj {
diff --git a/tests/subst.test b/tests/subst.test
index 498512d..256b7f7 100644
--- a/tests/subst.test
+++ b/tests/subst.test
@@ -15,6 +15,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
+testConstraint testbytestring [llength [info commands testbytestring]]
test subst-1.1 {basics} -returnCodes error -body {
subst
@@ -32,16 +36,16 @@ test subst-2.2 {simple strings} {
test subst-2.3 {simple strings} {
subst abcdefg
} abcdefg
-test subst-2.4 {simple strings} {
+test subst-2.4 {simple strings} testbytestring {
# Tcl Bug 685106
- subst [bytestring bar\x00soom]
-} [bytestring bar\x00soom]
+ subst [testbytestring bar\x00soom]
+} [testbytestring bar\x00soom]
test subst-3.1 {backslash substitutions} {
subst {\x\$x\[foo bar]\\}
} "x\$x\[foo bar]\\"
test subst-3.2 {backslash substitutions with utf chars} {
- # 'j' is just a char that doesn't mean anything, and \344 is 'ä'
+ # 'j' is just a char that doesn't mean anything, and \344 is 'ä'
# that also doesn't mean anything, but is multi-byte in UTF-8.
list [subst \j] [subst \\j] [subst \\344] [subst \\\344]
} "j j \344 \344"
diff --git a/tests/tcltest.test b/tests/tcltest.test
index ce8d617..e66678b 100644
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -142,7 +142,7 @@ test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} {
} {0 1 1 1 1}
test tcltest-2.6 {tcltest -verbose 't'} {
- -constraints {unixOrPc}
+ -constraints {unixOrPc}
-body {
set result [slave msg test.tcl -verbose 't']
list $result $msg
@@ -152,7 +152,7 @@ test tcltest-2.6 {tcltest -verbose 't'} {
}
test tcltest-2.6a {tcltest -verbose 'start'} {
- -constraints {unixOrPc}
+ -constraints {unixOrPc}
-body {
set result [slave msg test.tcl -verbose start]
list $result $msg
@@ -169,7 +169,7 @@ test tcltest-2.7 {tcltest::verbose} {
verbose foo
set newVerbosity [verbose]
verbose $oldVerbosity
- list $currentVerbosity $newVerbosity
+ list $currentVerbosity $newVerbosity
}
-result {body {}}
}
@@ -217,7 +217,7 @@ test tcltest-3.5 {tcltest::match} {
}
-result {foo bar}
}
-
+
# -skip, [skip]
test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} {
set result [slave msg test.tcl -skip a* -verbose 'ps']
@@ -299,8 +299,8 @@ test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} {
# -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}}
# -cleanup {
# set ::tcltest::constraintsSpecified $constraintlist
-# unset ::tcltest::testConstraints(tcltestFakeConstraint1)
-# unset ::tcltest::testConstraints(tcltestFakeConstraint2)
+# unset ::tcltest::testConstraints(tcltestFakeConstraint1)
+# unset ::tcltest::testConstraints(tcltestFakeConstraint2)
# }
#}
@@ -348,7 +348,7 @@ set printerror [makeFile {
::tcltest::PrintError "a really really long string containing a \
\"Path/that/is/really/long/and/contains/no/spaces\""
::tcltest::PrintError "a really really long string containing a \
- \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\""
+ \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\""
::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\""
exit
} printerror.tcl]
@@ -367,7 +367,7 @@ test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} {
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" a.tmp}]
list [regexp "a test" $msg] [regexp "a really" $msg] \
- $result1 $result2 [file exists a.tmp] [file delete a.tmp]
+ $result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {0 1 0 1 1 {}}
test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} {
slave msg $printerror -errfile a.tmp
@@ -413,7 +413,7 @@ test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} {
set f2 [errorFile $ef]
set f3 [errorChannel]
set f4 [errorFile]
- subst {$f0;$f1;$f2;$f3;$f4}
+ subst {$f0;$f1;$f2;$f3;$f4}
}
-result {stderr;stderr;.*efile;file[0-9a-f]+;.*efile}
-match regexp
@@ -449,7 +449,7 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} {
set f2 [outputFile $ef]
set f3 [outputChannel]
set f4 [outputFile]
- subst {$f0;$f1;$f2;$f3;$f4}
+ subst {$f0;$f1;$f2;$f3;$f4}
}
-result {stdout;stdout;.*efile;file[0-9a-f]+;.*efile}
-match regexp
@@ -550,7 +550,7 @@ switch -- $::tcl_platform(platform) {
}
default {
catch {file attributes $notWriteableDir -readonly 1}
- catch {testchmod 000 $notWriteableDir}
+ catch {testchmod 0 $notWriteableDir}
}
}
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
@@ -717,7 +717,7 @@ switch -- $::tcl_platform(platform) {
file attributes $notWriteableDir -permissions 777
}
default {
- catch {testchmod 777 $notWriteableDir}
+ catch {testchmod 0o777 $notWriteableDir}
catch {file attributes $notWriteableDir -readonly 0}
}
}
@@ -758,7 +758,7 @@ test tcltest-9.3 {matchFiles} {
set new [matchFiles]
matchFiles $old
list $current $new
- }
+ }
-result {foo bar}
}
@@ -771,7 +771,7 @@ test tcltest-9.4 {skipFiles} {
set new [skipFiles]
skipFiles $old
list $current $new
- }
+ }
-result {foo bar}
}
@@ -1146,7 +1146,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup {
interp delete slave2
interp delete slave1
if {$oldoptions eq "none"} {
- unset ::env(TCLTEST_OPTIONS)
+ unset ::env(TCLTEST_OPTIONS)
} else {
set ::env(TCLTEST_OPTIONS) $oldoptions
}
@@ -1260,7 +1260,7 @@ test tcltest-21.6 {test command - setup occurs before cleanup & before script} {
}
set foo 1
set expected 2
- }
+ }
-body {
incr foo
set foo
@@ -1424,7 +1424,7 @@ test tcltest-23.1 {makeFile} {
}
-cleanup {
file delete -force $mfdir \
- [file join [temporaryDirectory] t1.tmp]
+ [file join [temporaryDirectory] t1.tmp]
}
-result {1 1}
}
@@ -1447,7 +1447,7 @@ test tcltest-23.2 {removeFile} {
}
-cleanup {
file delete -force $mfdir \
- [file join [temporaryDirectory] t1.tmp]
+ [file join [temporaryDirectory] t1.tmp]
}
-result {0 0}
}
diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test
index e4613ed..2d227fe 100644
--- a/tests/unixFCmd.test
+++ b/tests/unixFCmd.test
@@ -59,7 +59,7 @@ if {[testConstraint unix]} {
}
proc openup {path} {
- testchmod 777 $path
+ testchmod 0o777 $path
if {[file isdirectory $path]} {
catch {
foreach p [glob -directory $path *] {
diff --git a/tests/utf.test b/tests/utf.test
index ebab967..2fcac49 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -16,50 +16,52 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
+testConstraint testbytestring [llength [info commands testbytestring]]
+
catch {unset x}
-test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
+test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring {
set x \x01
-} [bytestring "\x01"]
-test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
+} [testbytestring "\x01"]
+test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring {
set x "\x00"
-} [bytestring "\xc0\x80"]
-test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} {
+} [testbytestring "\xc0\x80"]
+test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring {
set x "\xe0"
-} [bytestring "\xc3\xa0"]
-test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} {
+} [testbytestring "\xc3\xa0"]
+test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring {
set x "\u4e4e"
-} [bytestring "\xe4\xb9\x8e"]
-test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} {
+} [testbytestring "\xe4\xb9\x8e"]
+test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring {
format %c 0x110000
-} [bytestring "\xef\xbf\xbd"]
-test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} {
+} [testbytestring "\xef\xbf\xbd"]
+test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring {
format %c -1
-} [bytestring "\xef\xbf\xbd"]
+} [testbytestring "\xef\xbf\xbd"]
test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
string length "abc"
} {3}
-test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} {
- string length [bytestring "\x82\x83\x84"]
+test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} testbytestring {
+ string length [testbytestring "\x82\x83\x84"]
} {3}
-test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} {
- string length [bytestring "\xC2"]
+test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} testbytestring {
+ string length [testbytestring "\xC2"]
} {1}
-test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} {
- string length [bytestring "\xC2\xa2"]
+test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} testbytestring {
+ string length [testbytestring "\xC2\xa2"]
} {1}
-test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} {
- string length [bytestring "\xE2"]
+test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} testbytestring {
+ string length [testbytestring "\xE2"]
} {1}
-test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} {
- string length [bytestring "\xE2\xA2"]
+test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestring {
+ string length [testbytestring "\xE2\xA2"]
} {2}
-test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} {
- string length [bytestring "\xE4\xb9\x8e"]
+test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring {
+ string length [testbytestring "\xE4\xb9\x8e"]
} {1}
-test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} {
- string length [bytestring "\xF4\xA2\xA2\xA2"]
+test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring {
+ string length [testbytestring "\xF4\xA2\xA2\xA2"]
} {4}
test utf-3.1 {Tcl_UtfCharComplete} {
@@ -69,26 +71,26 @@ testConstraint testnumutfchars [llength [info commands testnumutfchars]]
test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars {
testnumutfchars ""
} {0}
-test utf-4.2 {Tcl_NumUtfChars: length 1} testnumutfchars {
- testnumutfchars [bytestring "\xC2\xA2"]
+test utf-4.2 {Tcl_NumUtfChars: length 1} {testnumutfchars testbytestring} {
+ testnumutfchars [testbytestring "\xC2\xA2"]
} {1}
-test utf-4.3 {Tcl_NumUtfChars: long string} testnumutfchars {
- testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"]
+test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} {
+ testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"]
} {7}
-test utf-4.4 {Tcl_NumUtfChars: #u0000} testnumutfchars {
- testnumutfchars [bytestring "\xC0\x80"]
+test utf-4.4 {Tcl_NumUtfChars: #u0000} {testnumutfchars testbytestring} {
+ testnumutfchars [testbytestring "\xC0\x80"]
} {1}
test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars {
testnumutfchars "" 1
} {0}
-test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} testnumutfchars {
- testnumutfchars [bytestring "\xC2\xA2"] 1
+test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestring} {
+ testnumutfchars [testbytestring "\xC2\xA2"] 1
} {1}
-test utf-4.7 {Tcl_NumUtfChars: long string, calc len} testnumutfchars {
- testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1
+test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} {
+ testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1
} {7}
-test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} testnumutfchars {
- testnumutfchars [bytestring "\xC0\x80"] 1
+test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} {testnumutfchars testbytestring} {
+ testnumutfchars [testbytestring "\xC0\x80"] 1
} {1}
test utf-5.1 {Tcl_UtfFindFirsts} {
@@ -125,18 +127,18 @@ test utf-10.1 {Tcl_UtfBackslash: dst == NULL} {
set x \n
} {
}
-test utf-10.2 {Tcl_UtfBackslash: \u subst} {
+test utf-10.2 {Tcl_UtfBackslash: \u subst} testbytestring {
set x \ua2
-} [bytestring "\xc2\xa2"]
-test utf-10.3 {Tcl_UtfBackslash: longer \u subst} {
+} [testbytestring "\xc2\xa2"]
+test utf-10.3 {Tcl_UtfBackslash: longer \u subst} testbytestring {
set x \u4e21
-} [bytestring "\xe4\xb8\xa1"]
-test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} {
+} [testbytestring "\xe4\xb8\xa1"]
+test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring {
set x \u4e2k
-} "[bytestring \xd3\xa2]k"
-test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} {
+} "[testbytestring \xd3\xa2]k"
+test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring {
set x \u4e216
-} "[bytestring \xe4\xb8\xa1]6"
+} "[testbytestring \xe4\xb8\xa1]6"
proc bsCheck {char num} {
global errNum
test utf-10.$errNum {backslash substitution} {
@@ -293,15 +295,15 @@ test utf-20.1 {TclUniCharNcmp} {
} {}
test utf-21.1 {TclUniCharIsAlnum} {
- # this returns 1 with Unicode 6 compliance
+ # this returns 1 with Unicode 7 compliance
string is alnum \u1040\u021f\u0220
} {1}
test utf-21.2 {unicode alnum char in regc_locale.c} {
- # this returns 1 with Unicode 6 compliance
+ # this returns 1 with Unicode 7 compliance
list [regexp {^[[:alnum:]]+$} \u1040\u021f\u0220] [regexp {^\w+$} \u1040\u021f\u0220]
} {1 1}
test utf-21.3 {unicode print char in regc_locale.c} {
- # this returns 1 with Unicode 6 compliance
+ # this returns 1 with Unicode 7 compliance
regexp {^[[:print:]]+$} \ufbc1
} 1
test utf-21.4 {TclUniCharIsGraph} {
@@ -334,11 +336,11 @@ test utf-21.10 {unicode print char in regc_locale.c} {
} {0}
test utf-21.11 {TclUniCharIsControl} {
# [Bug 3464428]
- string is control \u00ad
+ string is control \u0000\u001f\u00ad\u0605\u061c\u180e\u2066\ufeff
} {1}
test utf-21.12 {unicode control char in regc_locale.c} {
# [Bug 3464428], [Bug a876646efe]
- regexp {^[[:cntrl:]]*$} \u0000\u001f\u00ad
+ regexp {^[[:cntrl:]]*$} \u0000\u001f\u00ad\u0605\u061c\u180e\u2066\ufeff
} {1}
test utf-22.1 {TclUniCharIsWordChar} {
@@ -349,30 +351,30 @@ test utf-22.2 {TclUniCharIsWordChar} {
} 10
test utf-23.1 {TclUniCharIsAlpha} {
- # this returns 1 with Unicode 6 compliance
- string is alpha \u021f\u0220
+ # this returns 1 with Unicode 7 compliance
+ string is alpha \u021f\u0220\u037f\u052f
} {1}
test utf-23.2 {unicode alpha char in regc_locale.c} {
- # this returns 1 with Unicode 6 compliance
- regexp {^[[:alpha:]]+$} \u021f\u0220
+ # this returns 1 with Unicode 7 compliance
+ regexp {^[[:alpha:]]+$} \u021f\u0220\u037f\u052f
} {1}
test utf-24.1 {TclUniCharIsDigit} {
- # this returns 1 with Unicode 6 compliance
+ # this returns 1 with Unicode 7 compliance
string is digit \u1040\uabf0
} {1}
test utf-24.2 {unicode digit char in regc_locale.c} {
- # this returns 1 with Unicode 6 compliance
+ # this returns 1 with Unicode 7 compliance
list [regexp {^[[:digit:]]+$} \u1040\uabf0] [regexp {^\d+$} \u1040\uabf0]
} {1 1}
test utf-24.3 {TclUniCharIsSpace} {
- # this returns 1 with Unicode 6 compliance
- string is space \u1680\u180e
+ # this returns 1 with Unicode 7/TIP 413 compliance
+ string is space \u0085\u1680\u180e\u200b\u202f\u2060
} {1}
test utf-24.4 {unicode space char in regc_locale.c} {
- # this returns 1 with Unicode 6 compliance
- list [regexp {^[[:space:]]+$} \u1680\u180e] [regexp {^\s+$} \u1680\u180e]
+ # this returns 1 with Unicode 7/TIP 413 compliance
+ list [regexp {^[[:space:]]+$} \u0085\u1680\u180e\u200b\u202f\u2060] [regexp {^\s+$} \u0085\u1680\u180e\u200b\u202f\u2060]
} {1 1}
testConstraint teststringobj [llength [info commands teststringobj]]
diff --git a/tests/util.test b/tests/util.test
index 0e50483..7782f35 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -16,6 +16,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint controversialNaN 1
+testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
testConstraint testdoubledigits [llength [info commands testdoubledigits]]
@@ -274,10 +275,10 @@ test util-5.17 {Tcl_StringMatch: UTF-8} {
# get 1 UTF-8 character
Wrapper_Tcl_StringMatch "a\[a\u4e4fc]c" "a\u4e4fc"
} 1
-test util-5.18 {Tcl_StringMatch: UTF-8} {
+test util-5.18 {Tcl_StringMatch: UTF-8} testbytestring {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# proper advance: wrong answer would match on UTF trail byte of \u4e4f
- Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [bytestring a\u008fc]
+ Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [testbytestring a\u008fc]
} 0
test util-5.19 {Tcl_StringMatch: UTF-8} {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index 28257c6..ab675d7 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.test
@@ -335,12 +335,12 @@ test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} -setup {
test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} \
-constraints {win exdev testfile testchmod} -body {
file mkdir d:/td1
- testchmod 000 d:/td1
+ testchmod 0 d:/td1
file mkdir c:/tf1
catch {testfile mv c:/tf1 d:/td1} msg
list $msg [file writable d:/td1]
} -cleanup {
- catch {testchmod 666 d:/td1}
+ catch {testchmod 0o666 d:/td1}
file delete d:/td1
file delete -force c:/tf1
} -result {EXDEV 0}
@@ -489,11 +489,11 @@ test winFCmd-2.12 {TclpCopyFile: CopyFile succeeds} -setup {
cleanup
} -constraints {win testfile} -body {
createfile tf1 tf1
- testchmod 000 tf1
+ testchmod 0 tf1
testfile cp tf1 tf2
list [contents tf2] [file writable tf2]
} -cleanup {
- catch {testchmod 666 tf1}
+ catch {testchmod 0o666 tf1}
cleanup
} -result {tf1 0}
test winFCmd-2.13 {TclpCopyFile: CopyFile fails} -setup {
@@ -535,11 +535,11 @@ test winFCmd-2.17 {TclpCopyFile: dst is readonly} -setup {
} -constraints {win testfile testchmod} -body {
createfile tf1 tf1
createfile tf2 tf2
- testchmod 000 tf2
+ testchmod 0 tf2
testfile cp tf1 tf2
list [file writable tf2] [contents tf2]
} -cleanup {
- catch {testchmod 666 tf2}
+ catch {testchmod 0o666 tf2}
cleanup
} -result {1 tf1}
@@ -605,7 +605,7 @@ test winFCmd-3.10 {TclpDeleteFile: path is readonly} -setup {
cleanup
} -constraints {win testfile testchmod} -body {
createfile tf1
- testchmod 000 tf1
+ testchmod 0 tf1
testfile rm tf1
file exists tf1
} -result {0}
@@ -613,11 +613,11 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} -setup {
cleanup
} -constraints {win testfile testchmod} -body {
set fd [open tf1 w]
- testchmod 000 tf1
+ testchmod 0 tf1
testfile rm tf1
} -cleanup {
close $fd
- catch {testchmod 666 tf1}
+ catch {testchmod 0o666 tf1}
cleanup
} -returnCodes error -result EACCES
@@ -658,11 +658,11 @@ test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} -setup {
cleanup
} -constraints {winVista testfile testchmod} -body {
file mkdir td1
- testchmod 000 td1
+ testchmod 0 td1
testfile rmdir td1
file exists td1
} -returnCodes error -cleanup {
- catch {testchmod 666 td1}
+ catch {testchmod 0o666 td1}
cleanup
} -result {td1 EACCES}
# This next test has a very hokey way of matching...
@@ -712,11 +712,11 @@ test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup {
cleanup
} -constraints {winVista testfile testchmod} -body {
file mkdir td1
- testchmod 000 td1
+ testchmod 0 td1
testfile rmdir td1
file exists td1
} -returnCodes error -cleanup {
- catch {testchmod 666 td1}
+ catch {testchmod 0o666 td1}
cleanup
} -result {td1 EACCES}
test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup {
@@ -730,11 +730,11 @@ test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup {
cleanup
} -constraints {winVista testfile testchmod} -body {
file mkdir td1
- testchmod 000 td1
+ testchmod 0 td1
testfile rmdir td1
file exists td1
} -cleanup {
- catch {testchmod 666 td1}
+ catch {testchmod 0o666 td1}
cleanup
} -returnCodes error -result {td1 EACCES}
# This next test has a very hokey way of matching...
@@ -830,11 +830,11 @@ test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} -setup {
} -constraints {win testfile testchmod} -body {
file mkdir td1
createfile td1/tf1 tf1
- testchmod 000 td1
+ testchmod 0 td1
testfile cpdir td1 td2
list [file exists td2] [file writable td2]
} -cleanup {
- catch {testchmod 666 td1}
+ catch {testchmod 0o666 td1}
cleanup
} -result {1 1}
test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} -setup {
@@ -901,11 +901,11 @@ test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} -setup {
} -constraints {win testfile testchmod} -body {
file mkdir td1
createfile td1/tf1 tf1
- testchmod 000 td1
+ testchmod 0 td1
testfile cpdir td1 td2
list [file exists td2] [file writable td2]
} -cleanup {
- catch {testchmod 666 td1}
+ catch {testchmod 0o666 td1}
cleanup
} -result {1 1}
test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} -setup {
@@ -932,11 +932,11 @@ test winFCmd-8.2 {TraversalCopy: DOTREE_PRED} -setup {
cleanup
} -constraints {win testfile testchmod} -body {
file mkdir td1/td2
- testchmod 000 td1
+ testchmod 0 td1
testfile cpdir td1 td2
list [file writable td1] [file writable td1/td2]
} -cleanup {
- catch {testchmod 666 td1}
+ catch {testchmod 0o666 td1}
cleanup
} -result {0 1}
test winFCmd-8.3 {TraversalCopy: DOTREE_POSTD} -setup {
@@ -959,11 +959,11 @@ test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup {
cleanup
} -constraints {winVista testfile testchmod} -body {
file mkdir td1/td2
- testchmod 000 td1
+ testchmod 0 td1
testfile rmdir -force td1
file exists td1
} -cleanup {
- catch {testchmod 666 td1}
+ catch {testchmod 0o666 td1}
cleanup
} -returnCodes error -result {td1 EACCES}
test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} -setup {
diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c
index b234667..b2bea45 100644
--- a/unix/tclUnixNotfy.c
+++ b/unix/tclUnixNotfy.c
@@ -311,6 +311,7 @@ Tcl_InitNotifier(void)
* pipe to the original notifier thread
*/
if (notifierCount > 0 && processIDInitialized != getpid()) {
+ Tcl_ConditionFinalize(&notifierCV);
notifierCount = 0;
processIDInitialized = 0;
close(triggerPipe);
@@ -1375,8 +1376,7 @@ AtForkParent(void)
static void
AtForkChild(void)
{
- notifierMutex = NULL;
- notifierCV = NULL;
+ Tcl_MutexFinalize(&notifierMutex);
Tcl_InitNotifier();
}
#endif /* HAVE_PTHREAD_ATFORK */
diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c
index a02044e..95bc8d1 100644
--- a/unix/tclUnixPipe.c
+++ b/unix/tclUnixPipe.c
@@ -229,7 +229,7 @@ TclpCreateTempFile(
Tcl_Obj *
TclpTempFileName(void)
{
- Tcl_Obj *nameObj = Tcl_NewObj();
+ Tcl_Obj *retVal, *nameObj = Tcl_NewObj();
int fd;
Tcl_IncrRefCount(nameObj);
@@ -242,7 +242,9 @@ TclpTempFileName(void)
fcntl(fd, F_SETFD, FD_CLOEXEC);
TclpObjDeleteFile(nameObj);
close(fd);
- return nameObj;
+ retVal = Tcl_DuplicateObj(nameObj);
+ Tcl_DecrRefCount(nameObj);
+ return retVal;
}
/*
diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c
index 4b0f369..c5ac52a 100644
--- a/unix/tclUnixTest.c
+++ b/unix/tclUnixTest.c
@@ -63,7 +63,7 @@ static const char *gotsig = "0";
*/
static Tcl_CmdProc TestalarmCmd;
-static Tcl_CmdProc TestchmodCmd;
+static Tcl_ObjCmdProc TestchmodCmd;
static Tcl_CmdProc TestfilehandlerCmd;
static Tcl_CmdProc TestfilewaitCmd;
static Tcl_CmdProc TestfindexecutableCmd;
@@ -96,7 +96,7 @@ int
TclplatformtestInit(
Tcl_Interp *interp) /* Interpreter to add commands to. */
{
- Tcl_CreateCommand(interp, "testchmod", TestchmodCmd,
+ Tcl_CreateObjCommand(interp, "testchmod", TestchmodCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd,
NULL, NULL);
@@ -740,29 +740,25 @@ static int
TestchmodCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Argument strings. */
{
int i, mode;
- char *rest;
- if (argc < 2) {
- usage:
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " mode file ?file ...?", NULL);
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "mode file ?file ...?");
return TCL_ERROR;
}
- mode = (int) strtol(argv[1], &rest, 8);
- if ((rest == argv[1]) || (*rest != '\0')) {
- goto usage;
+ if (Tcl_GetIntFromObj(interp, objv[1], &mode) != TCL_OK) {
+ return TCL_ERROR;
}
- for (i = 2; i < argc; i++) {
+ for (i = 2; i < objc; i++) {
Tcl_DString buffer;
const char *translated;
- translated = Tcl_TranslateFileName(interp, argv[i], &buffer);
+ translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer);
if (translated == NULL) {
return TCL_ERROR;
}
diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c
index fcb0773..f7c2652 100644
--- a/unix/tclXtTest.c
+++ b/unix/tclXtTest.c
@@ -15,7 +15,7 @@
#include <X11/Intrinsic.h>
#include "tcl.h"
-static Tcl_CmdProc TesteventloopCmd;
+static Tcl_ObjCmdProc TesteventloopCmd;
extern DLLEXPORT Tcl_PackageInitProc Tclxttest_Init;
/*
@@ -53,7 +53,7 @@ Tclxttest_Init(
}
XtToolkitInitialize();
InitNotifier();
- Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd,
+ Tcl_CreateObjCommand(interp, "testeventloop", TesteventloopCmd,
NULL, NULL);
return TCL_OK;
}
@@ -80,21 +80,20 @@ static int
TesteventloopCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
static int *framePtr = NULL;/* Pointer to integer on stack frame of
* innermost invocation of the "wait"
* subcommand. */
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " option ... \"", NULL);
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ...");
return TCL_ERROR;
}
- if (strcmp(argv[1], "done") == 0) {
+ if (strcmp(Tcl_GetString(objv[1]), "done") == 0) {
*framePtr = 1;
- } else if (strcmp(argv[1], "wait") == 0) {
+ } else if (strcmp(Tcl_GetString(objv[1]), "wait") == 0) {
int *oldFramePtr;
int done;
int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
@@ -118,7 +117,7 @@ TesteventloopCmd(
(void) Tcl_SetServiceMode(oldMode);
framePtr = oldFramePtr;
} else {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
+ Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be done or wait", NULL);
return TCL_ERROR;
}
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index ad4a5c4..1cdd53f 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -2900,7 +2900,7 @@ TclNativeCreateNativeRep(
WCHAR *nativePathPtr;
const char *str;
Tcl_Obj *validPathPtr;
- int len;
+ size_t len;
WCHAR *wp;
if (TclFSCwdIsNative()) {
@@ -2926,7 +2926,8 @@ TclNativeCreateNativeRep(
Tcl_IncrRefCount(validPathPtr);
}
- str = Tcl_GetStringFromObj(validPathPtr, &len);
+ str = Tcl_GetString(validPathPtr);
+ len = validPathPtr->length;
if (strlen(str)!=len) {
/* String contains NUL-bytes. This is invalid. */
diff --git a/win/tclWinTest.c b/win/tclWinTest.c
index 6027e32..b3ad626 100644
--- a/win/tclWinTest.c
+++ b/win/tclWinTest.c
@@ -32,8 +32,8 @@
* Forward declarations of functions defined later in this file:
*/
-static int TesteventloopCmd(ClientData dummy, Tcl_Interp *interp,
- int argc, const char **argv);
+static int TesteventloopCmd(ClientData dummy, Tcl_Interp* interp,
+ int objc, Tcl_Obj *const objv[]);
static int TestvolumetypeCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -43,8 +43,8 @@ static int TestwinsleepCmd(ClientData dummy, Tcl_Interp* interp,
int objc, Tcl_Obj *const objv[]);
static Tcl_ObjCmdProc TestExceptionCmd;
static int TestplatformChmod(const char *nativePath, int pmode);
-static int TestchmodCmd(ClientData dummy,
- Tcl_Interp *interp, int argc, const char **argv);
+static int TestchmodCmd(ClientData dummy, Tcl_Interp* interp,
+ int objc, Tcl_Obj *const objv[]);
/*
*----------------------------------------------------------------------
@@ -71,8 +71,8 @@ TclplatformtestInit(
* Add commands for platform specific tests for Windows here.
*/
- Tcl_CreateCommand(interp, "testchmod", TestchmodCmd, NULL, NULL);
- Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testchmod", TestchmodCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testeventloop", TesteventloopCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd, NULL, NULL);
@@ -103,21 +103,20 @@ static int
TesteventloopCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
static int *framePtr = NULL;/* Pointer to integer on stack frame of
* innermost invocation of the "wait"
* subcommand. */
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " option ... \"", NULL);
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ...");
return TCL_ERROR;
}
- if (strcmp(argv[1], "done") == 0) {
+ if (strcmp(Tcl_GetString(objv[1]), "done") == 0) {
*framePtr = 1;
- } else if (strcmp(argv[1], "wait") == 0) {
+ } else if (strcmp(Tcl_GetString(objv[1]), "wait") == 0) {
int *oldFramePtr, done;
int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
@@ -152,7 +151,7 @@ TesteventloopCmd(
(void) Tcl_SetServiceMode(oldMode);
framePtr = oldFramePtr;
} else {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
+ Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be done or wait", NULL);
return TCL_ERROR;
}
@@ -623,29 +622,25 @@ static int
TestchmodCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ int objc, /* Parameter count */
+ Tcl_Obj *const * objv) /* Parameter vector */
{
int i, mode;
- char *rest;
- if (argc < 2) {
- usage:
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " mode file ?file ...?", NULL);
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "mode file ?file ...?");
return TCL_ERROR;
}
- mode = (int) strtol(argv[1], &rest, 8);
- if ((rest == argv[1]) || (*rest != '\0')) {
- goto usage;
+ if (Tcl_GetIntFromObj(interp, objv[1], &mode) != TCL_OK) {
+ return TCL_ERROR;
}
- for (i = 2; i < argc; i++) {
+ for (i = 2; i < objc; i++) {
Tcl_DString buffer;
const char *translated;
- translated = Tcl_TranslateFileName(interp, argv[i], &buffer);
+ translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer);
if (translated == NULL) {
return TCL_ERROR;
}