From 2bd794f7cc85201d24a257dff0b649c9dd1eb0a5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Sep 2016 12:11:01 +0000 Subject: Proposed patch for [d4e7780ca1681cd095dbd81fe264feff75c988f7|d4e7780ca1], by Gustaf Neumann --- generic/tclCompExpr.c | 2 +- generic/tclCompile.c | 16 ++++-- generic/tclCompile.h | 5 +- generic/tclEnsemble.c | 9 +++- generic/tclInt.h | 10 ++-- generic/tclLiteral.c | 33 ++++++++---- generic/tclNamesp.c | 3 ++ generic/tclObj.c | 9 +++- generic/tclTest.c | 104 ++++++++++++++++++++++++++++++------- tests/resolver.test | 141 ++++++++++++++++++++++++++++++++++++++++++++++---- 10 files changed, 279 insertions(+), 53 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 4390282..ab5e8af 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2272,7 +2272,7 @@ CompileExprTree( Tcl_DStringAppend(&cmdName, p, length); TclEmitPush(TclRegisterNewCmdLiteral(envPtr, Tcl_DStringValue(&cmdName), - Tcl_DStringLength(&cmdName)), envPtr); + Tcl_DStringLength(&cmdName), 0), envPtr); Tcl_DStringFree(&cmdName); /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c0203dd..4e4ead6 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1781,10 +1781,20 @@ 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 = 0; + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + if (cmdPtr != NULL) { + if ((cmdPtr->flags & CMD_VIA_RESOLVER)) { + extraLiteralFlags = LITERAL_UNSHARED; + } + } + bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes, extraLiteralFlags); + if (cmdPtr) { TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index d5bc86b..fa76f83 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 @@ -1229,8 +1230,8 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, * int length); */ -#define TclRegisterNewCmdLiteral(envPtr, bytes, length) \ - TclRegisterLiteral(envPtr, (char *)(bytes), length, LITERAL_CMD_NAME) +#define TclRegisterNewCmdLiteral(envPtr, bytes, length, extraLiteralFlags) \ + TclRegisterLiteral(envPtr, (char *)(bytes), length, ((extraLiteralFlags)|LITERAL_CMD_NAME)) /* * Macro used to manually adjust the stack requirements; used in cases where diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 8e5e410..22c475f 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 = 0; DefineLineInformation; /* @@ -3349,7 +3349,12 @@ CompileToInvokedCommand( objPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); bytes = Tcl_GetStringFromObj(objPtr, &length); - cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length); + if (cmdPtr != NULL) { + if ((cmdPtr->flags & CMD_VIA_RESOLVER)) { + extraLiteralFlags = LITERAL_UNSHARED; + } + } + cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length, extraLiteralFlags); TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); 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..864d050 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -214,15 +214,16 @@ TclCreateLiteral( if (globalPtrPtr) { *globalPtrPtr = globalPtr; } - if (flags & LITERAL_ON_HEAP) { + if ((flags & LITERAL_ON_HEAP)) { ckfree(bytes); } globalPtr->refCount++; return objPtr; } } + if (!newPtr) { - if (flags & LITERAL_ON_HEAP) { + if ((flags & LITERAL_ON_HEAP)) { ckfree(bytes); } return NULL; @@ -235,13 +236,24 @@ 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; + } + /*fprintf(stderr, "UNSHARED LITERAL <%s>\n", bytes);*/ + return objPtr; + } + #ifdef TCL_COMPILE_DEBUG if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be", @@ -417,7 +429,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 { @@ -426,17 +438,17 @@ TclRegisterLiteral( } else { nsPtr = NULL; } - + /* * 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); @@ -1155,9 +1167,10 @@ TclVerifyLocalLiteralTable( 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); + //Tcl_Panic("%s: local literal \"%.*s\" is not global", + // "TclVerifyLocalLiteralTable", + // (length>60? 60 : length), bytes); + /*fprintf(stderr, "local literal \"%s\" is not global\n",bytes);*/ } if (localPtr->objPtr->bytes == NULL) { Tcl_Panic("%s: literal has NULL string rep", 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..661ab48 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->cmdPtr == cmdPtr) { + return; + } } cmdPtr->refCount++; @@ -4397,7 +4400,9 @@ SetCmdNameFromAny( cmdPtr->refCount++; resPtr = objPtr->internalRep.twoPtrValue.ptr1; if ((objPtr->typePtr == &tclCmdNameType) - && resPtr && (resPtr->refCount == 1)) { + && resPtr != NULL + && (resPtr->refCount == 1) + ) { /* * Reuse the old ResolvedCmdName struct instead of freeing it */ diff --git a/generic/tclTest.c b/generic/tclTest.c index e33d263..522e966 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7295,29 +7295,88 @@ InterpCmdResolver( int flags, Tcl_Command *rPtr) { - Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ? - varFramePtr->procPtr : NULL; - Namespace *ns2NsPtr = (Namespace *) - Tcl_FindNamespace(interp, "::ns2", NULL, 0); - - if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr - || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) { - const char *callingCmdName = + Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; + Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ? varFramePtr->procPtr : NULL; + Namespace *callerNsPtr = varFramePtr->nsPtr; + Tcl_Command resolvedCmdPtr = NULL; + + /* + * 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' ) { + 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). + */ - if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0') - && (name[0] == 'z') && (name[1] == '\0')) { - Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL, - TCL_GLOBAL_ONLY); + 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,10 +7508,17 @@ TestInterpResolverCmd( int idx; #define RESOLVER_KEY "testInterpResolver" - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "up|down"); + 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) { return TCL_ERROR; diff --git a/tests/resolver.test b/tests/resolver.test index f3d22e5..01e2e0b 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -38,10 +38,12 @@ test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup # is turned into a command literal shared for a given (here: the global) # namespace. set r0 [x]; # --> The result of [x] is "Y" + # 2) After having requested cmd resolution above, we can now use the # globally shared CmdName Tcl_Obj "z", now bound to cmd ::y. This is # certainly questionable, but defensible set r1 [z]; # --> The result of [z] is "Y" + # 3) We import from the namespace ns1 another z. [namespace import] takes # care "shadowed" cmd references, however, till now cmd literals have not # been touched. This is, however, necessary since the BC compiler (used in @@ -59,12 +61,12 @@ test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup rename ::y "" namespace delete ::ns1 } -result {Y Y Z} + + test resolver-1.2 {cmdNameObj sharing vs. cmd resolver: proc creation} -setup { testinterpresolver up proc ::y {} { return Y } - proc ::x {} { - z - } + proc ::x {} { z } } -constraints testinterpresolver -body { set r0 [x] set r1 [z] @@ -80,6 +82,8 @@ test resolver-1.2 {cmdNameObj sharing vs. cmd resolver: proc creation} -setup { rename ::foo "" rename ::z "" } -result {Y Y Z} + + test resolver-1.3 {cmdNameObj sharing vs. cmd resolver: rename} -setup { testinterpresolver up proc ::Z {} { return Z } @@ -101,6 +105,8 @@ test resolver-1.3 {cmdNameObj sharing vs. cmd resolver: rename} -setup { rename ::y "" rename ::z "" } -result {Y Y Z} + + test resolver-1.4 {cmdNameObj sharing vs. cmd resolver: interp expose} -setup { testinterpresolver up proc ::Z {} { return Z } @@ -123,6 +129,8 @@ test resolver-1.4 {cmdNameObj sharing vs. cmd resolver: interp expose} -setup { rename ::y "" rename ::z "" } -result {Y Y Z} + + test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -setup { testinterpresolver up namespace eval ::ns1 { @@ -131,9 +139,7 @@ test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -s } proc ::y {} { return Y } namespace eval ::ns2 { - proc x {} { - z - } + proc x {} { z } } namespace eval :: { variable r2 "" @@ -151,13 +157,13 @@ test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -s namespace delete ::ns2 namespace delete ::ns1 } -result {Y Y Z} + + test resolver-1.6 {cmdNameObj sharing vs. cmd resolver: interp alias} -setup { testinterpresolver up proc ::Z {} { return Z } proc ::y {} { return Y } - proc ::x {} { - z - } + proc ::x {} { z } } -constraints testinterpresolver -body { set r0 [x] set r1 [z] @@ -187,7 +193,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 +202,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 -- cgit v0.12 From 6f860bc18d7bc3154d11ac863b4ebc1612dff554 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 5 Sep 2016 13:14:45 +0000 Subject: Some patch clean-up, no change in functionality --- generic/tclCompExpr.c | 2 +- generic/tclCompile.c | 4 ++-- generic/tclCompile.h | 4 ++-- generic/tclEnsemble.c | 2 +- generic/tclLiteral.c | 20 ++++++++------------ generic/tclTest.c | 18 +++++++++--------- tests/resolver.test | 26 ++++++++++---------------- 7 files changed, 33 insertions(+), 43 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index ab5e8af..4390282 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2272,7 +2272,7 @@ CompileExprTree( Tcl_DStringAppend(&cmdName, p, length); TclEmitPush(TclRegisterNewCmdLiteral(envPtr, Tcl_DStringValue(&cmdName), - Tcl_DStringLength(&cmdName), 0), envPtr); + Tcl_DStringLength(&cmdName)), envPtr); Tcl_DStringFree(&cmdName); /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 4e4ead6..ee36bff 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1793,8 +1793,8 @@ CompileCmdLiteral( } bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); - cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes, extraLiteralFlags); - + cmdLitIdx = TclRegisterLiteral(envPtr, (char *)bytes, numBytes, extraLiteralFlags|LITERAL_CMD_NAME); + if (cmdPtr) { TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index fa76f83..ba6ad44 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1230,8 +1230,8 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, * int length); */ -#define TclRegisterNewCmdLiteral(envPtr, bytes, length, extraLiteralFlags) \ - TclRegisterLiteral(envPtr, (char *)(bytes), length, ((extraLiteralFlags)|LITERAL_CMD_NAME)) +#define TclRegisterNewCmdLiteral(envPtr, bytes, length) \ + TclRegisterLiteral(envPtr, (char *)(bytes), length, LITERAL_CMD_NAME) /* * Macro used to manually adjust the stack requirements; used in cases where diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 22c475f..67ee65e 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3354,7 +3354,7 @@ CompileToInvokedCommand( extraLiteralFlags = LITERAL_UNSHARED; } } - cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length, extraLiteralFlags); + cmdLit = TclRegisterLiteral(envPtr, (char *)bytes, length, extraLiteralFlags|LITERAL_CMD_NAME); TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 864d050..484b86b 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -214,16 +214,15 @@ TclCreateLiteral( if (globalPtrPtr) { *globalPtrPtr = globalPtr; } - if ((flags & LITERAL_ON_HEAP)) { + if (flags & LITERAL_ON_HEAP) { ckfree(bytes); } globalPtr->refCount++; return objPtr; } } - if (!newPtr) { - if ((flags & LITERAL_ON_HEAP)) { + if (flags & LITERAL_ON_HEAP) { ckfree(bytes); } return NULL; @@ -236,15 +235,15 @@ 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)) { - /* + if (flags & LITERAL_UNSHARED) { + /* * Make clear, that no global value is returned */ if (globalPtrPtr != NULL) { @@ -429,7 +428,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 { @@ -438,10 +437,11 @@ TclRegisterLiteral( } else { nsPtr = NULL; } - + /* * 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); @@ -1167,10 +1167,6 @@ TclVerifyLocalLiteralTable( 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); - /*fprintf(stderr, "local literal \"%s\" is not global\n",bytes);*/ } if (localPtr->objPtr->bytes == NULL) { Tcl_Panic("%s: literal has NULL string rep", diff --git a/generic/tclTest.c b/generic/tclTest.c index 522e966..1e595d6 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7308,21 +7308,21 @@ InterpCmdResolver( */ 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) + * 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. + * from the topmost stack frame. * * - Note that the context is NOT provided during byte-code * compilation (e.g. in TclProcCompileProc) @@ -7331,23 +7331,23 @@ InterpCmdResolver( * 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' ) { resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY); } } else if (callerNsPtr != NULL) { /* - * Case B) + * 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. + * from the 2nd highest stack frame. * * - Note that the context can be provided during byte-code * compilation (e.g. in TclProcCompileProc) @@ -7364,13 +7364,13 @@ InterpCmdResolver( 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; diff --git a/tests/resolver.test b/tests/resolver.test index 01e2e0b..dc38ff0 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -38,12 +38,10 @@ test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup # is turned into a command literal shared for a given (here: the global) # namespace. set r0 [x]; # --> The result of [x] is "Y" - # 2) After having requested cmd resolution above, we can now use the # globally shared CmdName Tcl_Obj "z", now bound to cmd ::y. This is # certainly questionable, but defensible set r1 [z]; # --> The result of [z] is "Y" - # 3) We import from the namespace ns1 another z. [namespace import] takes # care "shadowed" cmd references, however, till now cmd literals have not # been touched. This is, however, necessary since the BC compiler (used in @@ -61,12 +59,12 @@ test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup rename ::y "" namespace delete ::ns1 } -result {Y Y Z} - - test resolver-1.2 {cmdNameObj sharing vs. cmd resolver: proc creation} -setup { testinterpresolver up proc ::y {} { return Y } - proc ::x {} { z } + proc ::x {} { + z + } } -constraints testinterpresolver -body { set r0 [x] set r1 [z] @@ -82,8 +80,6 @@ test resolver-1.2 {cmdNameObj sharing vs. cmd resolver: proc creation} -setup { rename ::foo "" rename ::z "" } -result {Y Y Z} - - test resolver-1.3 {cmdNameObj sharing vs. cmd resolver: rename} -setup { testinterpresolver up proc ::Z {} { return Z } @@ -105,8 +101,6 @@ test resolver-1.3 {cmdNameObj sharing vs. cmd resolver: rename} -setup { rename ::y "" rename ::z "" } -result {Y Y Z} - - test resolver-1.4 {cmdNameObj sharing vs. cmd resolver: interp expose} -setup { testinterpresolver up proc ::Z {} { return Z } @@ -129,8 +123,6 @@ test resolver-1.4 {cmdNameObj sharing vs. cmd resolver: interp expose} -setup { rename ::y "" rename ::z "" } -result {Y Y Z} - - test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -setup { testinterpresolver up namespace eval ::ns1 { @@ -139,7 +131,9 @@ test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -s } proc ::y {} { return Y } namespace eval ::ns2 { - proc x {} { z } + proc x {} { + z + } } namespace eval :: { variable r2 "" @@ -157,13 +151,13 @@ test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -s namespace delete ::ns2 namespace delete ::ns1 } -result {Y Y Z} - - test resolver-1.6 {cmdNameObj sharing vs. cmd resolver: interp alias} -setup { testinterpresolver up proc ::Z {} { return Z } proc ::y {} { return Y } - proc ::x {} { z } + proc ::x {} { + z + } } -constraints testinterpresolver -body { set r0 [x] set r1 [z] @@ -193,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 -- cgit v0.12 From b74823229102197226f39d91b52b146826567cf4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 5 Sep 2016 14:52:01 +0000 Subject: some more clean-up --- generic/tclCompile.c | 10 ++++------ generic/tclEnsemble.c | 10 ++++------ generic/tclLiteral.c | 4 +++- generic/tclObj.c | 12 +++++------- 4 files changed, 16 insertions(+), 20 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index ee36bff..f6b3c52 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1783,17 +1783,15 @@ CompileCmdLiteral( int numBytes; const char *bytes; Command *cmdPtr; - int cmdLitIdx, extraLiteralFlags = 0; + int cmdLitIdx, extraLiteralFlags = LITERAL_CMD_NAME; cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); - if (cmdPtr != NULL) { - if ((cmdPtr->flags & CMD_VIA_RESOLVER)) { - extraLiteralFlags = LITERAL_UNSHARED; - } + if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { + extraLiteralFlags |= LITERAL_UNSHARED; } bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); - cmdLitIdx = TclRegisterLiteral(envPtr, (char *)bytes, numBytes, extraLiteralFlags|LITERAL_CMD_NAME); + cmdLitIdx = TclRegisterLiteral(envPtr, (char *)bytes, numBytes, extraLiteralFlags); if (cmdPtr) { TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 67ee65e..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, extraLiteralFlags = 0; + int length, i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; DefineLineInformation; /* @@ -3349,12 +3349,10 @@ CompileToInvokedCommand( objPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); bytes = Tcl_GetStringFromObj(objPtr, &length); - if (cmdPtr != NULL) { - if ((cmdPtr->flags & CMD_VIA_RESOLVER)) { - extraLiteralFlags = LITERAL_UNSHARED; - } + if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { + extraLiteralFlags |= LITERAL_UNSHARED; } - cmdLit = TclRegisterLiteral(envPtr, (char *)bytes, length, extraLiteralFlags|LITERAL_CMD_NAME); + cmdLit = TclRegisterLiteral(envPtr, (char *)bytes, length, extraLiteralFlags); TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 484b86b..c329ed7 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -249,7 +249,6 @@ TclCreateLiteral( if (globalPtrPtr != NULL) { *globalPtrPtr = NULL; } - /*fprintf(stderr, "UNSHARED LITERAL <%s>\n", bytes);*/ return objPtr; } @@ -1167,6 +1166,9 @@ TclVerifyLocalLiteralTable( 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", diff --git a/generic/tclObj.c b/generic/tclObj.c index 661ab48..283c8d2 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -4219,10 +4219,10 @@ TclSetCmdNameObj( const char *name; if (objPtr->typePtr == &tclCmdNameType) { - resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if (resPtr->cmdPtr == cmdPtr) { - return; - } + resPtr = objPtr->internalRep.twoPtrValue.ptr1; + if (resPtr->cmdPtr == cmdPtr) { + return; + } } cmdPtr->refCount++; @@ -4400,9 +4400,7 @@ SetCmdNameFromAny( cmdPtr->refCount++; resPtr = objPtr->internalRep.twoPtrValue.ptr1; if ((objPtr->typePtr == &tclCmdNameType) - && resPtr != NULL - && (resPtr->refCount == 1) - ) { + && resPtr && (resPtr->refCount == 1)) { /* * Reuse the old ResolvedCmdName struct instead of freeing it */ -- cgit v0.12 From 98dbefe2cc97be5b598d5dbf0287a3b332f121ea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 6 Sep 2016 08:25:18 +0000 Subject: Additiona patch/suggestion from Gustaf. This indeed fixes the crash in oo.test. Looks good to me, so only waiting for final feedback from Gustaf and eventually feedback from other people. --- generic/tclLiteral.c | 7 ------- generic/tclObj.c | 2 +- 2 files changed, 1 insertion(+), 8 deletions(-) diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index c329ed7..6b3560d 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -1163,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/tclObj.c b/generic/tclObj.c index 283c8d2..29c8e23 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -4220,7 +4220,7 @@ TclSetCmdNameObj( if (objPtr->typePtr == &tclCmdNameType) { resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if (resPtr->cmdPtr == cmdPtr) { + if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) { return; } } -- cgit v0.12 From 7ccdd3657bcc55c8e1635e046ab83be482855420 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 6 Sep 2016 10:44:45 +0000 Subject: Fixed bug in pushed transforms with full internal buffers not writing out. --- generic/tclZlib.c | 48 +++++++++++++++++++++++++++++++++--------------- tests/zlib.test | 23 +++++++++++++++++++++++ 2 files changed, 56 insertions(+), 15 deletions(-) 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/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 -- cgit v0.12