summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclCmdAH.c2
-rw-r--r--generic/tclCompile.c14
-rw-r--r--generic/tclCompile.h1
-rw-r--r--generic/tclEnsemble.c7
-rw-r--r--generic/tclExecute.c2
-rw-r--r--generic/tclInt.h10
-rw-r--r--generic/tclLiteral.c32
-rw-r--r--generic/tclNamesp.c3
-rw-r--r--generic/tclObj.c5
-rw-r--r--generic/tclTest.c96
-rw-r--r--generic/tclUtf.c68
-rw-r--r--generic/tclVar.c24
-rw-r--r--generic/tclZlib.c48
-rw-r--r--library/auto.tcl11
-rw-r--r--tests/resolver.test117
-rw-r--r--tests/var.test30
-rw-r--r--tests/zlib.test23
-rw-r--r--win/Makefile.in2
-rw-r--r--win/coffbase.txt4
-rw-r--r--win/rules.vc2
-rwxr-xr-xwin/tclWinFile.c8
-rw-r--r--win/tclWinPipe.c2
-rw-r--r--win/tclWinPort.h2
23 files changed, 389 insertions, 124 deletions
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 88cc17d..4c299f8 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -1597,7 +1597,7 @@ FileAttrIsOwnedCmd(
Tcl_Obj *const objv[])
{
#ifdef __CYGWIN__
-#define geteuid() (short)(geteuid)()
+#define geteuid() (short)(geteuid)()
#endif
#if !defined(_WIN32)
Tcl_StatBuf buf;
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index c0203dd..f6b3c52 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -1781,9 +1781,17 @@ CompileCmdLiteral(
CompileEnv *envPtr)
{
int numBytes;
- const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes);
- int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes);
- Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
+ const char *bytes;
+ Command *cmdPtr;
+ int cmdLitIdx, extraLiteralFlags = LITERAL_CMD_NAME;
+
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
+ if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
+ extraLiteralFlags |= LITERAL_UNSHARED;
+ }
+
+ bytes = Tcl_GetStringFromObj(cmdObj, &numBytes);
+ cmdLitIdx = TclRegisterLiteral(envPtr, (char *)bytes, numBytes, extraLiteralFlags);
if (cmdPtr) {
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index d5bc86b..ba6ad44 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -1208,6 +1208,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
#define LITERAL_ON_HEAP 0x01
#define LITERAL_CMD_NAME 0x02
+#define LITERAL_UNSHARED 0x04
/*
* Form of TclRegisterLiteral with flags == 0. In that case, it is safe to
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 8e5e410..6fedf29 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -3306,7 +3306,7 @@ CompileToInvokedCommand(
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
char *bytes;
- int length, i, numWords, cmdLit;
+ int length, i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
DefineLineInformation;
/*
@@ -3349,7 +3349,10 @@ CompileToInvokedCommand(
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
bytes = Tcl_GetStringFromObj(objPtr, &length);
- cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length);
+ if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
+ extraLiteralFlags |= LITERAL_UNSHARED;
+ }
+ cmdLit = TclRegisterLiteral(envPtr, (char *)bytes, length, extraLiteralFlags);
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index e539161..34d92d3 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -3173,7 +3173,7 @@ TEBCresume(
Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL);
Tcl_ListObjAppendElement(NULL, copyPtr, objPtr);
- Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
+ Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
objc - opnd, objv + opnd);
Tcl_DecrRefCount(objPtr);
objPtr = copyPtr;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 4f7ea6e..4d3c0b1 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -1677,11 +1677,13 @@ typedef struct Command {
* (these last two flags are defined in tcl.h)
*/
-#define CMD_IS_DELETED 0x1
-#define CMD_TRACE_ACTIVE 0x2
-#define CMD_HAS_EXEC_TRACES 0x4
-#define CMD_COMPILES_EXPANDED 0x8
+#define CMD_IS_DELETED 0x01
+#define CMD_TRACE_ACTIVE 0x02
+#define CMD_HAS_EXEC_TRACES 0x04
+#define CMD_COMPILES_EXPANDED 0x08
#define CMD_REDEF_IN_PROGRESS 0x10
+#define CMD_VIA_RESOLVER 0x20
+
/*
*----------------------------------------------------------------
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
index 03200ca..4ae94a0 100644
--- a/generic/tclLiteral.c
+++ b/generic/tclLiteral.c
@@ -214,7 +214,7 @@ TclCreateLiteral(
if (globalPtrPtr) {
*globalPtrPtr = globalPtr;
}
- if (flags & LITERAL_ON_HEAP) {
+ if ((flags & LITERAL_ON_HEAP)) {
ckfree(bytes);
}
globalPtr->refCount++;
@@ -222,7 +222,7 @@ TclCreateLiteral(
}
}
if (!newPtr) {
- if (flags & LITERAL_ON_HEAP) {
+ if ((flags & LITERAL_ON_HEAP)) {
ckfree(bytes);
}
return NULL;
@@ -234,14 +234,23 @@ TclCreateLiteral(
*/
TclNewObj(objPtr);
- Tcl_IncrRefCount(objPtr);
- if (flags & LITERAL_ON_HEAP) {
+ if ((flags & LITERAL_ON_HEAP)) {
objPtr->bytes = bytes;
objPtr->length = length;
} else {
TclInitStringRep(objPtr, bytes, length);
}
+ if ((flags & LITERAL_UNSHARED)) {
+ /*
+ * Make clear, that no global value is returned
+ */
+ if (globalPtrPtr != NULL) {
+ *globalPtrPtr = NULL;
+ }
+ return objPtr;
+ }
+
#ifdef TCL_COMPILE_DEBUG
if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be",
@@ -251,6 +260,7 @@ TclCreateLiteral(
globalPtr = ckalloc(sizeof(LiteralEntry));
globalPtr->objPtr = objPtr;
+ Tcl_IncrRefCount(objPtr);
globalPtr->refCount = 1;
globalPtr->nsPtr = nsPtr;
globalPtr->nextPtr = globalTablePtr->buckets[globalHash];
@@ -398,7 +408,7 @@ TclRegisterLiteral(
if ((objPtr->length == length) && ((length == 0)
|| ((objPtr->bytes[0] == bytes[0])
&& (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) {
- if (flags & LITERAL_ON_HEAP) {
+ if ((flags & LITERAL_ON_HEAP)) {
ckfree(bytes);
}
objIndex = (localPtr - envPtr->literalArrayPtr);
@@ -417,7 +427,7 @@ TclRegisterLiteral(
* the namespace as the interp's global NS.
*/
- if (flags & LITERAL_CMD_NAME) {
+ if ((flags & LITERAL_CMD_NAME)) {
if ((length >= 2) && (bytes[0] == ':') && (bytes[1] == ':')) {
nsPtr = iPtr->globalNsPtr;
} else {
@@ -431,12 +441,13 @@ TclRegisterLiteral(
* Is it in the interpreter's global literal table? If not, create it.
*/
+ globalPtr = NULL;
objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, flags,
&globalPtr);
objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash);
#ifdef TCL_COMPILE_DEBUG
- if (globalPtr->refCount < 1) {
+ if (globalPtr != NULL && globalPtr->refCount < 1) {
Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
"TclRegisterLiteral", (length>60? 60 : length), bytes,
globalPtr->refCount);
@@ -1152,13 +1163,6 @@ TclVerifyLocalLiteralTable(
"TclVerifyLocalLiteralTable",
(length>60? 60 : length), bytes, localPtr->refCount);
}
- if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
- localPtr->objPtr) == NULL) {
- bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
- Tcl_Panic("%s: local literal \"%.*s\" is not global",
- "TclVerifyLocalLiteralTable",
- (length>60? 60 : length), bytes);
- }
if (localPtr->objPtr->bytes == NULL) {
Tcl_Panic("%s: literal has NULL string rep",
"TclVerifyLocalLiteralTable");
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 5930859..a8d351f 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -2566,7 +2566,9 @@ Tcl_FindCommand(
}
if (result == TCL_OK) {
+ ((Command *)cmd)->flags |= CMD_VIA_RESOLVER;
return cmd;
+
} else if (result != TCL_CONTINUE) {
return NULL;
}
@@ -2658,6 +2660,7 @@ Tcl_FindCommand(
}
if (cmdPtr != NULL) {
+ cmdPtr->flags &= ~CMD_VIA_RESOLVER;
return (Tcl_Command) cmdPtr;
}
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 628c3a7..29c8e23 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -4219,7 +4219,10 @@ TclSetCmdNameObj(
const char *name;
if (objPtr->typePtr == &tclCmdNameType) {
- return;
+ resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) {
+ return;
+ }
}
cmdPtr->refCount++;
diff --git a/generic/tclTest.c b/generic/tclTest.c
index e33d263..568dd01 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -7299,24 +7299,83 @@ InterpCmdResolver(
CallFrame *varFramePtr = iPtr->varFramePtr;
Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ?
varFramePtr->procPtr : NULL;
- Namespace *ns2NsPtr = (Namespace *)
- Tcl_FindNamespace(interp, "::ns2", NULL, 0);
+ Namespace *callerNsPtr = varFramePtr->nsPtr;
+ Tcl_Command resolvedCmdPtr = NULL;
- if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr
- || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) {
- const char *callingCmdName =
+ /*
+ * Just do something special on a cmd literal "z" in two cases:
+ * A) when the caller is a proc "x", and the proc is either in "::" or in "::ns2".
+ * B) the caller's namespace is "ctx1" or "ctx2"
+ */
+ if ( (name[0] == 'z') && (name[1] == '\0') ) {
+ Namespace *ns2NsPtr = (Namespace *) Tcl_FindNamespace(interp, "::ns2", NULL, 0);
+
+ if (procPtr != NULL
+ && ((procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr)
+ || (ns2NsPtr != NULL && procPtr->cmdPtr->nsPtr == ns2NsPtr)
+ )
+ ) {
+ /*
+ * Case A)
+ *
+ * - The context, in which this resolver becomes active, is
+ * determined by the name of the caller proc, which has to be
+ * named "x".
+ *
+ * - To determine the name of the caller proc, the proc is taken
+ * from the topmost stack frame.
+ *
+ * - Note that the context is NOT provided during byte-code
+ * compilation (e.g. in TclProcCompileProc)
+ *
+ * When these conditions hold, this function resolves the
+ * passed-in cmd literal into a cmd "y", which is taken from the
+ * the global namespace (for simplicity).
+ */
+
+ const char *callingCmdName =
Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr);
- if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0')
- && (name[0] == 'z') && (name[1] == '\0')) {
- Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL,
- TCL_GLOBAL_ONLY);
+ if ( callingCmdName[0] == 'x' && callingCmdName[1] == '\0' ) {
+ resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
+ }
+ } else if (callerNsPtr != NULL) {
+ /*
+ * Case B)
+ *
+ * - The context, in which this resolver becomes active, is
+ * determined by the name of the parent namespace, which has
+ * to be named "ctx1" or "ctx2".
+ *
+ * - To determine the name of the parent namesace, it is taken
+ * from the 2nd highest stack frame.
+ *
+ * - Note that the context can be provided during byte-code
+ * compilation (e.g. in TclProcCompileProc)
+ *
+ * When these conditions hold, this function resolves the
+ * passed-in cmd literal into a cmd "y" or "Y" depending on the
+ * context. The resolved procs are taken from the the global
+ * namespace (for simplicity).
+ */
+
+ CallFrame *parentFramePtr = varFramePtr->callerPtr;
+ char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)";
- if (sourceCmdPtr != NULL) {
- *rPtr = sourceCmdPtr;
- return TCL_OK;
+ if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
+ resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
+ /* fprintf(stderr, "... y ==> %p\n", resolvedCmdPtr);*/
+
+ } else if (strcmp(context, "ctx2") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
+ resolvedCmdPtr = Tcl_FindCommand(interp, "Y", NULL, TCL_GLOBAL_ONLY);
+ /*fprintf(stderr, "... Y ==> %p\n", resolvedCmdPtr);*/
}
}
+
+ if (resolvedCmdPtr != NULL) {
+ *rPtr = resolvedCmdPtr;
+ return TCL_OK;
+ }
}
return TCL_CONTINUE;
}
@@ -7449,9 +7508,16 @@ TestInterpResolverCmd(
int idx;
#define RESOLVER_KEY "testInterpResolver"
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "up|down");
- return TCL_ERROR;
+ if ((objc < 2) || (objc > 3)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "up|down ?interp?");
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ interp = Tcl_GetSlave(interp, Tcl_GetString(objv[2]));
+ if (interp == NULL) {
+ Tcl_AppendResult(interp, "provided interpreter not found", NULL);
+ return TCL_ERROR;
+ }
}
if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT,
&idx) != TCL_OK) {
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index b878149..68119a4 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -73,16 +73,7 @@ static const unsigned char totalBytes[256] = {
#else
1,1,1,1,1,1,1,1,
#endif
-#if TCL_UTF_MAX > 4
- 5,5,5,5,
-#else
- 1,1,1,1,
-#endif
-#if TCL_UTF_MAX > 5
- 6,6,6,6
-#else
- 1,1,1,1
-#endif
+ 1,1,1,1,1,1,1,1
};
/*
@@ -111,14 +102,14 @@ INLINE static int
UtfCount(
int ch) /* The Tcl_UniChar whose size is returned. */
{
- if ((ch > 0) && (ch < UNICODE_SELF)) {
+ if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
return 1;
}
if (ch <= 0x7FF) {
return 2;
}
#if TCL_UTF_MAX > 3
- if ((ch > 0xFFFF) && (ch <= 0x10FFFF)) {
+ if (((unsigned)(ch - 0x10000) <= 0xfffff)) {
return 4;
}
#endif
@@ -152,7 +143,7 @@ Tcl_UniCharToUtf(
* large enough to hold the UTF-8 character
* (at most TCL_UTF_MAX bytes). */
{
- if ((ch > 0) && (ch < UNICODE_SELF)) {
+ if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
buf[0] = (char) ch;
return 1;
}
@@ -180,11 +171,7 @@ Tcl_UniCharToUtf(
}
}
#endif
- three:
- buf[2] = (char) ((ch | 0x80) & 0xBF);
- buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF);
- buf[0] = (char) ((ch >> 12) | 0xE0);
- return 3;
+ goto three;
}
#if TCL_UTF_MAX > 3
@@ -199,7 +186,11 @@ Tcl_UniCharToUtf(
}
ch = 0xFFFD;
- goto three;
+three:
+ buf[2] = (char) ((ch | 0x80) & 0xBF);
+ buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF);
+ buf[0] = (char) ((ch >> 12) | 0xE0);
+ return 3;
}
/*
@@ -314,9 +305,6 @@ Tcl_UtfToUniChar(
* A two-byte-character lead-byte not followed by trail-byte
* represents itself.
*/
-
- *chPtr = (Tcl_UniChar) byte;
- return 1;
} else if (byte < 0xF0) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) {
/*
@@ -332,31 +320,23 @@ Tcl_UtfToUniChar(
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
-
- *chPtr = (Tcl_UniChar) byte;
- return 1;
}
#if TCL_UTF_MAX > 3
- {
- int ch, total, trail;
-
- total = totalBytes[byte];
- trail = total - 1;
- if (trail > 0) {
- ch = byte & (0x3F >> trail);
- do {
- src++;
- if ((*src & 0xC0) != 0x80) {
- *chPtr = byte;
- return 1;
- }
- ch <<= 6;
- ch |= (*src & 0x3F);
- trail--;
- } while (trail > 0);
- *chPtr = ch;
- return total;
+ else if (byte < 0xF8) {
+ if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
+ /*
+ * Four-byte-character lead byte followed by three trail bytes.
+ */
+
+ *chPtr = (Tcl_UniChar) (((byte & 0x0E) << 18) | ((src[1] & 0x3F) << 12)
+ | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F));
+ return 4;
}
+
+ /*
+ * A three-byte-character lead-byte not followed by two trail-bytes
+ * represents itself.
+ */
}
#endif
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 2adffbc..46a1da6 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -5193,13 +5193,16 @@ TclDeleteNamespaceVars(
VarHashRefCount(varPtr)++; /* Make sure we get to remove from
* hash. */
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
- UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, NULL, flags,
- -1);
- Tcl_DecrRefCount(objPtr); /* Free no longer needed obj */
+ UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr,
+ NULL, flags, -1);
/*
- * Remove the variable from the table and force it undefined in case
- * an unset trace brought it back from the dead.
+ * We just unset the variable. However, an unset trace might
+ * have re-set it, or might have re-established traces on it.
+ * This namespace and its vartable are going away unconditionally,
+ * so we cannot let such things linger. That would be a leak.
+ *
+ * First we destroy all traces. ...
*/
if (TclIsVarTraced(varPtr)) {
@@ -5223,6 +5226,17 @@ TclDeleteNamespaceVars(
}
}
}
+
+ /*
+ * ...and then, if the variable still holds a value, we unset it
+ * again. This time with no traces left, we're sure it goes away.
+ */
+
+ if (!TclIsVarUndefined(varPtr)) {
+ UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr,
+ NULL, flags, -1);
+ }
+ Tcl_DecrRefCount(objPtr); /* free no longer needed obj */
VarHashRefCount(varPtr)--;
VarHashDeleteEntry(varPtr);
}
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index dac47cf..c9d7b88 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -2864,7 +2864,7 @@ ZlibTransformClose(
Tcl_Interp *interp)
{
ZlibChannelData *cd = instanceData;
- int e, result = TCL_OK;
+ int e, written, result = TCL_OK;
/*
* Delete the support timer.
@@ -2882,6 +2882,17 @@ ZlibTransformClose(
cd->outStream.next_out = (Bytef *) cd->outBuffer;
cd->outStream.avail_out = (unsigned) cd->outAllocated;
e = deflate(&cd->outStream, Z_FINISH);
+ written = cd->outAllocated - cd->outStream.avail_out;
+
+ /*
+ * Can't be sure that deflate() won't declare the buffer to be
+ * full (with Z_BUF_ERROR) so handle that case.
+ */
+
+ if (e == Z_BUF_ERROR) {
+ e = Z_OK;
+ written = cd->outAllocated;
+ }
if (e != Z_OK && e != Z_STREAM_END) {
/* TODO: is this the right way to do errors on close? */
if (!TclInThreadExit()) {
@@ -2890,20 +2901,17 @@ ZlibTransformClose(
result = TCL_ERROR;
break;
}
- if (cd->outStream.avail_out != (unsigned) cd->outAllocated) {
- if (Tcl_WriteRaw(cd->parent, cd->outBuffer,
- cd->outAllocated - cd->outStream.avail_out) < 0) {
- /* TODO: is this the right way to do errors on close?
- * Note: when close is called from FinalizeIOSubsystem
- * then interp may be NULL */
- if (!TclInThreadExit() && interp) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "error while finalizing file: %s",
- Tcl_PosixError(interp)));
- }
- result = TCL_ERROR;
- break;
+ if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) < 0) {
+ /* TODO: is this the right way to do errors on close?
+ * Note: when close is called from FinalizeIOSubsystem then
+ * interp may be NULL */
+ if (!TclInThreadExit() && interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "error while finalizing file: %s",
+ Tcl_PosixError(interp)));
}
+ result = TCL_ERROR;
+ break;
}
} while (e != Z_STREAM_END);
(void) deflateEnd(&cd->outStream);
@@ -3084,7 +3092,17 @@ ZlibTransformOutput(
e = deflate(&cd->outStream, Z_NO_FLUSH);
produced = cd->outAllocated - cd->outStream.avail_out;
- if (e == Z_OK && produced > 0) {
+ if ((e == Z_OK && produced > 0) || e == Z_BUF_ERROR) {
+ /*
+ * deflate() indicates that it is out of space by returning
+ * Z_BUF_ERROR; in that case, we must write the whole buffer out
+ * and retry to compress what is left.
+ */
+
+ if (e == Z_BUF_ERROR) {
+ produced = cd->outAllocated;
+ e = Z_OK;
+ }
if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) {
*errorCodePtr = Tcl_GetErrno();
return -1;
diff --git a/library/auto.tcl b/library/auto.tcl
index 02edcc4..97ea8af 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -122,11 +122,9 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
# uniquify $dirs in order
array set seen {}
foreach i $dirs {
- # Take note that the [file normalize] below has been noted to cause
- # difficulties for the freewrap utility. See Bug 1072136. Until
- # freewrap resolves the matter, one might work around the problem by
- # disabling that branch.
+ # Make sure $i is unique under normalization. Avoid repeated [source].
if {[interp issafe]} {
+ # Safe interps have no [file normalize].
set norm $i
} else {
set norm [file normalize $i]
@@ -135,10 +133,7 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
continue
}
set seen($norm) {}
- lappend uniqdirs $i
- }
- set dirs $uniqdirs
- foreach i $dirs {
+
set the_library $i
set file [file join $i $initScript]
diff --git a/tests/resolver.test b/tests/resolver.test
index f3d22e5..9bb4c08 100644
--- a/tests/resolver.test
+++ b/tests/resolver.test
@@ -187,7 +187,7 @@ test resolver-2.1 {compiled var resolver: Bug #3383616} -setup {
# During the compilation the compiled var resolver, the resolve-specific
# var info is allocated, during the execution of the body, the variable is
# fetched and cached.
- x;
+ x
# During later calls, the cached variable is reused.
x
# When the proc is freed, the resolver-specific resolver var info is
@@ -196,6 +196,121 @@ test resolver-2.1 {compiled var resolver: Bug #3383616} -setup {
} -cleanup {
testinterpresolver down
} -result {}
+
+
+#
+# The test resolver-3.1* test bad interactions of resolvers on the "global"
+# (per interp) literal pools. A resolver might resolve a cmd literal depending
+# on a context differently, whereas the cmd literal sharing assumed that the
+# namespace containing the literal solely determines the resolved cmd (and is
+# resolver-agnostic).
+#
+# In order to make the test cases for the per-interpreter cmd literal pool
+# reproducable and to minimize interactions between test cases, we use a slave
+# interpreter per test-case.
+#
+#
+# Testing resolver in namespace-based context "ctx1"
+#
+test resolver-3.1a {
+ interp command resolver,
+ resolve literal "z" in proc "x1" in context "ctx1"
+} -setup {
+
+ interp create i0
+ testinterpresolver up i0
+ i0 eval {
+ proc y {} { return yy }
+ namespace eval ::ns {
+ proc x1 {} { z }
+ }
+ }
+} -constraints testinterpresolver -body {
+
+ set r [i0 eval {namespace eval ::ctx1 {
+ ::ns::x1
+ }}]
+
+ return $r
+} -cleanup {
+ testinterpresolver down i0
+ interp delete i0
+} -result {yy}
+
+#
+# Testing resolver in namespace-based context "ctx2"
+#
+test resolver-3.1b {
+ interp command resolver,
+ resolve literal "z" in proc "x2" in context "ctx2"
+} -setup {
+
+ interp create i0
+ testinterpresolver up i0
+ i0 eval {
+ proc Y {} { return YY }
+ namespace eval ::ns {
+ proc x2 {} { z }
+ }
+ }
+} -constraints testinterpresolver -body {
+
+ set r [i0 eval {namespace eval ::ctx2 {
+ ::ns::x2
+ }}]
+
+ return $r
+} -cleanup {
+ testinterpresolver down i0
+ interp delete i0
+} -result {YY}
+
+#
+# Testing resolver in namespace-based context "ctx1" and "ctx2" in the same
+# interpreter.
+#
+
+test resolver-3.1c {
+ interp command resolver,
+ resolve literal "z" in proc "x1" in context "ctx1",
+ resolve literal "z" in proc "x2" in context "ctx2"
+
+ Test, whether the shared cmd literal created by the first byte-code
+ compilation interacts with the second one.
+} -setup {
+
+ interp create i0
+ testinterpresolver up i0
+
+ i0 eval {
+ proc y {} { return yy }
+ proc Y {} { return YY }
+ namespace eval ::ns {
+ proc x1 {} { z }
+ proc x2 {} { z }
+ }
+ }
+
+} -constraints testinterpresolver -body {
+
+ set r1 [i0 eval {namespace eval ::ctx1 {
+ ::ns::x1
+ }}]
+
+ set r2 [i0 eval {namespace eval ::ctx2 {
+ ::ns::x2
+ }}]
+
+ set r3 [i0 eval {namespace eval ::ctx1 {
+ ::ns::x1
+ }}]
+
+ return [list $r1 $r2 $r3]
+} -cleanup {
+ testinterpresolver down i0
+ interp delete i0
+} -result {yy YY yy}
+
cleanupTests
return
diff --git a/tests/var.test b/tests/var.test
index 297034a..a9d93ac 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -26,6 +26,20 @@ testConstraint testupvar [llength [info commands testupvar]]
testConstraint testgetvarfullname [llength [info commands testgetvarfullname]]
testConstraint testsetnoerr [llength [info commands testsetnoerr]]
testConstraint memory [llength [info commands memory]]
+if {[testConstraint memory]} {
+ proc getbytes {} {
+ return [lindex [split [memory info] \n] 3 3]
+ }
+ proc leaktest {script {iterations 3}} {
+ set end [getbytes]
+ for {set i 0} {$i < $iterations} {incr i} {
+ uplevel 1 $script
+ set tmp $end
+ set end [getbytes]
+ }
+ return [expr {$end - $tmp}]
+ }
+}
catch {rename p ""}
catch {namespace delete test_ns_var}
@@ -579,6 +593,22 @@ test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called wit
list [namespace delete test_ns_var] $::info
} -result {{} {::test_ns_var::v {} u}}
+test var-8.3 {TclDeleteNamespaceVars, mem leak} -constraints memory -setup {
+ proc ::t {a i o} {
+ set $a 321
+ }
+} -body {
+ leaktest {
+ namespace eval n {
+ variable v 123
+ trace variable v u ::t
+ }
+ namespace delete n
+ }
+} -cleanup {
+ rename ::t {}
+} -result 0
+
test var-9.1 {behaviour of TclGet/SetVar simple get/set} -setup {
catch {unset u}
catch {unset v}
diff --git a/tests/zlib.test b/tests/zlib.test
index 8a040d8..15dbb34 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -917,6 +917,29 @@ test zlib-12.1 {Tk Bug 9eb55debc5} -constraints zlib -setup {
} -cleanup {
$stream close
} -result {12026 18000}
+test zlib-12.2 {Patrick Dunnigan's issue} -constraints zlib -setup {
+ set filesrc [makeFile {} test.input]
+ set filedst [makeFile {} test.output]
+ set f [open $filesrc "wb"]
+ for {set i 0} {$i < 10000} {incr i} {
+ puts -nonewline $f "x"
+ }
+ close $f
+} -body {
+ set fin [open $filesrc "rb"]
+ set fout [open $filedst "wb"]
+ set header [dict create filename "test.input" time 0]
+ try {
+ fcopy $fin [zlib push gzip $fout -header $header]
+ } finally {
+ close $fin
+ close $fout
+ }
+ file size $filedst
+} -cleanup {
+ removeFile $filesrc
+ removeFile $filedst
+} -result 4152
::tcltest::cleanupTests
return
diff --git a/win/Makefile.in b/win/Makefile.in
index 28ffe0a..066e6b1 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -81,7 +81,7 @@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@
#CFLAGS = $(CFLAGS_DEBUG)
#CFLAGS = $(CFLAGS_OPTIMIZE)
#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE)
-CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DUNICODE -D_UNICODE
+CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DUNICODE -D_UNICODE -D_ATL_XP_TARGETING
# To compile without backward compatibility and deprecated code uncomment the
# following
diff --git a/win/coffbase.txt b/win/coffbase.txt
index 0142bb3..3314f26 100644
--- a/win/coffbase.txt
+++ b/win/coffbase.txt
@@ -13,8 +13,8 @@
; linker with the `-base:@$(TCLDIR)\win\coffbase.txt,<key>` option.
tcl 0x10000000 0x00200000
-tcldde 0x10200000 0x00020000
-tclreg 0x10210000 0x00020000
+tcldde 0x10200000 0x00010000
+tclreg 0x10210000 0x00010000
tk 0x10220000 0x00200000
expect 0x10480000 0x00080000
itcl 0x10500000 0x00080000
diff --git a/win/rules.vc b/win/rules.vc
index cd06e96..e12854d 100644
--- a/win/rules.vc
+++ b/win/rules.vc
@@ -159,7 +159,7 @@ DEBUGFLAGS = $(DEBUGFLAGS) -RTC1
DEBUGFLAGS = $(DEBUGFLAGS) -GZ
!endif
-COMPILERFLAGS =-W3 -DUNICODE -D_UNICODE -D_USING_V110_SDK71_=1
+COMPILERFLAGS =-W3 /DUNICODE /D_UNICODE /D_ATL_XP_TARGETING
# In v13 -GL and -YX are incompatible.
!if [nmakehlp -c -YX]
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 4d7500b..6662327 100755
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -3166,8 +3166,8 @@ TclWinFileOwned(
case we are in all likelihood not the owner */
return 0;
}
-
- /*
+
+ /*
* Getting the current process SID is a multi-step process.
* We make the assumption that if a call fails, this process is
* so underprivileged it could not possibly own anything. Normally
@@ -3191,10 +3191,10 @@ TclWinFileOwned(
LocalFree(secd); /* Also frees ownerSid */
if (buf)
ckfree(buf);
-
+
return (owned != 0); /* Convert non-0 to 1 */
}
-
+
/*
* Local Variables:
* mode: c
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
index 382addd..4666deb 100644
--- a/win/tclWinPipe.c
+++ b/win/tclWinPipe.c
@@ -1337,7 +1337,7 @@ ApplicationType(
Tcl_DStringFree(&ds);
ext = strrchr(fullName, '.');
- if ((ext != NULL) &&
+ if ((ext != NULL) &&
(strcasecmp(ext, ".cmd") == 0 || strcasecmp(ext, ".bat") == 0)) {
applType = APPL_DOS;
break;
diff --git a/win/tclWinPort.h b/win/tclWinPort.h
index b486466..159a708 100644
--- a/win/tclWinPort.h
+++ b/win/tclWinPort.h
@@ -360,7 +360,7 @@ typedef DWORD_PTR * PDWORD_PTR;
# define S_IFLNK 0120000 /* Symbolic Link */
#endif
-/*
+/*
* Windows compilers do not define S_IFBLK. However, Tcl uses it in
* GetTypeFromMode to identify blockSpecial devices based on the
* value in the statsbuf st_mode field. We have no other way to pass this
generated by cgit v0.12 at 2024-08-21 17:44:12 (GMT)