From 6b17a1e25a0decc3f6acbd09b70e06186e781f6e Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Apr 2013 18:11:33 +0000 Subject: Revise TclNREvalObjv so that pre-resolution of the Command by a caller does not force suppression of exception handling. Let those be separable demands. Aim is to bring TclObjInvoke*() into the fold. --- generic/tclBasic.c | 17 ++++++++++++----- generic/tclNamesp.c | 2 +- generic/tclOOMethod.c | 2 +- 3 files changed, 14 insertions(+), 7 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cde1cb9..22ec6b0 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4188,10 +4188,6 @@ TclNREvalObjv( return result; } - if (cmdPtr) { - goto commandFound; - } - /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). @@ -4201,6 +4197,10 @@ TclNREvalObjv( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } + if (cmdPtr) { + goto commandFound; + } + /* * Configure evaluation context to match the requested flags. */ @@ -6620,9 +6620,11 @@ TclObjInvoke( Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } +#if 1 if (TclInterpReady(interp) == TCL_ERROR) { return TCL_ERROR; } +#endif cmdName = TclGetString(objv[0]); hTblPtr = iPtr->hiddenCmdTablePtr; @@ -6638,6 +6640,7 @@ TclObjInvoke( } cmdPtr = Tcl_GetHashValue(hPtr); +#if 1 /* * Invoke the command function. */ @@ -6669,6 +6672,9 @@ TclObjInvoke( iPtr->flags &= ~ERR_ALREADY_LOGGED; } return result; +#else + +#endif } /* @@ -8243,7 +8249,8 @@ Tcl_NRCmdSwap( Tcl_Obj *const objv[], int flags) { - return TclNREvalObjv(interp, objc, objv, flags, (Command *) cmd); + return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR, + (Command *) cmd); } /***************************************************************************** diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index aed623a..bdd5386 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1942,7 +1942,7 @@ InvokeImportedNRCmd( Command *realCmdPtr = dataPtr->realCmdPtr; TclSkipTailcall(interp); - return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0); + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr); } static int diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 98b4078..bd2744a 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1429,7 +1429,7 @@ InvokeForwardMethod( contextPtr->oPtr->namespacePtr, 0 /* normal lookup */); } Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); - return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, cmdPtr); + return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, cmdPtr); } static int -- cgit v0.12 From 1ddb66bfdaba5d875111c7b0f6ebecc8d5e69f35 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 9 Apr 2013 19:04:04 +0000 Subject: Use the double-secret iPtr->lookupNsPtr field to get post-enter-trace re-resolutions of commands done in the right context for oo forwards. --- generic/tclOOMethod.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 98b4078..5296397 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1429,6 +1429,7 @@ InvokeForwardMethod( contextPtr->oPtr->namespacePtr, 0 /* normal lookup */); } Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); + ((Interp *)interp)->lookupNsPtr = contextPtr->oPtr->namespacePtr; return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, cmdPtr); } -- cgit v0.12 From b6b0d1b8dd33bb6eb9c97217ec0c813452cafaed Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 9 Apr 2013 20:01:08 +0000 Subject: added some test cases, based on bug report --- tests/oo.test | 63 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 63 insertions(+) diff --git a/tests/oo.test b/tests/oo.test index 49fe150..84e6236 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -936,6 +936,69 @@ test oo-6.18 {Bug 3408830: more forwarding cases} -setup { } -returnCodes error -cleanup { fooClass destroy } -result {wrong # args: should be "::foo len string"} +test oo-6.19 {Bug 3610404: forwarding resolution + traces} -setup { + oo::object create foo + unset -nocomplain ::result + set ::result {} +} -body { + proc ::my {method} {lappend ::result global} + oo::objdefine foo { + method target {} {lappend ::result instance} + forward bar my target + method bump {} { + set ns [info object namespace ::foo] + rename ${ns}::my ${ns}:: + rename ${ns}:: ${ns}::my + } + } + proc harness {} { + foo target + foo bar + foo target + } + trace add execution harness enterstep {apply {{cmd args} {foo bump}}} + foo target + foo bar + foo bump + foo bar + harness +} -cleanup { + catch {rename harness {}} + catch {rename ::my {}} + foo destroy +} -result {instance instance instance instance instance instance} +test oo-6.20 {Bug 3610404: forwarding resolution + traces} -setup { + oo::class create fooClass + fooClass create foo + unset -nocomplain ::result + set ::result {} +} -body { + proc ::my {method} {lappend ::result global} + oo::define fooClass { + method target {} {lappend ::result class} + forward bar my target + method bump {} { + set ns [info object namespace [self]] + rename ${ns}::my ${ns}:: + rename ${ns}:: ${ns}::my + } + } + proc harness {} { + foo target + foo bar + foo target + } + trace add execution harness enterstep {apply {{cmd args} {foo bump}}} + foo target + foo bar + foo bump + foo bar + harness +} -cleanup { + catch {rename harness {}} + catch {rename ::my {}} + fooClass destroy +} -result {class class class class class class} test oo-7.1 {OO: inheritance 101} -setup { oo::class create superClass -- cgit v0.12 From 65978723356ae1cc7caa39411544d5f9a190b154 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Apr 2013 14:39:56 +0000 Subject: New internal routine TclNRInvoke() - NR-enabled path through the machinery behind invokehidden commands. --- generic/tclBasic.c | 77 +++++++++++++++++++++-------------------------------- generic/tclInt.h | 1 + generic/tclInterp.c | 7 ++++- 3 files changed, 37 insertions(+), 48 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 22ec6b0..82ce385 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -162,6 +162,7 @@ static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; static Tcl_ObjCmdProc NRCoroInjectObjCmd; +static Tcl_NRPostProc NRPostInvoke; MODULE_SCOPE const TclStubs tclStubs; @@ -6599,32 +6600,32 @@ TclObjInvoke( * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, * or TCL_INVOKE_NO_TRACEBACK. */ { - register Interp *iPtr = (Interp *) interp; - Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ - const char *cmdName; /* Name of the command from objv[0]. */ - Tcl_HashEntry *hPtr = NULL; - Command *cmdPtr; - int result; - if (interp == NULL) { return TCL_ERROR; } - if ((objc < 1) || (objv == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal argument vector", -1)); return TCL_ERROR; } - if ((flags & TCL_INVOKE_HIDDEN) == 0) { Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } + return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv); +} -#if 1 - if (TclInterpReady(interp) == TCL_ERROR) { - return TCL_ERROR; - } -#endif +int +TclNRInvoke( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + register Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ + const char *cmdName; /* Name of the command from objv[0]. */ + Tcl_HashEntry *hPtr = NULL; + Command *cmdPtr; cmdName = TclGetString(objv[0]); hTblPtr = iPtr->hiddenCmdTablePtr; @@ -6640,41 +6641,23 @@ TclObjInvoke( } cmdPtr = Tcl_GetHashValue(hPtr); -#if 1 - /* - * Invoke the command function. - */ - - iPtr->cmdCount++; - if (cmdPtr->objProc != NULL) { - result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } else { - result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, - cmdPtr->objClientData, objc, objv); - } - - /* - * If an error occurred, record information about what was being executed - * when the error occurred. - */ - - if ((result == TCL_ERROR) - && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) - && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { - int length; - Tcl_Obj *command = Tcl_NewListObj(objc, objv); - const char *cmdString; + /* Avoid the exception-handling brain damage when numLevels == 0 . */ + iPtr->numLevels++; + Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); + + /* TODO: how to get re-resolution right */ + return TclNREvalObjv(interp, objc, objv, 0, cmdPtr); +} - Tcl_IncrRefCount(command); - cmdString = Tcl_GetStringFromObj(command, &length); - Tcl_LogCommandInfo(interp, cmdString, cmdString, length); - Tcl_DecrRefCount(command); - iPtr->flags &= ~ERR_ALREADY_LOGGED; - } +static int +NRPostInvoke( + ClientData clientData[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *)interp; + iPtr->numLevels--; return result; -#else - -#endif } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 1f939c0..70d6d02 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2739,6 +2739,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 1a4297b..ac51d9d 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -3052,7 +3052,12 @@ SlaveInvokeHidden( Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { - result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + if (interp == slaveInterp) { + Tcl_Release(slaveInterp); + return TclNRInvoke(NULL, slaveInterp, objc, objv); + } else { + result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + } } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; -- cgit v0.12 From 064f7e5513e1c51e2e1501e4ee4c223bd689de35 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Apr 2013 19:36:37 +0000 Subject: More revisions let multi-interp test case work, but at cost of panics and segfaults. Pushing the NRE-envelope. --- generic/tclInterp.c | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index ac51d9d..e9ed790 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -279,6 +279,7 @@ static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); +static Tcl_NRPostProc NRPostInvokeHidden; /* *---------------------------------------------------------------------- @@ -3056,7 +3057,9 @@ SlaveInvokeHidden( Tcl_Release(slaveInterp); return TclNRInvoke(NULL, slaveInterp, objc, objv); } else { - result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, + NULL, NULL, NULL); + return TclNRInvoke(NULL, slaveInterp, objc, objv); } } else { Namespace *nsPtr, *dummy1, *dummy2; @@ -3076,6 +3079,19 @@ SlaveInvokeHidden( Tcl_Release(slaveInterp); return result; } + +static int +NRPostInvokeHidden( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + + Tcl_TransferResult(slaveInterp, result, interp); + Tcl_Release(slaveInterp); + return result; +} /* *---------------------------------------------------------------------- -- cgit v0.12 From 64bf3c8f4ac71870000a6d8f4941d0db79972ef6 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Apr 2013 21:30:40 +0000 Subject: More progress. NR-enable [interp] and [$slave], completely with invokehidden subcommand. Test suite passes with no errors. --- generic/tclInterp.c | 51 +++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 39 insertions(+), 12 deletions(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index e9ed790..0da5d47 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -279,7 +279,12 @@ static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); + +/* NRE enabling */ static Tcl_NRPostProc NRPostInvokeHidden; +static Tcl_ObjCmdProc NRInterpCmd; +static Tcl_ObjCmdProc NRSlaveCmd; + /* *---------------------------------------------------------------------- @@ -482,7 +487,8 @@ TclInterpInit( slavePtr->interpCmd = NULL; Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL); + Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd, + NULL, NULL); Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); return TCL_OK; @@ -591,6 +597,16 @@ Tcl_InterpObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv); +} + +static int +NRInterpCmd( + ClientData clientData, /* Unused. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Interp *slaveInterp; int index; static const char *const options[] = { @@ -2373,8 +2389,8 @@ SlaveCreate( slavePtr->masterInterp = masterInterp; slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, - SlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc); + slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path, + SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, slavePtr); Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); @@ -2463,6 +2479,16 @@ SlaveObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv); +} + +static int +NRSlaveCmd( + ClientData clientData, /* Slave interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Interp *slaveInterp = clientData; int index; static const char *const options[] = { @@ -3053,14 +3079,11 @@ SlaveInvokeHidden( Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { - if (interp == slaveInterp) { - Tcl_Release(slaveInterp); - return TclNRInvoke(NULL, slaveInterp, objc, objv); - } else { - Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, - NULL, NULL, NULL); - return TclNRInvoke(NULL, slaveInterp, objc, objv); - } + NRE_callback *rootPtr = TOP_CB(slaveInterp); + + Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, + rootPtr, NULL, NULL); + return TclNRInvoke(NULL, slaveInterp, objc, objv); } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; @@ -3087,8 +3110,12 @@ NRPostInvokeHidden( int result) { Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + NRE_callback *rootPtr = (NRE_callback *)data[1]; - Tcl_TransferResult(slaveInterp, result, interp); + if (interp != slaveInterp) { + result = TclNRRunCallbacks(slaveInterp, result, rootPtr); + Tcl_TransferResult(slaveInterp, result, interp); + } Tcl_Release(slaveInterp); return result; } -- cgit v0.12 From 5684ad8d9463f7c23551d1fef32f69c3f72fdd27 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 15 Jul 2013 19:09:59 +0000 Subject: Possible improvement in light of [86ceb4e2b6]. --- library/tm.tcl | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/library/tm.tcl b/library/tm.tcl index d2af4f5..955e84d 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -238,6 +238,15 @@ proc ::tcl::tm::UnknownHandler {original name args} { continue } + if {[string length [package ifneeded $pkgname $pkgversion]]} { + # There's already a provide script registered for + # this version of this package. Since all units of + # code claiming to be the same version of the same + # package ought to be identical, just stick with + # the one we already have. + continue + } + # We have found a candidate, generate a "provide script" # for it, and remember it. Note that we are using ::list # to do this; locally [list] means something else without -- cgit v0.12 From a2400fbe30f602e19fbeb74a5c6df7fc0e220699 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 14 Aug 2013 17:02:41 +0000 Subject: [a16752c252] Correct failure to call cmd deletion callbacks. --- generic/tclBasic.c | 28 +++++----------------------- generic/tclTest.c | 6 +++--- tests/rename.test | 7 +++++++ 3 files changed, 15 insertions(+), 26 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 4f24515..8ab3acb 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1966,12 +1966,8 @@ Tcl_CreateCommand( * future calls to Tcl_GetCommandName. * * Side effects: - * If no command named "cmdName" already exists for interp, one is - * created. Otherwise, if a command does exist, then if the object-based - * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand - * was called previously for the same command and just set its - * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old - * command. + * If a command named "cmdName" already exists for interp, it is + * first deleted. Then the new command is created from the arguments. * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based @@ -2039,21 +2035,7 @@ Tcl_CreateObjCommand( cmdPtr = Tcl_GetHashValue(hPtr); /* - * Command already exists. If its object-based Tcl_ObjCmdProc is - * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the - * argument "proc". Otherwise, we delete the old command. - */ - - if (cmdPtr->objProc == TclInvokeStringCommand) { - cmdPtr->objProc = proc; - cmdPtr->objClientData = clientData; - cmdPtr->deleteProc = deleteProc; - cmdPtr->deleteData = clientData; - return (Tcl_Command) cmdPtr; - } - - /* - * Otherwise, we delete the old command. Be careful to preserve any + * Command already exists; delete it. Be careful to preserve any * existing import links so we can restore them down below. That way, * you can redefine a command and its import status will remain * intact. @@ -2188,8 +2170,8 @@ TclInvokeStringCommand( * A standard Tcl string result value. * * Side effects: - * Besides those side effects of the called Tcl_CmdProc, - * TclInvokeStringCommand allocates and frees storage. + * Besides those side effects of the called Tcl_ObjCmdProc, + * TclInvokeObjectCommand allocates and frees storage. * *---------------------------------------------------------------------- */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 9ef7805..5b51baa 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1545,14 +1545,14 @@ DelCallbackProc( * * TestdelCmd -- * - * This procedure implements the "testdcall" command. It is used - * to test Tcl_CallWhenDeleted. + * This procedure implements the "testdel" command. It is used + * to test calling of command deletion callbacks. * * Results: * A standard Tcl result. * * Side effects: - * Creates and deletes interpreters. + * Creates a command. * *---------------------------------------------------------------------- */ diff --git a/tests/rename.test b/tests/rename.test index bd14578..cd90b55 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -135,6 +135,13 @@ test rename-4.7 {reentrancy issues with command deletion and renaming} testdel { if {[info exists env(value)]} { unset env(value) } +test rename-4.8 {Bug a16752c252} testdel { + set x broken + testdel {} foo {set x ok} + proc foo args {} + rename foo {} + return -level 0 $x[unset x] +} ok # Save the unknown procedure which is modified by the following test. -- cgit v0.12 From 058f0df44de4f6b80f1df5494c14c4d592928768 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 14 Aug 2013 20:20:11 +0000 Subject: Add several tests to check consistency of stack traces. --- tests/interp.test | 14 ++++++++++ tests/safe.test | 80 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 94 insertions(+) diff --git a/tests/interp.test b/tests/interp.test index 0af9887..ad99fac 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -1599,6 +1599,20 @@ test interp-20.50 {Bug 2486550} -setup { } -cleanup { interp delete slave } -returnCodes error -match glob -result * +test interp-20.50.1 {Bug 2486550} -setup { + interp create slave +} -body { + slave hide coroutine + catch {slave invokehidden coroutine} m o + dict get $o -errorinfo +} -cleanup { + unset -nocomplain m 0 + interp delete slave +} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?" + while executing +"coroutine" + invoked from within +"slave invokehidden coroutine"} test interp-21.1 {interp hidden} { interp hidden {} diff --git a/tests/safe.test b/tests/safe.test index 4a2792e..859f352 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -425,6 +425,19 @@ test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i {load {} Safepkg1}} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure + invoked from within +"load {} Safepkg1" + invoked from within +"interp eval $i {load {} Safepkg1}"} test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body { set i [safe::interpCreate -nostatics] interp eval $i {load {} Safepkg1} @@ -444,6 +457,18 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints Tcl } -returnCodes error -cleanup { safe::interpDelete $i } -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { + set i [safe::interpCreate -nestedloadok] + catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure + invoked from within +"load {} Safepkg1 x" + invoked from within +"interp eval $i {interp create x; load {} Safepkg1 x}"} test safe-11.1 {testing safe encoding} -setup { set i [safe::interpCreate] @@ -501,6 +526,23 @@ test safe-11.7 {testing safe encoding} -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {wrong # args: should be "encoding convertfrom ?encoding? data"} +test safe-11.7.1 {testing safe encoding} -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i encoding convertfrom} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {wrong # args: should be "encoding convertfrom ?encoding? data" + while executing +"encoding convertfrom" + invoked from within +"::interp invokehidden interp1 encoding convertfrom" + invoked from within +"encoding convertfrom" + invoked from within +"interp eval $i encoding convertfrom"} test safe-11.8 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -508,6 +550,23 @@ test safe-11.8 {testing safe encoding} -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {wrong # args: should be "encoding convertto ?encoding? data"} +test safe-11.8.1 {testing safe encoding} -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i encoding convertto} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {wrong # args: should be "encoding convertto ?encoding? data" + while executing +"encoding convertto" + invoked from within +"::interp invokehidden interp1 encoding convertto" + invoked from within +"encoding convertto" + invoked from within +"interp eval $i encoding convertto"} test safe-12.1 {glob is restricted [Bug 2906841]} -setup { set i [safe::interpCreate] @@ -715,8 +774,29 @@ test safe-15.1 {safe file ensemble does not surprise code} -setup { lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg } -cleanup { + unset -nocomplain msg interp delete $i } -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}} +test safe-15.1.1 {safe file ensemble does not surprise code} -setup { + set i [interp create -safe] +} -body { + set result [expr {"file" in [interp hidden $i]}] + lappend result [interp eval $i {tcl::file::split a/b/c}] + lappend result [catch {interp eval $i {tcl::file::isdirectory .}}] + lappend result [interp invokehidden $i file split a/b/c] + lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg + lappend result [catch {interp invokehidden $i file isdirectory .}] + interp expose $i file + lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg + lappend result [catch {interp eval $i {file isdirectory .}} msg o] [dict get $o -errorinfo] +} -cleanup { + unset -nocomplain msg o + interp delete $i +} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file + while executing +"file isdirectory ." + invoked from within +"interp eval $i {file isdirectory .}"}} ### ~ should have no special meaning in paths in safe interpreters test safe-16.1 {Bug 3529949: defang ~ in paths} -setup { -- cgit v0.12 From fe60431f5338aefb240b653c800fdcfe6c720706 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 15 Aug 2013 14:05:02 +0000 Subject: The fix for [3610404] leads to a simplification in the implementation of forward methods. --- generic/tclOOInt.h | 6 ------ generic/tclOOMethod.c | 13 +------------ 2 files changed, 1 insertion(+), 18 deletions(-) diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index ab54964..c0e4022 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -122,12 +122,6 @@ typedef struct ForwardMethod { Tcl_Obj *prefixObj; /* The list of values to use to replace the * object and method name with. Will be a * non-empty list. */ - int fullyQualified; /* If 1, the command name is fully qualified - * and we should let the default Tcl mechanism - * handle the command lookup because it is - * more efficient. If 0, we need to do a - * specialized lookup based on the current - * object's namespace. */ } ForwardMethod; /* diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 0799082..f9f980a 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1338,7 +1338,6 @@ TclOONewForwardInstanceMethod( fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); - fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0); Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags, &fwdMethodType, fmPtr); @@ -1380,7 +1379,6 @@ TclOONewForwardMethod( fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); - fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0); Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, &fwdMethodType, fmPtr); @@ -1409,7 +1407,6 @@ InvokeForwardMethod( ForwardMethod *fmPtr = clientData; Tcl_Obj **argObjs, **prefixObjs; int numPrefixes, len, skip = contextPtr->skip; - Command *cmdPtr; /* * Build the real list of arguments to use. Note that we know that the @@ -1421,17 +1418,10 @@ InvokeForwardMethod( Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs); argObjs = InitEnsembleRewrite(interp, objc, objv, skip, numPrefixes, prefixObjs, &len); - - if (fmPtr->fullyQualified) { - cmdPtr = NULL; - } else { - cmdPtr = (Command *) Tcl_FindCommand(interp, TclGetString(argObjs[0]), - contextPtr->oPtr->namespacePtr, 0 /* normal lookup */); - } Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); ((Interp *)interp)->lookupNsPtr = (Namespace *) contextPtr->oPtr->namespacePtr; - return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, cmdPtr); + return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, NULL); } static int @@ -1476,7 +1466,6 @@ CloneForwardMethod( ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod)); fm2Ptr->prefixObj = fmPtr->prefixObj; - fm2Ptr->fullyQualified = fmPtr->fullyQualified; Tcl_IncrRefCount(fm2Ptr->prefixObj); *newClientData = fm2Ptr; return TCL_OK; -- cgit v0.12 From 5cdaf0e05bd402111776b93b830743a9746ad571 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 15 Aug 2013 19:55:26 +0000 Subject: Make sure the errors raised by execution traces become errors raised by the traced command, as documented. Deletion of the traced command was supressing that. --- generic/tclBasic.c | 2 +- tests/trace.test | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 8ab3acb..314b5fc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3642,7 +3642,7 @@ TclEvalObjvInternal( * implementation. */ - if (cmdEpoch != newEpoch) { + if (traceCode == TCL_OK && cmdEpoch != newEpoch) { checkTraces = 0; if (commandPtr) { Tcl_DecrRefCount(commandPtr); diff --git a/tests/trace.test b/tests/trace.test index 24279f5..9c01908 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -2658,6 +2658,13 @@ test trace-39.1 {bug #3485022: tracing Bc'ed commands} -setup { rename dotrace {} rename foo {} } -result {3 | 0 1 1} + +test trace-40.1 {execution trace errors become command errors} { + proc foo args {} + trace add execution foo enter {rename foo {}; error bar;#} + catch foo m + return -level 0 $m[unset m] +} bar # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). -- cgit v0.12 From a6f2dee7fbd4c79aabb8e7533d20d042eb7062c1 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 19 Aug 2013 15:22:15 +0000 Subject: Testing doing away with the NRRunObjProc routine, which looks like a useless extra bounce on the NRE trampoline. Normal testing has no problem with it, but debug-enabled testing triggers an assert failure. Either it would be good to have a normal test that fails in the conditions of the assert failure, or it would be good to discover the assert is asserting something not actually required, and then make the purge. --- generic/tclBasic.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 4a95340..020f2f2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -133,7 +133,9 @@ static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); +#if 0 static Tcl_NRPostProc NRRunObjProc; +#endif static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); static void ProcessUnexpectedResult(Tcl_Interp *interp, @@ -4238,9 +4240,13 @@ TclNREvalObjv( */ if (cmdPtr->nreProc) { +#if 0 TclNRAddCallback(interp, NRRunObjProc, cmdPtr, INT2PTR(objc), (ClientData) objv, NULL); return TCL_OK; +#else + return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); +#endif } else { return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); } @@ -4323,6 +4329,7 @@ NRCommand( return result; } +#if 0 static int NRRunObjProc( ClientData data[], @@ -4337,6 +4344,7 @@ NRRunObjProc( return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); } +#endif /* -- cgit v0.12 From 066a4b7b358ee4c7da44938fa7abc24285fe966e Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 19 Aug 2013 16:34:10 +0000 Subject: Revise execution trace handling to take account of the new reality in Tcl 8.6 that callers can pre-resolve a cmdPtr for us. In that case a re-resolution in the form of another command name lookup isn't the right thing. --- generic/tclBasic.c | 51 +++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 37 insertions(+), 14 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 64563ee..8ac5781 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -148,7 +148,8 @@ static int TEOV_NotFound(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static int TEOV_RunEnterTraces(Tcl_Interp *interp, Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], Namespace *lookupNsPtr); + Tcl_Obj *const objv[], Namespace *lookupNsPtr, + int weLookUp); static Tcl_NRPostProc RewindCoroutineCallback; static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; @@ -4098,6 +4099,7 @@ TclNREvalObjv( Namespace *lookupNsPtr = iPtr->lookupNsPtr; Command **cmdPtrPtr; NRE_callback *callbackPtr; + int weLookUp = (cmdPtr == NULL); iPtr->lookupNsPtr = NULL; @@ -4136,7 +4138,7 @@ TclNREvalObjv( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } - if (cmdPtr) { + if (!weLookUp) { goto commandFound; } @@ -4188,12 +4190,16 @@ TclNREvalObjv( result = TEOV_RunEnterTraces(interp, &cmdPtr, TclGetSourceFromFrame( flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, - objc, objv), objc, objv, lookupNsPtr); + objc, objv), objc, objv, lookupNsPtr, weLookUp); if (result != TCL_OK) { return result; } - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + if (cmdPtr == NULL) { + if (weLookUp) { + return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + } + /* Is this right??? */ + return TCL_OK; } } @@ -4605,7 +4611,8 @@ TEOV_RunEnterTraces( Tcl_Obj *commandPtr, int objc, Tcl_Obj *const objv[], - Namespace *lookupNsPtr) + Namespace *lookupNsPtr, + int weLookUp) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; @@ -4613,7 +4620,7 @@ TEOV_RunEnterTraces( int cmdEpoch = cmdPtr->cmdEpoch; int newEpoch; const char *command; - int length; + int length, deleted; Tcl_IncrRefCount(commandPtr); command = Tcl_GetStringFromObj(commandPtr, &length); @@ -4635,16 +4642,32 @@ TEOV_RunEnterTraces( cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); } newEpoch = cmdPtr->cmdEpoch; + deleted = cmdPtr->flags & CMD_IS_DELETED; TclCleanupCommandMacro(cmdPtr); - /* - * If the traces modified/deleted the command or any existing traces, they - * will update the command's epoch. We need to lookup again, but do not - * run enter traces on the newly found cmdPtr. - */ - if (cmdEpoch != newEpoch) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + + /* + * The traces did something to the traced command. How should + * we respond? + * + * If we got the trace command by looking up a command name, we + * should just look it up again. + */ + if (weLookUp) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + } else { + + /* + * If we did not look up a command name, we got the cmdPtr + * from a caller. If that cmdPtr has been deleted, we need + * to avoid a crash. Otherwise, press on. We don't have + * any foundation to claim a better answer. + */ + if (deleted) { + cmdPtr = NULL; + } + } *cmdPtrPtr = cmdPtr; } -- cgit v0.12 From 4bf79aef9b62990cea9c4069d86c25a45790f096 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 20 Aug 2013 14:00:05 +0000 Subject: Push out a trial patch for more eyes to see. --- generic/tclBasic.c | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 020f2f2..ca49bec 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -161,6 +161,8 @@ static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; +static Tcl_NRPostProc Dispatch; + static Tcl_ObjCmdProc NRCoroInjectObjCmd; MODULE_SCOPE const TclStubs tclStubs; @@ -4234,6 +4236,9 @@ TclNREvalObjv( *cmdPtrPtr = cmdPtr; cmdPtr->refCount++; + TclNRAddCallback(interp, Dispatch, cmdPtr, INT2PTR(objc), objv, NULL); + return TCL_OK; + /* * Find the objProc to call: nreProc if available, objProc otherwise. Push * a callback to do the actual running. @@ -4252,6 +4257,23 @@ TclNREvalObjv( } } +static int +Dispatch( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Command *cmdPtr = data[0]; + int objc = PTR2INT(data[1]); + Tcl_Obj **objv = data[2]; + + if (cmdPtr->nreProc) { + return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); + } else { + return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); + } +} + int TclNRRunCallbacks( Tcl_Interp *interp, -- cgit v0.12 From 6b6685b8fd3a03752470571d3ecf2e1f66965ba5 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 21 Aug 2013 09:35:50 +0000 Subject: define tests for this bug; no fix yet --- tests/oo.test | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/tests/oo.test b/tests/oo.test index e0e0791..054bc46 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1839,6 +1839,36 @@ test oo-15.9 {ensemble rewriting must not bleed through oo::copy} -setup { } -returnCodes error -cleanup { Foo destroy } -result {wrong # args: should be "::bar a b"} +test oo-15.10 {variable binding must not bleed through oo::copy} -setup { + oo::class create FooClass + set result {} +} -body { + set obj1 [FooClass new] + oo::objdefine $obj1 { + variable var + method m {} { + set var foo + } + method get {} { + return $var + } + export eval + } + + $obj1 m + lappend result [$obj1 get] + set obj2 [oo::copy $obj1] + $obj2 eval { + set var bar + } + lappend result [$obj2 get] + $obj1 eval { + set var grill + } + lappend result [$obj1 get] [$obj2 get] +} -cleanup { + FooClass destroy +} -result {foo bar grill bar} test oo-16.1 {OO: object introspection} -body { info object -- cgit v0.12 From 4d6aaa2e8b970c7babd8047939266ccc21084c7e Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 21 Aug 2013 10:25:18 +0000 Subject: [3612422]: Refer to correct part of tclvars(n) rather than page itself. --- doc/AddErrInfo.3 | 12 ++++++------ doc/CrtInterp.3 | 7 ++++--- doc/Environment.3 | 2 +- doc/bgerror.n | 5 ++++- doc/binary.n | 2 +- doc/catch.n | 3 ++- doc/eval.n | 3 ++- doc/info.n | 12 ++++++------ doc/library.n | 10 +++++++--- doc/return.n | 4 ++-- doc/tclsh.1 | 8 +++++--- doc/throw.n | 2 +- 12 files changed, 41 insertions(+), 29 deletions(-) diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3 index b9c6a63..36f6a20 100644 --- a/doc/AddErrInfo.3 +++ b/doc/AddErrInfo.3 @@ -176,16 +176,16 @@ these return options. The \fB\-errorinfo\fR option holds a stack trace of the operations that were in progress when an error occurred, and is intended to be human-readable. -The \fB\-errorcode\fR option holds a list of items that +The \fB\-errorcode\fR option holds a Tcl list of items that are intended to be machine-readable. The first item in the \fB\-errorcode\fR value identifies the class of error that occurred -(e.g. POSIX means an error occurred in a POSIX system call) +(e.g., POSIX means an error occurred in a POSIX system call) and additional elements hold additional pieces of information that depend on the class. -See the \fBtclvars\fR manual entry for details on the various -formats for the \fB\-errorcode\fR option used by -Tcl's built-in commands. +See the manual entry on the \fBerrorCode\fR variable for details on the +various formats for the \fB\-errorcode\fR option used by Tcl's built-in +commands. .PP The \fB\-errorinfo\fR option value is gradually built up as an error unwinds through the nested operations. @@ -307,6 +307,6 @@ so they continue to hold a record of information about the most recent error seen in an interpreter. .SH "SEE ALSO" Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_Interp(3), Tcl_ResetResult(3), -Tcl_SetErrno(3), tclvars(n) +Tcl_SetErrno(3), errorCode(n), errorInfo(n) .SH KEYWORDS error, value, value result, stack, trace, variable diff --git a/doc/CrtInterp.3 b/doc/CrtInterp.3 index a248cf4..1156a20 100644 --- a/doc/CrtInterp.3 +++ b/doc/CrtInterp.3 @@ -41,8 +41,9 @@ may only be passed to Tcl routines called from the same thread as the original \fBTcl_CreateInterp\fR call. It is not safe for multiple threads to pass the same token to Tcl's routines. The new interpreter is initialized with the built-in Tcl commands -and with the variables documented in the \fBtclvars\fR manual page. To bind in -additional commands, call \fBTcl_CreateCommand\fR. +and with standard variables like \fBtcl_platform\fR and \fBenv\fR. To +bind in additional commands, call \fBTcl_CreateCommand\fR, and to +create additional variables, call \fBTcl_SetVar\fR. .PP \fBTcl_DeleteInterp\fR marks an interpreter as deleted; the interpreter will eventually be deleted when all calls to \fBTcl_Preserve\fR for it have @@ -144,6 +145,6 @@ should be used to determine when an interpreter is a candidate for deletion due to inactivity. .VE 8.6 .SH "SEE ALSO" -Tcl_Preserve(3), Tcl_Release(3), tclvars(n) +Tcl_Preserve(3), Tcl_Release(3) .SH KEYWORDS command, create, delete, interpreter diff --git a/doc/Environment.3 b/doc/Environment.3 index 3753f43..46262ab 100644 --- a/doc/Environment.3 +++ b/doc/Environment.3 @@ -33,6 +33,6 @@ Tcl-based applications using \fBputenv\fR should redefine it to \fBTcl_PutEnv\fR so that they will interface properly to the Tcl runtime. .SH "SEE ALSO" -tclvars(n) +env(n) .SH KEYWORDS environment, variable diff --git a/doc/bgerror.n b/doc/bgerror.n index ac53eca..16a23a3 100644 --- a/doc/bgerror.n +++ b/doc/bgerror.n @@ -85,6 +85,9 @@ proc bgerror {message} { } .CE .SH "SEE ALSO" -after(n), interp(n), tclvars(n) +after(n), errorCode(n), errorInfo(n), interp(n) .SH KEYWORDS background error, reporting +'\" Local Variables: +'\" mode: nroff +'\" End: diff --git a/doc/binary.n b/doc/binary.n index 68bf9cc..a40afe6 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -884,7 +884,7 @@ close $f puts [\fBbinary encode\fR base64 \-maxlen 64 $data] .CE .SH "SEE ALSO" -format(n), scan(n), tclvars(n) +format(n), scan(n), tcl_platform(n) .SH KEYWORDS binary, format, scan '\" Local Variables: diff --git a/doc/catch.n b/doc/catch.n index a05ca71..9597ccf 100644 --- a/doc/catch.n +++ b/doc/catch.n @@ -115,7 +115,8 @@ if { [\fBcatch\fR {open $someFile w} fid] } { There are more complex examples of \fBcatch\fR usage in the documentation for the \fBreturn\fR command. .SH "SEE ALSO" -break(n), continue(n), dict(n), error(n), info(n), return(n), tclvars(n) +break(n), continue(n), dict(n), error(n), errorCode(n), errorInfo(n), info(n), +return(n) .SH KEYWORDS catch, error, exception '\" Local Variables: diff --git a/doc/eval.n b/doc/eval.n index da88757..13b54be 100644 --- a/doc/eval.n +++ b/doc/eval.n @@ -75,7 +75,8 @@ However, the last line would now normally be written without set var [linsert $var 0 {*}$args] .CE .SH "SEE ALSO" -catch(n), concat(n), error(n), interp(n), list(n), namespace(n), subst(n), tclvars(n), uplevel(n) +catch(n), concat(n), error(n), errorCode(n), errorInfo(n), interp(n), list(n), +namespace(n), subst(n), uplevel(n) .SH KEYWORDS concatenate, evaluate, script '\" Local Variables: diff --git a/doc/info.n b/doc/info.n index e65a083..14a9e50 100644 --- a/doc/info.n +++ b/doc/info.n @@ -296,7 +296,6 @@ Returns the name of the library directory in which standard Tcl scripts are stored. This is actually the value of the \fBtcl_library\fR variable and may be changed by setting \fBtcl_library\fR. -See the \fBtclvars\fR manual entry for more information. .TP \fBinfo loaded \fR?\fIinterp\fR? . @@ -336,8 +335,8 @@ described in \fBOBJECT INTROSPECTION\fR below. .TP \fBinfo patchlevel\fR . -Returns the value of the global variable \fBtcl_patchLevel\fR; see -the \fBtclvars\fR manual entry for more information. +Returns the value of the global variable \fBtcl_patchLevel\fR, which holds +the exact version of the Tcl library by default. .TP \fBinfo procs \fR?\fIpattern\fR? . @@ -374,8 +373,8 @@ string is returned. .TP \fBinfo tclversion\fR . -Returns the value of the global variable \fBtcl_version\fR; see -the \fBtclvars\fR manual entry for more information. +Returns the value of the global variable \fBtcl_version\fR, which holds the +major and minor version of the Tcl library by default. .TP \fBinfo vars\fR ?\fIpattern\fR? . @@ -763,8 +762,9 @@ proc getDef {obj method} { .VE 8.6 .SH "SEE ALSO" .VS 8.6 -global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n) +global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n), .VE 8.6 +tcl_library(n), tcl_patchLevel(n), tcl_version(n) .SH KEYWORDS command, information, interpreter, introspection, level, namespace, .VS 8.6 diff --git a/doc/library.n b/doc/library.n index 2413692..98dcb35 100644 --- a/doc/library.n +++ b/doc/library.n @@ -262,13 +262,17 @@ If set to any value, then \fBunknown\fR will not attempt to auto-load any commands. .TP \fBauto_path\fR +. If set, then it must contain a valid Tcl list giving directories to -search during auto-load operations. +search during auto-load operations (including for package index +files when using the default \fBpackage unknown\fR handler). This variable is initialized during startup to contain, in order: the directories listed in the \fBTCLLIBPATH\fR environment variable, -the directory named by the \fBtcl_library\fR variable, +the directory named by the \fBtcl_library\fR global variable, the parent directory of \fBtcl_library\fR, the directories listed in the \fBtcl_pkgPath\fR variable. +Additional locations to look for files and package indices should +normally be added to this variable using \fBlappend\fR. .TP \fBenv(TCL_LIBRARY)\fR If set, then it specifies the location of the directory containing @@ -306,7 +310,7 @@ considered to be a word character. On Windows platforms, words are comprised of any character that is not a space, tab, or newline. Under Unix, words are comprised of numbers, letters or underscores. .SH "SEE ALSO" -info(n), re_syntax(n), tclvars(n) +env(n), info(n), re_syntax(n) .SH KEYWORDS auto-exec, auto-load, library, unknown, word, whitespace '\"Local Variables: diff --git a/doc/return.n b/doc/return.n index b59a93d..a1abccf 100644 --- a/doc/return.n +++ b/doc/return.n @@ -317,8 +317,8 @@ proc myReturn {args} { } .CE .SH "SEE ALSO" -break(n), catch(n), continue(n), dict(n), error(n), proc(n), -source(n), tclvars(n), throw(n), try(n) +break(n), catch(n), continue(n), dict(n), error(n), errorCode(n), +errorInfo(n), proc(n), source(n), throw(n), try(n) .SH KEYWORDS break, catch, continue, error, exception, procedure, result, return .\" Local Variables: diff --git a/doc/tclsh.1 b/doc/tclsh.1 index 8e7fb9e..dfc2635 100644 --- a/doc/tclsh.1 +++ b/doc/tclsh.1 @@ -102,7 +102,9 @@ but also the disadvantage of making it harder to write scripts that start up uniformly across different versions of Tcl. .SH "VARIABLES" .PP -\fBTclsh\fR sets the following Tcl variables: +\fBTclsh\fR sets the following global Tcl variables in addition to those +created by the Tcl library itself (such as \fBenv\fR, which maps +environment variables such as \fBPATH\fR into Tcl): .TP 15 \fBargc\fR . @@ -129,7 +131,7 @@ device), 0 otherwise. When \fBtclsh\fR is invoked interactively it normally prompts for each command with .QW "\fB% \fR" . -You can change the prompt by setting the +You can change the prompt by setting the global variables \fBtcl_prompt1\fR and \fBtcl_prompt2\fR. If variable \fBtcl_prompt1\fR exists then it must consist of a Tcl script to output a prompt; instead of outputting a prompt \fBtclsh\fR @@ -142,6 +144,6 @@ incomplete commands. .PP See \fBTcl_StandardChannels\fR for more explanations. .SH "SEE ALSO" -encoding(n), fconfigure(n), tclvars(n) +auto_path(n), encoding(n), env(n), fconfigure(n) .SH KEYWORDS application, argument, interpreter, prompt, script file, shell diff --git a/doc/throw.n b/doc/throw.n index d49fb24..b28f2e4 100644 --- a/doc/throw.n +++ b/doc/throw.n @@ -40,7 +40,7 @@ The following produces an error that is identical to that produced by \fBthrow\fR {ARITH DIVZERO {divide by zero}} {divide by zero} .CE .SH "SEE ALSO" -catch(n), error(n), return(n), tclvars(n), try(n) +catch(n), error(n), errorCode(n), errorInfo(n), return(n), try(n) .SH "KEYWORDS" error, exception '\" Local Variables: -- cgit v0.12 From f18c1126d55725786c4ba524c310c989adbe15c5 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Aug 2013 18:27:23 +0000 Subject: Don't use automatic storage to hold the invocation words of oo::define. That practice doesn't agree with NRE execution. --- generic/tclOOBasic.c | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index f8cd1a4..073abab 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -88,7 +88,7 @@ TclOO_Class_Constructor( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - Tcl_Obj *invoke[3]; + Tcl_Obj **invoke = ckalloc(3 * sizeof(Tcl_Obj *)); if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -115,7 +115,7 @@ TclOO_Class_Constructor( Tcl_IncrRefCount(invoke[1]); Tcl_IncrRefCount(invoke[2]); TclNRAddCallback(interp, DecrRefsPostClassConstructor, - invoke[0], invoke[1], invoke[2], NULL); + invoke, NULL, NULL, NULL); /* * Tricky point: do not want the extra reported level in the Tcl stack @@ -131,9 +131,12 @@ DecrRefsPostClassConstructor( Tcl_Interp *interp, int result) { - TclDecrRefCount((Tcl_Obj *) data[0]); - TclDecrRefCount((Tcl_Obj *) data[1]); - TclDecrRefCount((Tcl_Obj *) data[2]); + Tcl_Obj **invoke = data[0]; + + TclDecrRefCount(invoke[0]); + TclDecrRefCount(invoke[1]); + TclDecrRefCount(invoke[2]); + ckfree(invoke); return result; } -- cgit v0.12 From 83d427e824792fee386b4dc5699858922a3cc3c2 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Aug 2013 19:00:17 +0000 Subject: Don't allocate memory until you know you're going to use it and arrange for it to be freed. Leak! --- generic/tclOOBasic.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 073abab..aba06a5 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -88,7 +88,7 @@ TclOO_Class_Constructor( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - Tcl_Obj **invoke = ckalloc(3 * sizeof(Tcl_Obj *)); + Tcl_Obj **invoke; if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -102,6 +102,7 @@ TclOO_Class_Constructor( * Delegate to [oo::define] to do the work. */ + invoke = ckalloc(3 * sizeof(Tcl_Obj *)); invoke[0] = oPtr->fPtr->defineName; invoke[1] = TclOOObjectName(interp, oPtr); invoke[2] = objv[objc-1]; -- cgit v0.12 From ed72e77b7de9b2427769b37d8f669b1f05d9ee42 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Aug 2013 19:18:28 +0000 Subject: Tidy the code and add a test. --- generic/tclBasic.c | 39 --------------------------------------- tests/coroutine.test | 9 +++++++++ 2 files changed, 9 insertions(+), 39 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index ca49bec..c1032f9 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -133,9 +133,6 @@ static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); -#if 0 -static Tcl_NRPostProc NRRunObjProc; -#endif static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); static void ProcessUnexpectedResult(Tcl_Interp *interp, @@ -160,7 +157,6 @@ static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; - static Tcl_NRPostProc Dispatch; static Tcl_ObjCmdProc NRCoroInjectObjCmd; @@ -4238,23 +4234,6 @@ TclNREvalObjv( TclNRAddCallback(interp, Dispatch, cmdPtr, INT2PTR(objc), objv, NULL); return TCL_OK; - - /* - * Find the objProc to call: nreProc if available, objProc otherwise. Push - * a callback to do the actual running. - */ - - if (cmdPtr->nreProc) { -#if 0 - TclNRAddCallback(interp, NRRunObjProc, cmdPtr, - INT2PTR(objc), (ClientData) objv, NULL); - return TCL_OK; -#else - return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); -#endif - } else { - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } } static int @@ -4350,24 +4329,6 @@ NRCommand( return result; } - -#if 0 -static int -NRRunObjProc( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - /* OPT: do not call? */ - - Command* cmdPtr = data[0]; - int objc = PTR2INT(data[1]); - Tcl_Obj **objv = data[2]; - - return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); -} -#endif - /* *---------------------------------------------------------------------- diff --git a/tests/coroutine.test b/tests/coroutine.test index 1d9040b..faa5a42 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -609,6 +609,15 @@ test coroutine-7.3 {yielding between coroutines} -body { } -cleanup { catch {rename juggler ""} } -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}} + +test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { + proc foo {a b} {catch yield; return 1} +} -cleanup { + rename foo {} +} -body { + coroutine demo lsort -command foo {a b} +} -result {b a} + # cleanup unset lambda -- cgit v0.12 From 52b97dd00b18638dfeb1fea5dcc028759127b714 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 22 Aug 2013 08:07:33 +0000 Subject: Correction to documentation --- doc/Method.3 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/doc/Method.3 b/doc/Method.3 index 43b3609..2537d5e 100644 --- a/doc/Method.3 +++ b/doc/Method.3 @@ -172,8 +172,9 @@ typedef struct { .PP The \fIversion\fR field allows for future expansion of the structure, and should always be declared equal to TCL_OO_METHOD_VERSION_CURRENT. The -\fIname\fR field provides a human-readable name for the type, and is reserved -for debugging. +\fIname\fR field provides a human-readable name for the type, and is the value +that is exposed via the \fBinfo class methodtype\fR and +\fBinfo object methodtype\fR Tcl commands. .PP The \fIcallProc\fR field gives a function that is called when the method is invoked; it must never be NULL. -- cgit v0.12 From a5b75dfa9a6ddadcf9f6a864bc47a1b5e69daed5 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Aug 2013 13:01:31 +0000 Subject: More coroutine tests. --- tests/coroutine.test | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/tests/coroutine.test b/tests/coroutine.test index faa5a42..8a7fdf3 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -618,6 +618,21 @@ test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { coroutine demo lsort -command foo {a b} } -result {b a} +test coroutine-7.5 {return codes} { + set result {} + foreach code {0 1 2 3 4 5} { + lappend result [catch {coroutine demo return -level 0 -code $code}] + } + set result +} {0 1 2 3 4 5} + +test coroutine-7.6 {Early yield crashes} { + proc foo args {} + trace add execution foo enter {catch yield} + coroutine demo foo + rename foo {} +} {} + # cleanup unset lambda -- cgit v0.12 From 8173bccfd9b158ecd9f10dd7d9978a2b287fdcfe Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Aug 2013 16:13:29 +0000 Subject: Remove assertion that is not true in some circumstances (--enable-dtrace). --- generic/tclExecute.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d066476..96004e2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -8798,8 +8798,7 @@ TclGetSrcInfoForPc( &cfPtr->len, NULL, NULL); } - assert(cfPtr->cmd != NULL); - { + if (cfPtr->cmd != NULL) { /* * We now have the command. We can get the srcOffset back and from * there find the list of word locations for this command. -- cgit v0.12 From f7cf1b2bae1b15e6c6002405dbff659d2e8ac384 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Aug 2013 20:21:15 +0000 Subject: Make Dispatch() the single point for calling a Tcl_ObjCmdProc, and attach the DTRACE machinery there (one place, not two). --- generic/tclBasic.c | 91 +++++++++++++++++++----------------------------------- 1 file changed, 32 insertions(+), 59 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c1032f9..5371f31 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4196,6 +4196,31 @@ TclNREvalObjv( } } + /* + * Fix the original callback to point to the now known cmdPtr. Insure that + * the Command struct lives until the command returns. + */ + + *cmdPtrPtr = cmdPtr; + cmdPtr->refCount++; + + TclNRAddCallback(interp, Dispatch, + cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, + cmdPtr->objClientData, INT2PTR(objc), objv); + return TCL_OK; +} + +static int +Dispatch( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_ObjCmdProc *objProc = data[0]; + ClientData clientData = data[1]; + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; #ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { @@ -4216,41 +4241,17 @@ TclNREvalObjv( TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); TclDecrRefCount(info); } - if (TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) { + if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) + && objc) { TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); } - if (TCL_DTRACE_CMD_ENTRY_ENABLED()) { + if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, (Tcl_Obj **)(objv + 1)); } #endif /* USE_DTRACE */ - /* - * Fix the original callback to point to the now known cmdPtr. Insure that - * the Command struct lives until the command returns. - */ - - *cmdPtrPtr = cmdPtr; - cmdPtr->refCount++; - - TclNRAddCallback(interp, Dispatch, cmdPtr, INT2PTR(objc), objv, NULL); - return TCL_OK; -} - -static int -Dispatch( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Command *cmdPtr = data[0]; - int objc = PTR2INT(data[1]); - Tcl_Obj **objv = data[2]; - if (cmdPtr->nreProc) { - return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); - } else { - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } + return objProc(clientData, interp, objc, objv); } int @@ -7981,39 +7982,11 @@ Tcl_NRCallObjProc( int objc, Tcl_Obj *const objv[]) { - int result = TCL_OK; NRE_callback *rootPtr = TOP_CB(interp); -#ifdef USE_DTRACE - if (TCL_DTRACE_CMD_ARGS_ENABLED()) { - const char *a[10]; - int i = 0; - - while (i < 10) { - a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; - } - TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], - a[8], a[9]); - } - if (TCL_DTRACE_CMD_INFO_ENABLED() && ((Interp *) interp)->cmdFramePtr) { - Tcl_Obj *info = TclInfoFrame(interp, ((Interp *) interp)->cmdFramePtr); - const char *a[6]; int i[2]; - - TclDTraceInfo(info, a, i); - TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); - TclDecrRefCount(info); - } - if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) - && objc) { - TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); - } - if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { - TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, - (Tcl_Obj **)(objv + 1)); - } -#endif /* USE_DTRACE */ - result = objProc(clientData, interp, objc, objv); - return TclNRRunCallbacks(interp, result, rootPtr); + TclNRAddCallback(interp, Dispatch, objProc, clientData, + INT2PTR(objc), objv); + return TclNRRunCallbacks(interp, TCL_OK, rootPtr); } /* -- cgit v0.12 From 272b2008ad7da7b6bd2c559142d78d06f0030a67 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Aug 2013 20:34:30 +0000 Subject: compiler warning --- generic/tclBasic.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5371f31..fc449cc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4220,9 +4220,9 @@ Dispatch( ClientData clientData = data[1]; int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; +#ifdef USE_DTRACE Interp *iPtr = (Interp *) interp; -#ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { const char *a[10]; int i = 0; -- cgit v0.12 From 55b0c170677b1848194ee9ebf1806ff60ad9589a Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 23 Aug 2013 05:59:48 +0000 Subject: Remove complications that no longer server any required purpose. --- generic/tclBasic.c | 20 +------------------- 1 file changed, 1 insertion(+), 19 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index fc449cc..4d56f3a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4095,8 +4095,6 @@ TclNREvalObjv( Interp *iPtr = (Interp *) interp; int result; Namespace *lookupNsPtr = iPtr->lookupNsPtr; - Command **cmdPtrPtr; - NRE_callback *callbackPtr; iPtr->lookupNsPtr = NULL; @@ -4111,13 +4109,10 @@ TclNREvalObjv( */ if (iPtr->deferredCallbacks) { - callbackPtr = iPtr->deferredCallbacks; iPtr->deferredCallbacks = NULL; } else { TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); - callbackPtr = TOP_CB(interp); } - cmdPtrPtr = (Command **) &(callbackPtr->data[0]); iPtr->numLevels++; result = TclInterpReady(interp); @@ -4196,14 +4191,6 @@ TclNREvalObjv( } } - /* - * Fix the original callback to point to the now known cmdPtr. Insure that - * the Command struct lives until the command returns. - */ - - *cmdPtrPtr = cmdPtr; - cmdPtr->refCount++; - TclNRAddCallback(interp, Dispatch, cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, cmdPtr->objClientData, INT2PTR(objc), objv); @@ -4297,13 +4284,8 @@ NRCommand( int result) { Interp *iPtr = (Interp *) interp; - Command *cmdPtr = data[0]; - /* int cmdStart = PTR2INT(data[1]); NOT USED HERE */ - if (cmdPtr) { - TclCleanupCommandMacro(cmdPtr); - } - ((Interp *)interp)->numLevels--; + iPtr->numLevels--; /* * If there is a tailcall, schedule it -- cgit v0.12 From f36f801d244571eecd337bd8cbaeb33609da2630 Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 23 Aug 2013 13:08:15 +0000 Subject: fix NRE docs --- doc/NRE.3 | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/doc/NRE.3 b/doc/NRE.3 index 7ebeb39..a27a359 100644 --- a/doc/NRE.3 +++ b/doc/NRE.3 @@ -8,7 +8,8 @@ .TH NRE 3 8.6 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. +Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, +Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. .SH SYNOPSIS .nf \fB#include \fR @@ -207,7 +208,7 @@ is something like: .PP .CS int -\fITheCmdObjProc\fR( +\fITheCmdOldObjProc\fR( ClientData clientData, Tcl_Interp *interp, int objc, @@ -225,7 +226,7 @@ int return result; } \fBTcl_CreateObjCommand\fR(interp, "theCommand", - \fITheCmdObjProc\fR, clientData, TheCmdDeleteProc); + \fITheCmdOldObjProc\fR, clientData, TheCmdDeleteProc); .CE .PP To enable a command like this one for trampoline-based evaluation, @@ -255,8 +256,8 @@ int int objc, Tcl_Obj *const objv[]) { - return \fBTcl_NRCallObjProc\fR(interp, name, - \fITheCmdNRObjProc\fR, clientData, objc, objv); + return \fBTcl_NRCallObjProc\fR(interp, \fITheCmdNRObjProc\fR, + clientData, objc, objv); } .CE .PP @@ -317,7 +318,7 @@ and the second is for use when there is already a trampoline in place. .PP .CS \fBTcl_NRCreateCommand\fR(interp, "theCommand", - \fITheCmdObjProc\fR, \fITheCmdNRObjProc\fR, clientData, + \fITheCmdNewObjProc\fR, \fITheCmdNRObjProc\fR, clientData, TheCmdDeleteProc); .CE .SH "SEE ALSO" -- cgit v0.12 From a33a94ec85ccfbfe1b666744acca22f46798f77a Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 23 Aug 2013 16:23:47 +0000 Subject: Make sure all Tcl_NR*Eval*() routines do a schedule only. No errors raised. --- generic/tclBasic.c | 49 ++++++++++++++++++++++++++++++++----------------- 1 file changed, 32 insertions(+), 17 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 4d56f3a..96d74c4 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -157,6 +157,7 @@ static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; +static Tcl_NRPostProc EvalObjvCore; static Tcl_NRPostProc Dispatch; static Tcl_ObjCmdProc NRCoroInjectObjCmd; @@ -4093,16 +4094,8 @@ TclNREvalObjv( * requested Command struct to be invoked. */ { Interp *iPtr = (Interp *) interp; - int result; - Namespace *lookupNsPtr = iPtr->lookupNsPtr; - - iPtr->lookupNsPtr = NULL; /* - * Push a callback with cleanup tasks for commands; the cmdPtr at data[0] - * will be filled later when the command is found: save its address at - * objProcPtr. - * * data[1] stores a marker for use by tailcalls; it will be set to 1 by * command redirectors (imports, alias, ensembles) so that tailcalls * finishes the source command and not just the target. @@ -4115,12 +4108,38 @@ TclNREvalObjv( } iPtr->numLevels++; - result = TclInterpReady(interp); + TclNRAddCallback(interp, EvalObjvCore, cmdPtr, INT2PTR(flags), + INT2PTR(objc), objv); + return TCL_OK; +} - if ((result != TCL_OK) || (objc == 0)) { - return result; +static int +EvalObjvCore( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Command *cmdPtr = data[0]; + int flags = PTR2INT(data[1]); + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; + Namespace *lookupNsPtr = iPtr->lookupNsPtr; + + if (TCL_OK != TclInterpReady(interp)) { + return TCL_ERROR; } + if (objc == 0) { + return TCL_OK; + } + + if (TclLimitExceeded(iPtr->limit)) { + return TCL_ERROR; + } + + iPtr->lookupNsPtr = NULL; + if (cmdPtr) { goto commandFound; } @@ -4164,11 +4183,6 @@ TclNREvalObjv( return TEOV_NotFound(interp, objc, objv, lookupNsPtr); } - iPtr->cmdCount++; - if (TclLimitExceeded(iPtr->limit)) { - return TCL_ERROR; - } - /* * Found a command! The real work begins now ... */ @@ -4207,9 +4221,9 @@ Dispatch( ClientData clientData = data[1]; int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; -#ifdef USE_DTRACE Interp *iPtr = (Interp *) interp; +#ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { const char *a[10]; int i = 0; @@ -4238,6 +4252,7 @@ Dispatch( } #endif /* USE_DTRACE */ + iPtr->cmdCount++; return objProc(clientData, interp, objc, objv); } -- cgit v0.12 From ccbbb5d2887f70f66db0bd2afff3def17d388c21 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 24 Aug 2013 09:42:43 +0000 Subject: Unbreak doc; the apropos index entry *must* be one line. (This is an external constraint forced by the requirement to fit into the standard Unix manual system.) --- doc/NRE.3 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/doc/NRE.3 b/doc/NRE.3 index a27a359..ce609e6 100644 --- a/doc/NRE.3 +++ b/doc/NRE.3 @@ -8,8 +8,7 @@ .TH NRE 3 8.6 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, -Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. +Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. .SH SYNOPSIS .nf \fB#include \fR -- cgit v0.12 From 28384139ba926d9708620f89b4b77f0fa48e07d7 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 Aug 2013 18:11:53 +0000 Subject: Add test for Bug 2486550. --- tests/coroutine.test | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/tests/coroutine.test b/tests/coroutine.test index 8a7fdf3..03c63ad 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -633,6 +633,15 @@ test coroutine-7.6 {Early yield crashes} { rename foo {} } {} +test coroutine-7.7 {Bug 2486550} -setup { + interp hide {} yield +} -body { + coroutine demo interp invokehidden {} yield ok +} -cleanup { + demo + interp expose {} yield +} -result ok + # cleanup unset lambda -- cgit v0.12 From 24be1383dafbc20a0a8693031637a2cb13d810b4 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 Aug 2013 20:03:57 +0000 Subject: Inline TEOV_RunEnterTraces() so its interface can be redesigned. --- generic/tclBasic.c | 74 +++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 71 insertions(+), 3 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 82aa833..8407edb 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4197,9 +4197,77 @@ EvalObjvCore( * necessary. */ - result = TEOV_RunEnterTraces(interp, &cmdPtr, TclGetSourceFromFrame( - flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, - objc, objv), objc, objv, lookupNsPtr, weLookUp); + int traceCode = TCL_OK; + int cmdEpoch = cmdPtr->cmdEpoch; + int newEpoch; + const char *command; + int length, deleted; + + Tcl_Obj *commandPtr = TclGetSourceFromFrame( + flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, + objc, objv); + + Tcl_IncrRefCount(commandPtr); + command = Tcl_GetStringFromObj(commandPtr, &length); + + /* + * Call trace functions. + * Execute any command or execution traces. Note that we bump up the + * command's reference count for the duration of the calling of the traces + * so that the structure doesn't go away underneath our feet. + */ + + cmdPtr->refCount++; + if (iPtr->tracePtr) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + newEpoch = cmdPtr->cmdEpoch; + deleted = cmdPtr->flags & CMD_IS_DELETED; + TclCleanupCommandMacro(cmdPtr); + + if (cmdEpoch != newEpoch) { + + /* + * The traces did something to the traced command. How should + * we respond? + * + * If we got the trace command by looking up a command name, we + * should just look it up again. + */ + if (weLookUp) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + } else { + + /* + * If we did not look up a command name, we got the cmdPtr + * from a caller. If that cmdPtr has been deleted, we need + * to avoid a crash. Otherwise, press on. We don't have + * any foundation to claim a better answer. + */ + if (deleted) { + cmdPtr = NULL; + } + } + } + + if (cmdPtr && (traceCode == TCL_OK)) { + /* + * Command was found: push a record to schedule the leave traces. + */ + + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); + cmdPtr->refCount++; + } else { + Tcl_DecrRefCount(commandPtr); + } + result = traceCode; + if (result != TCL_OK) { return result; } -- cgit v0.12 From e6af5d333b0e3409534af0b32a5feb4924845d25 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 Aug 2013 20:06:08 +0000 Subject: Exceptions raised from enter traces take priority over re-resolution games. --- generic/tclBasic.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 8407edb..172c698 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4230,6 +4230,11 @@ EvalObjvCore( deleted = cmdPtr->flags & CMD_IS_DELETED; TclCleanupCommandMacro(cmdPtr); + if (traceCode != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return traceCode; + } + if (cmdEpoch != newEpoch) { /* @@ -4255,7 +4260,7 @@ EvalObjvCore( } } - if (cmdPtr && (traceCode == TCL_OK)) { + if (cmdPtr) { /* * Command was found: push a record to schedule the leave traces. */ @@ -4266,11 +4271,6 @@ EvalObjvCore( } else { Tcl_DecrRefCount(commandPtr); } - result = traceCode; - - if (result != TCL_OK) { - return result; - } if (cmdPtr == NULL) { if (weLookUp) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); -- cgit v0.12 From 367ade79eda8ed8d2766b50d3b3137e9c671c9c5 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 Aug 2013 20:25:15 +0000 Subject: Tidy up indenting for clarity in refactoring. --- generic/tclBasic.c | 123 +++++++++++++++++++++++++++-------------------------- 1 file changed, 62 insertions(+), 61 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 172c698..3f579d1 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4197,80 +4197,81 @@ EvalObjvCore( * necessary. */ - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length, deleted; + int traceCode = TCL_OK; + int cmdEpoch = cmdPtr->cmdEpoch; + int newEpoch; + const char *command; + int length, deleted; - Tcl_Obj *commandPtr = TclGetSourceFromFrame( - flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, - objc, objv); + Tcl_Obj *commandPtr = TclGetSourceFromFrame( + flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, + objc, objv); - Tcl_IncrRefCount(commandPtr); - command = Tcl_GetStringFromObj(commandPtr, &length); + Tcl_IncrRefCount(commandPtr); + command = Tcl_GetStringFromObj(commandPtr, &length); - /* - * Call trace functions. - * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the traces - * so that the structure doesn't go away underneath our feet. - */ + /* + * Call trace functions. + * Execute any command or execution traces. Note that we bump up the + * command's reference count for the duration of the calling of the + * traces so that the structure doesn't go away underneath our feet. + */ - cmdPtr->refCount++; - if (iPtr->tracePtr) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - newEpoch = cmdPtr->cmdEpoch; - deleted = cmdPtr->flags & CMD_IS_DELETED; - TclCleanupCommandMacro(cmdPtr); + cmdPtr->refCount++; + if (iPtr->tracePtr) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + newEpoch = cmdPtr->cmdEpoch; + deleted = cmdPtr->flags & CMD_IS_DELETED; + TclCleanupCommandMacro(cmdPtr); - if (traceCode != TCL_OK) { - Tcl_DecrRefCount(commandPtr); - return traceCode; - } + if (traceCode != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return traceCode; + } - if (cmdEpoch != newEpoch) { - - /* - * The traces did something to the traced command. How should - * we respond? - * - * If we got the trace command by looking up a command name, we - * should just look it up again. - */ - if (weLookUp) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - } else { + if (cmdEpoch != newEpoch) { /* - * If we did not look up a command name, we got the cmdPtr - * from a caller. If that cmdPtr has been deleted, we need - * to avoid a crash. Otherwise, press on. We don't have - * any foundation to claim a better answer. + * The traces did something to the traced command. How should + * we respond? + * + * If we got the trace command by looking up a command name, we + * should just look it up again. */ - if (deleted) { - cmdPtr = NULL; + if (weLookUp) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + } else { + + /* + * If we did not look up a command name, we got the cmdPtr + * from a caller. If that cmdPtr has been deleted, we need + * to avoid a crash. Otherwise, press on. We don't have + * any foundation to claim a better answer. + */ + if (deleted) { + cmdPtr = NULL; + } } } - } - if (cmdPtr) { - /* - * Command was found: push a record to schedule the leave traces. - */ + if (cmdPtr) { + /* + * Command was found: push a record to schedule the leave traces. + */ + + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); + cmdPtr->refCount++; + } else { + Tcl_DecrRefCount(commandPtr); + } - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), - commandPtr, cmdPtr, objv); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); - } if (cmdPtr == NULL) { if (weLookUp) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); -- cgit v0.12 From 24cec35f7b00f8efa4fba53a12db4c1343d34751 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 28 Aug 2013 02:44:50 +0000 Subject: Clarfy and prettify influence of flag settings and command lookups. --- generic/tclBasic.c | 77 ++++++++++++++++++++++++++++-------------------------- 1 file changed, 40 insertions(+), 37 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3f579d1..af747cd 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4121,13 +4121,21 @@ EvalObjvCore( Tcl_Interp *interp, int result) { - Command *cmdPtr = data[0]; + Command *cmdPtr = NULL, *preCmdPtr = data[0]; int flags = PTR2INT(data[1]); int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; Interp *iPtr = (Interp *) interp; + + /* + * Capture the namespace we should do command name resolution in, as + * instructed by our caller sneaking it in to us in a private interp + * field. Clear that field right away so we cannot possibly have its + * use leak where it should not. The sneaky message pass is done. + */ + Namespace *lookupNsPtr = iPtr->lookupNsPtr; - int weLookUp = (cmdPtr == NULL); + iPtr->lookupNsPtr = NULL; if (TCL_OK != TclInterpReady(interp)) { return TCL_ERROR; @@ -4141,8 +4149,6 @@ EvalObjvCore( return TCL_ERROR; } - iPtr->lookupNsPtr = NULL; - /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). @@ -4152,45 +4158,43 @@ EvalObjvCore( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } - if (!weLookUp) { - goto commandFound; - } - - /* - * Configure evaluation context to match the requested flags. - */ - - if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) { - if (!lookupNsPtr) { - lookupNsPtr = iPtr->globalNsPtr; - } + if (preCmdPtr) { + cmdPtr = preCmdPtr; } else { - if (flags & TCL_EVAL_GLOBAL) { - TEOV_SwitchVarFrame(interp); - lookupNsPtr = iPtr->globalNsPtr; - } /* - * TCL_EVAL_INVOKE was not set: clear rewrite rules + * Configure evaluation context to match the requested flags. */ - iPtr->ensembleRewrite.sourceObjs = NULL; - } + if (lookupNsPtr) { + /* + * Do nothing. Caller gave us the lookup namespace. Use it. + * Overrides TCL_EVAL_GLOBAL. For both lookup and eval. + */ + } else if (flags & TCL_EVAL_INVOKE) { + lookupNsPtr = iPtr->globalNsPtr; + } else { - /* - * Lookup the command - */ + /* + * TCL_EVAL_INVOKE was not set: clear rewrite rules + */ - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); - } + iPtr->ensembleRewrite.sourceObjs = NULL; - /* - * Found a command! The real work begins now ... - */ + if (flags & TCL_EVAL_GLOBAL) { + /* TODO: Check we do this whenever needed. */ + TEOV_SwitchVarFrame(interp); + lookupNsPtr = iPtr->globalNsPtr; + } + } + + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + if (!cmdPtr) { + return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + } + + } - commandFound: if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { /* * Call enter traces. They will schedule a call to the leave traces if @@ -4244,7 +4248,7 @@ EvalObjvCore( * If we got the trace command by looking up a command name, we * should just look it up again. */ - if (weLookUp) { + if (preCmdPtr == NULL) { cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); } else { @@ -4273,7 +4277,7 @@ EvalObjvCore( } if (cmdPtr == NULL) { - if (weLookUp) { + if (preCmdPtr == NULL) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); } /* Is this right??? */ @@ -4798,7 +4802,6 @@ TEOV_LookupCmdFromObj( if (lookupNsPtr) { iPtr->varFramePtr->nsPtr = lookupNsPtr; - iPtr->lookupNsPtr = NULL; } cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr); iPtr->varFramePtr->nsPtr = savedNsPtr; -- cgit v0.12 From 6dcfcb8be9f31859901af2772441a1ad224c9190 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 28 Aug 2013 18:05:07 +0000 Subject: Rework the re-resolution after enter traces machinery with cleaner separations and neater interfaces. --- generic/tclBasic.c | 214 +++++++++++++++++------------------------------------ 1 file changed, 69 insertions(+), 145 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index af747cd..bafb4c2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -147,8 +147,7 @@ static int TEOV_NotFound(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static int TEOV_RunEnterTraces(Tcl_Interp *interp, Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], Namespace *lookupNsPtr, - int weLookUp); + Tcl_Obj *const objv[]); static Tcl_NRPostProc RewindCoroutineCallback; static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; @@ -4126,6 +4125,7 @@ EvalObjvCore( int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; Interp *iPtr = (Interp *) interp; + int enterTracesDone = 0; /* * Capture the namespace we should do command name resolution in, as @@ -4152,137 +4152,100 @@ EvalObjvCore( /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). + * TODO: Consider moving this up. */ if (!(flags & TCL_EVAL_NOERR)) { TEOV_PushExceptionHandlers(interp, objc, objv, flags); } - if (preCmdPtr) { - cmdPtr = preCmdPtr; - } else { + /* + * Configure evaluation context to match the requested flags. + */ + if (lookupNsPtr) { /* - * Configure evaluation context to match the requested flags. + * Do nothing. Caller gave us the lookup namespace. Use it. + * Overrides TCL_EVAL_GLOBAL. For both lookup and eval. + * TODO: Is that a bug? */ + } else if (flags & TCL_EVAL_INVOKE) { + lookupNsPtr = iPtr->globalNsPtr; + } else { - if (lookupNsPtr) { - /* - * Do nothing. Caller gave us the lookup namespace. Use it. - * Overrides TCL_EVAL_GLOBAL. For both lookup and eval. - */ - } else if (flags & TCL_EVAL_INVOKE) { - lookupNsPtr = iPtr->globalNsPtr; - } else { - - /* - * TCL_EVAL_INVOKE was not set: clear rewrite rules - */ + /* + * TCL_EVAL_INVOKE was not set: clear rewrite rules + */ - iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.sourceObjs = NULL; - if (flags & TCL_EVAL_GLOBAL) { - /* TODO: Check we do this whenever needed. */ - TEOV_SwitchVarFrame(interp); - lookupNsPtr = iPtr->globalNsPtr; - } + if (flags & TCL_EVAL_GLOBAL) { + TEOV_SwitchVarFrame(interp); + lookupNsPtr = iPtr->globalNsPtr; } + } + reresolve: + if (preCmdPtr) { + if (preCmdPtr->flags & CMD_IS_DELETED) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to invoke a deleted command")); + Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); + return TCL_ERROR; + } + cmdPtr = preCmdPtr; + } else { cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); if (!cmdPtr) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); } - } - if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - /* - * Call enter traces. They will schedule a call to the leave traces if - * necessary. - */ - - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length, deleted; + if (enterTracesDone || iPtr->tracePtr + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { Tcl_Obj *commandPtr = TclGetSourceFromFrame( flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, objc, objv); - Tcl_IncrRefCount(commandPtr); - command = Tcl_GetStringFromObj(commandPtr, &length); - /* - * Call trace functions. - * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the - * traces so that the structure doesn't go away underneath our feet. - */ + if (!enterTracesDone) { - cmdPtr->refCount++; - if (iPtr->tracePtr) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - newEpoch = cmdPtr->cmdEpoch; - deleted = cmdPtr->flags & CMD_IS_DELETED; - TclCleanupCommandMacro(cmdPtr); - - if (traceCode != TCL_OK) { - Tcl_DecrRefCount(commandPtr); - return traceCode; - } - - if (cmdEpoch != newEpoch) { + int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, + objc, objv); /* - * The traces did something to the traced command. How should - * we respond? - * - * If we got the trace command by looking up a command name, we - * should just look it up again. + * Send any exception from enter traces back as an exception + * raised by the traced command. */ - if (preCmdPtr == NULL) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - } else { - /* - * If we did not look up a command name, we got the cmdPtr - * from a caller. If that cmdPtr has been deleted, we need - * to avoid a crash. Otherwise, press on. We don't have - * any foundation to claim a better answer. - */ - if (deleted) { - cmdPtr = NULL; - } + if (code != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return code; } - } - if (cmdPtr) { /* - * Command was found: push a record to schedule the leave traces. + * If the enter traces made the resolved cmdPtr unusable, go + * back and resolve again, but next time don't run enter + * traces again. */ - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), - commandPtr, cmdPtr, objv); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); - } - - if (cmdPtr == NULL) { - if (preCmdPtr == NULL) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + if (cmdPtr == NULL) { + enterTracesDone = 1; + Tcl_DecrRefCount(commandPtr); + goto reresolve; } - /* Is this right??? */ - return TCL_OK; } + + /* + * Schedule leave traces. Raise the refCount on the resolved + * cmdPtr, so that when it passes to the leave traces we know + * it's still valid. + */ + + cmdPtr->refCount++; + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); } TclNRAddCallback(interp, Dispatch, @@ -4672,26 +4635,19 @@ TEOV_RunEnterTraces( Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], - Namespace *lookupNsPtr, - int weLookUp) + Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length, deleted; - - Tcl_IncrRefCount(commandPtr); - command = Tcl_GetStringFromObj(commandPtr, &length); + int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + int length, traceCode = TCL_OK; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); /* * Call trace functions. * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the traces - * so that the structure doesn't go away underneath our feet. + * command's reference count for the duration of the calling of the + * traces so that the structure doesn't go away underneath our feet. */ cmdPtr->refCount++; @@ -4704,47 +4660,15 @@ TEOV_RunEnterTraces( cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); } newEpoch = cmdPtr->cmdEpoch; - deleted = cmdPtr->flags & CMD_IS_DELETED; TclCleanupCommandMacro(cmdPtr); - if (cmdEpoch != newEpoch) { - - /* - * The traces did something to the traced command. How should - * we respond? - * - * If we got the trace command by looking up a command name, we - * should just look it up again. - */ - if (weLookUp) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - } else { - - /* - * If we did not look up a command name, we got the cmdPtr - * from a caller. If that cmdPtr has been deleted, we need - * to avoid a crash. Otherwise, press on. We don't have - * any foundation to claim a better answer. - */ - if (deleted) { - cmdPtr = NULL; - } - } - *cmdPtrPtr = cmdPtr; + if (traceCode != TCL_OK) { + return traceCode; } - - if (cmdPtr && (traceCode == TCL_OK)) { - /* - * Command was found: push a record to schedule the leave traces. - */ - - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), - commandPtr, cmdPtr, objv); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); + if (cmdEpoch != newEpoch) { + *cmdPtrPtr = NULL; } - return traceCode; + return TCL_OK; } static int -- cgit v0.12 From 4096bf5d01844a7fec7efeb6e234130bf81bccf0 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 29 Aug 2013 17:59:36 +0000 Subject: New internal eval flag value so that all TclNREvalObjv() callers that pre-resolve command names can choose whether or not TclNREvalObjv() should attempt to re-do the resolution from objv[0] when something goes wrong. --- generic/tclBasic.c | 75 ++++++++++++++++++++++++++++++++++-------------------- generic/tclInt.h | 1 + 2 files changed, 49 insertions(+), 27 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index bafb4c2..884b5cc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4125,18 +4125,18 @@ EvalObjvCore( int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; Interp *iPtr = (Interp *) interp; + Namespace *lookupNsPtr = NULL; int enterTracesDone = 0; - + /* - * Capture the namespace we should do command name resolution in, as - * instructed by our caller sneaking it in to us in a private interp - * field. Clear that field right away so we cannot possibly have its - * use leak where it should not. The sneaky message pass is done. + * Push records for task to be done on return, in INVERSE order. First, if + * needed, the exception handlers (as they should happen last). */ - Namespace *lookupNsPtr = iPtr->lookupNsPtr; - iPtr->lookupNsPtr = NULL; - + if (!(flags & TCL_EVAL_NOERR)) { + TEOV_PushExceptionHandlers(interp, objc, objv, flags); + } + if (TCL_OK != TclInterpReady(interp)) { return TCL_ERROR; } @@ -4150,25 +4150,23 @@ EvalObjvCore( } /* - * Push records for task to be done on return, in INVERSE order. First, if - * needed, the exception handlers (as they should happen last). - * TODO: Consider moving this up. - */ - - if (!(flags & TCL_EVAL_NOERR)) { - TEOV_PushExceptionHandlers(interp, objc, objv, flags); - } - - /* * Configure evaluation context to match the requested flags. */ - if (lookupNsPtr) { + if (iPtr->lookupNsPtr) { + /* - * Do nothing. Caller gave us the lookup namespace. Use it. - * Overrides TCL_EVAL_GLOBAL. For both lookup and eval. + * Capture the namespace we should do command name resolution in, as + * instructed by our caller sneaking it in to us in a private interp + * field. Clear that field right away so we cannot possibly have its + * use leak where it should not. The sneaky message pass is done. + * + * Use of this mechanism overrides the TCL_EVAL_GLOBAL flag. * TODO: Is that a bug? */ + + lookupNsPtr = iPtr->lookupNsPtr; + iPtr->lookupNsPtr = NULL; } else if (flags & TCL_EVAL_INVOKE) { lookupNsPtr = iPtr->globalNsPtr; } else { @@ -4185,16 +4183,29 @@ EvalObjvCore( } } + /* + * Lookup the Command to dispatch. + */ + reresolve: + assert(cmdPtr == NULL); if (preCmdPtr) { - if (preCmdPtr->flags & CMD_IS_DELETED) { + /* Caller gave it to us */ + if (!(preCmdPtr->flags & CMD_IS_DELETED)) { + /* So long as it exists, use it. */ + cmdPtr = preCmdPtr; + } else if (flags & TCL_EVAL_NORESOLVE) { + /* + * When it's been deleted, and we're told not to attempt + * resolving it ourselves, all we can do is raise an error. + */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to invoke a deleted command")); Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); return TCL_ERROR; } - cmdPtr = preCmdPtr; - } else { + } + if (cmdPtr == NULL) { cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); if (!cmdPtr) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); @@ -4217,6 +4228,11 @@ EvalObjvCore( /* * Send any exception from enter traces back as an exception * raised by the traced command. + * TODO: Is this a bug? Letting an execution trace BREAK or + * CONTINUE or RETURN in the place of the traced command? + * Would either converting all exceptions to TCL_ERROR, or + * just swallowing them be better? (Swallowing them has the + * problem of permanently hiding program errors.) */ if (code != TCL_OK) { @@ -6524,9 +6540,14 @@ TclNRInvoke( /* Avoid the exception-handling brain damage when numLevels == 0 . */ iPtr->numLevels++; Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); - - /* TODO: how to get re-resolution right */ - return TclNREvalObjv(interp, objc, objv, 0, cmdPtr); + + /* + * Normal command resolution of objv[0] isn't going to find cmdPtr. + * That's the whole point of **hidden** commands. So tell the + * Eval core machinery not to even try (and risk finding something wrong). + */ + + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr); } static int diff --git a/generic/tclInt.h b/generic/tclInt.h index e0e694f..380284f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2201,6 +2201,7 @@ typedef struct Interp { #define TCL_ALLOW_EXCEPTIONS 0x04 #define TCL_EVAL_FILE 0x02 #define TCL_EVAL_SOURCE_IN_FRAME 0x10 +#define TCL_EVAL_NORESOLVE 0x20 /* * Flag bits for Interp structures: -- cgit v0.12 From b9ef27650542d7fc1a804c5779b6ec6f0e569f84 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 29 Aug 2013 20:08:04 +0000 Subject: Bump to 8.5.15 for release. --- ChangeLog | 13 +++++++++++++ README | 2 +- generic/tcl.h | 4 ++-- library/init.tcl | 2 +- tools/tcl.wse.in | 2 +- unix/configure | 2 +- unix/configure.in | 2 +- unix/tcl.spec | 2 +- win/configure | 2 +- win/configure.in | 2 +- 10 files changed, 23 insertions(+), 10 deletions(-) diff --git a/ChangeLog b/ChangeLog index 02472fe..032bfc7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,16 @@ +2013-04-03 Don Porter + + * generic/tcl.h: Bump to 8.5.15 for release. + * library/init.tcl: + * tools/tcl.wse.in: + * unix/configure.in: + * unix/tcl.spec: + * win/configure.in: + * README: + + * unix/configure: autoconf-2.59 + * win/configure: + 2013-08-01 Harald Oehlmann * tclUnixNotify.c Tcl_InitNotifier: Bug [a0bc856dcd] diff --git a/README b/README index 0b3cf05..2ad171f 100644 --- a/README +++ b/README @@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.5.14 source distribution. + This is the Tcl 8.5.15 source distribution. http://sourceforge.net/projects/tcl/files/Tcl/ You can get any source release of Tcl from the URL above. diff --git a/generic/tcl.h b/generic/tcl.h index be5e697..eeff36e 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -58,10 +58,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 5 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 14 +#define TCL_RELEASE_SERIAL 15 #define TCL_VERSION "8.5" -#define TCL_PATCH_LEVEL "8.5.14" +#define TCL_PATCH_LEVEL "8.5.15" /* * The following definitions set up the proper options for Windows compilers. diff --git a/library/init.tcl b/library/init.tcl index 071e6df..6b49fdf 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -16,7 +16,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.5.14 +package require -exact Tcl 8.5.15 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/tools/tcl.wse.in b/tools/tcl.wse.in index aac4413..e22b74a 100644 --- a/tools/tcl.wse.in +++ b/tools/tcl.wse.in @@ -12,7 +12,7 @@ item: Global Log Pathname=%MAINDIR%\INSTALL.LOG Message Font=MS Sans Serif Font Size=8 - Disk Label=tcl8.5.14 + Disk Label=tcl8.5.15 Disk Filename=setup Patch Flags=0000000000000001 Patch Threshold=85 diff --git a/unix/configure b/unix/configure index 217e5d4..d7bd53b 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".14" +TCL_PATCH_LEVEL=".15" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/configure.in b/unix/configure.in index 37de8be..b5a09dd 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".14" +TCL_PATCH_LEVEL=".15" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/tcl.spec b/unix/tcl.spec index f7705fd..b61f4bf 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.5.14 +Version: 8.5.15 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index a1c0f6d..a0be0c4 100755 --- a/win/configure +++ b/win/configure @@ -1311,7 +1311,7 @@ SHELL=/bin/sh TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".14" +TCL_PATCH_LEVEL=".15" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 diff --git a/win/configure.in b/win/configure.in index 33bf784..ea25843 100644 --- a/win/configure.in +++ b/win/configure.in @@ -14,7 +14,7 @@ SHELL=/bin/sh TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".14" +TCL_PATCH_LEVEL=".15" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 -- cgit v0.12 From 743ced9da32b68cf1ca139b5d6ac455c39b97cf5 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 Aug 2013 14:16:05 +0000 Subject: changes --- changes | 45 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 44 insertions(+), 1 deletion(-) diff --git a/changes b/changes index 78ade0e..2221400 100644 --- a/changes +++ b/changes @@ -7735,6 +7735,49 @@ Many revisions to better support a Cygwin environment (nijtmans) --- Released 8.5.14, April 3, 2013 --- See ChangeLog for details --- -2013-05-08 (bug fix)[3036566] Honor language packs on Vista+ to get initial locale (oehlmann) +2013-04-03 (bug fix)[3205320] outsmart gcc on powerpc detect stack direction + +2013-04-04 (bug fix) Support URLs with query but no path (max) +=> http 2.7.12 + +2013-04-08 (bug fix)[3610026] regexp crash on color overflow (linnakangas) + +2013-04-16 (bug fix)[3610404] crash in enter traces (found with TclOO) (porter) + +2013-04-30 (enhancement) broaden glibc version detection (kupries) +=> platform 1.0.12 + +2013-05-01 (bug fix)[2901998] inconsistent I/O buffering (ferrieux) + +2013-05-06 (platform support) Cygwin64 (nijtmans) + +2013-05-16 (platform support) mingw-4.0 (nijtmans) + +2013-05-19 (platform support) FreeBSD updates (cerutti) + +2013-05-22 (bug fix)[3613609] [lsort -nocase] failed on non-ASCII (fellows) + +2013-05-28 (bug fix)[3036566] Use language packs (Vista+) locale (oehlmann) => msgcat 1.5.2 +2013-06-03 Restored lost performance appending to long strings (elby,porter) + +2013-06-17 (bug fix)[a876646] [:cntrl:] includes \x00 to \x1f (nijtmans) + +2013-06-17 [string is space \u180e] => 1 (nijtmans) + +2013-06-27 (bug fix)[983509] missing encodings for config values (nijtmans) + +2013-06-27 (bug fix)[32afa6] corrected dirent64 check (griffin) + +2013-07-06 tzdata updated to Olson's tzdata2013d (kenny) + +2013-07-26 (bug fix)[6585b2] regexp {(\w).*?\1} abb (lane) + +2013-07-29 [string is space \u202f] => 1 (nijtmans) + +2013-08-01 [a0bc85] Limited support for fork with threads (for Rivet) (nijtmans) + +2013-08-15 Errors from execution traces become errors of the command (porter) + +--- Released 8.5.15, September 16, 2013 --- See ChangeLog for details --- -- cgit v0.12 From 3adc64580249a75c06fd957e06732387385c4982 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 Aug 2013 14:31:06 +0000 Subject: fix date --- ChangeLog | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 032bfc7..fca182b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,4 @@ -2013-04-03 Don Porter +2013-08-30 Don Porter * generic/tcl.h: Bump to 8.5.15 for release. * library/init.tcl: -- cgit v0.12 From 6b45d21b4b5cf1d203ccaba63c88551b37c31b97 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 Aug 2013 21:57:26 +0000 Subject: Bump to tcltest 2.3.6 to account for changes since Tcl 8.6.0 release. --- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 4b0a9bc..60a9485 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded tcltest 2.3.5 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.3.6 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index d6e6487..c30d2e4 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.3.5 + variable Version 2.3.6 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] diff --git a/unix/Makefile.in b/unix/Makefile.in index 443e70d..505f7e0 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -850,8 +850,8 @@ install-libraries: libraries done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.5 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.tm; + @echo "Installing package tcltest 2.3.6 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.6.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.12.tm; diff --git a/win/Makefile.in b/win/Makefile.in index 47f3fdd..5109e7a 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -650,8 +650,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.tm; + @echo "Installing package tcltest 2.3.6 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.6.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.12.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; -- cgit v0.12 From 8932701ae7f25eee8d3bad440459a52afab45ff8 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 Aug 2013 22:04:12 +0000 Subject: Bump version number to 8.6.1. --- ChangeLog | 12 ++++++++++++ README | 2 +- generic/tcl.h | 4 ++-- library/init.tcl | 2 +- unix/configure | 2 +- unix/configure.in | 2 +- unix/tcl.spec | 2 +- win/configure | 2 +- win/configure.in | 2 +- 9 files changed, 21 insertions(+), 9 deletions(-) diff --git a/ChangeLog b/ChangeLog index ddde893..13fd83b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,15 @@ +2013-08-30 Don Porter + + * generic/tcl.h: Bump version number to 8.6.1. + * library/init.tcl: + * unix/configure.in: + * win/configure.in: + * unix/tcl.spec: + * README: + + * unix/configure: autoconf-2.59 + * win/configure: + 2013-08-03 Donal Fellows * library/auto.tcl: [Patch 3611643]: Allow TclOO classes to be found diff --git a/README b/README index 8ecd7a9..7004bc5 100644 --- a/README +++ b/README @@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.6.0 source distribution. + This is the Tcl 8.6.1 source distribution. http://sourceforge.net/projects/tcl/files/Tcl/ You can get any source release of Tcl from the URL above. diff --git a/generic/tcl.h b/generic/tcl.h index a833218..1b120fb 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -56,10 +56,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 0 +#define TCL_RELEASE_SERIAL 1 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.0" +#define TCL_PATCH_LEVEL "8.6.1" /* *---------------------------------------------------------------------------- diff --git a/library/init.tcl b/library/init.tcl index bedc06e..1ca6413 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -16,7 +16,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.6.0 +package require -exact Tcl 8.6.1 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/unix/configure b/unix/configure index 9b3c298..06ff7a4 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/configure.in b/unix/configure.in index 1a9bb31..61ad30f 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/tcl.spec b/unix/tcl.spec index 27f7189..678222c 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.6.0 +Version: 8.6.1 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index fc453f8..e7c1329 100755 --- a/win/configure +++ b/win/configure @@ -1311,7 +1311,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/configure.in b/win/configure.in index 373cfcc..6e1af50 100644 --- a/win/configure.in +++ b/win/configure.in @@ -14,7 +14,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 -- cgit v0.12 From 22515fc47ff9d489579d2363c0cb240b2235acd7 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 1 Sep 2013 20:08:50 +0000 Subject: [b98fa55285]: Fix handling of whitespace at end of hex strings to decode. --- ChangeLog | 6 ++++++ generic/tclBinary.c | 43 +++++++++++++++++++++++-------------------- tests/binary.test | 28 ++++++++++++++++++++++++++++ 3 files changed, 57 insertions(+), 20 deletions(-) diff --git a/ChangeLog b/ChangeLog index ddde893..e0b623b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2013-09-01 Donal Fellows + + * generic/tclBinary.c (BinaryDecodeHex): [Bug b98fa55285]: Ensure that + whitespace at the end of a string don't cause the decoder to drop the + last decoded byte. + 2013-08-03 Donal Fellows * library/auto.tcl: [Patch 3611643]: Allow TclOO classes to be found diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 901237b..7625d39 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2386,29 +2386,32 @@ BinaryDecodeHex( while (data < dataend) { value = 0; for (i=0 ; i<2 ; i++) { - if (data < dataend) { - c = *data++; - - if (!isxdigit((int) c)) { - if (strict || !isspace(c)) { - goto badChar; - } - i--; - continue; - } + if (data >= dataend) { value <<= 4; - c -= '0'; - if (c > 9) { - c += ('0' - 'A') + 10; - } - if (c > 16) { - c += ('A' - 'a'); + break; + } + + c = *data++; + if (!isxdigit((int) c)) { + if (strict || !isspace(c)) { + goto badChar; } - value |= (c & 0xf); - } else { - value <<= 4; - cut++; + i--; + continue; } + + value <<= 4; + c -= '0'; + if (c > 9) { + c += ('0' - 'A') + 10; + } + if (c > 16) { + c += ('A' - 'a'); + } + value |= (c & 0xf); + } + if (i < 2) { + cut++; } *cursor++ = UCHAR(value); value = 0; diff --git a/tests/binary.test b/tests/binary.test index 4393245..d424837 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2499,6 +2499,34 @@ test binary-71.9 {binary decode hex} -body { test binary-71.10 {binary decode hex} -body { string length [binary decode hex " "] } -result 0 +test binary-71.11 {binary decode hex: Bug b98fa55285} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c26\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {29 38} +test binary-71.12 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} +test binary-71.13 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} +test binary-71.14 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} test binary-72.1 {binary encode base64} -body { binary encode base64 -- cgit v0.12 From 54223a5f7e90edf67dcf3332c655723eb272ac93 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 2 Sep 2013 14:01:00 +0000 Subject: typo --- tests/zlib.test | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/zlib.test b/tests/zlib.test index c469eea..2ea185f 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -233,7 +233,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" -test zlib-8.8 {transformtion and fconfigure} -setup { +test zlib-8.8 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict @@ -250,7 +250,7 @@ test zlib-8.8 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} -test zlib-8.9 {transformtion and fconfigure} -setup { +test zlib-8.9 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream decompress] } -constraints zlib -body { @@ -267,7 +267,7 @@ test zlib-8.9 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {3064818174 358 358} -test zlib-8.10 {transformtion and fconfigure} -setup { +test zlib-8.10 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push deflate $outSide -dictionary $spdyDict @@ -284,7 +284,7 @@ test zlib-8.10 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {254 212 {data error} {TCL ZLIB DATA}} -test zlib-8.11 {transformtion and fconfigure} -setup { +test zlib-8.11 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream inflate] } -constraints zlib -body { @@ -300,7 +300,7 @@ test zlib-8.11 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.12 {transformtion and fconfigure} -setup { +test zlib-8.12 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { @@ -317,7 +317,7 @@ test zlib-8.12 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.13 {transformtion and fconfigure} -setup { +test zlib-8.13 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { @@ -334,7 +334,7 @@ test zlib-8.13 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.14 {transformtion and fconfigure} -setup { +test zlib-8.14 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { @@ -350,7 +350,7 @@ test zlib-8.14 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.15 {transformtion and fconfigure} -setup { +test zlib-8.15 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { -- cgit v0.12 From 8520e69f3213d9c34e39b16438ff5933e874a320 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 2 Sep 2013 17:59:42 +0000 Subject: [010f4162ef] First step of fix on stammering errorstack. errorstack fixed. errorinfo revision still under consideration. --- generic/tclBasic.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 884b5cc..e909a1a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4679,6 +4679,9 @@ TEOV_RunEnterTraces( TclCleanupCommandMacro(cmdPtr); if (traceCode != TCL_OK) { + if (traceCode == TCL_ERROR) { + iPtr->flags |= ERR_ALREADY_LOGGED; + } return traceCode; } if (cmdEpoch != newEpoch) { @@ -4725,6 +4728,9 @@ TEOV_RunLeaveTraces( TclCleanupCommandMacro(cmdPtr); if (traceCode != TCL_OK) { + if (traceCode == TCL_ERROR) { + iPtr->flags |= ERR_ALREADY_LOGGED; + } return traceCode; } return result; -- cgit v0.12 From 2c3dbea378135685d72d688a6ee0fffe633d5376 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 2 Sep 2013 18:47:07 +0000 Subject: Add test and improve errorInfo. --- generic/tclBasic.c | 22 ++++++++++++++++------ tests/error.test | 10 ++++++++++ 2 files changed, 26 insertions(+), 6 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e909a1a..a10a11a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4680,6 +4680,12 @@ TEOV_RunEnterTraces( if (traceCode != TCL_OK) { if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (enter trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); iPtr->flags |= ERR_ALREADY_LOGGED; } return traceCode; @@ -4702,12 +4708,10 @@ TEOV_RunLeaveTraces( Tcl_Obj *commandPtr = data[1]; Command *cmdPtr = data[2]; Tcl_Obj **objv = data[3]; - + int length; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { - int length; - const char *command = Tcl_GetStringFromObj(commandPtr, &length); - if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); @@ -4717,7 +4721,6 @@ TEOV_RunLeaveTraces( cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } } - Tcl_DecrRefCount(commandPtr); /* * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. @@ -4729,10 +4732,17 @@ TEOV_RunLeaveTraces( if (traceCode != TCL_OK) { if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (leave trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); iPtr->flags |= ERR_ALREADY_LOGGED; } - return traceCode; + result = traceCode; } + Tcl_DecrRefCount(commandPtr); return result; } diff --git a/tests/error.test b/tests/error.test index 06f8eca..0de644c 100644 --- a/tests/error.test +++ b/tests/error.test @@ -182,6 +182,16 @@ test error-4.7 {errorstack via options dict } -body { catch {f 12} m d dict get $d -errorstack } -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1} +test error-4.8 {errorstack from exec traces} -body { + proc foo args {} + proc goo {} foo + trace add execution foo enter {error bar;#} + catch goo m d + dict get $d -errorstack +} -cleanup { + rename goo {}; rename foo {} + unset -nocomplain m d +} -result {INNER {error bar} CALL goo UP 1} # Errors in error command itself -- cgit v0.12 From a313e78ffabc885fb945f12c419a3f5df086f5dc Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 16:04:06 +0000 Subject: some missed changes --- changes | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/changes b/changes index 2221400..ba7ce74 100644 --- a/changes +++ b/changes @@ -7768,7 +7768,9 @@ Many revisions to better support a Cygwin environment (nijtmans) 2013-06-27 (bug fix)[983509] missing encodings for config values (nijtmans) -2013-06-27 (bug fix)[32afa6] corrected dirent64 check (griffin) +2013-06-27 (bug fix)[34538b] apply DST in 2099 (lang) + +2013-07-02 (bug fix)[32afa6] corrected dirent64 check (griffin) 2013-07-06 tzdata updated to Olson's tzdata2013d (kenny) @@ -7778,6 +7780,8 @@ Many revisions to better support a Cygwin environment (nijtmans) 2013-08-01 [a0bc85] Limited support for fork with threads (for Rivet) (nijtmans) +2013-08-14 (bug fix)[a16752] Missing command delete callbacks (porter) + 2013-08-15 Errors from execution traces become errors of the command (porter) --- Released 8.5.15, September 16, 2013 --- See ChangeLog for details --- -- cgit v0.12 From 4733e874fc2db791cb87418bca14cb11c922ba83 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 16:04:30 +0000 Subject: update changes --- changes | 128 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 127 insertions(+), 1 deletion(-) diff --git a/changes b/changes index d3bbb43..0339919 100644 --- a/changes +++ b/changes @@ -8164,6 +8164,132 @@ Dropped support for OS X versions less than 10.4 (Tiger) (fellows) --- Released 8.6.0, December 20, 2012 --- See ChangeLog for details --- -2013-05-08 (bug fix)[3036566] Honor language packs on Vista+ to get initial locale (oehlmann) +2012-12-22 (bug fix)[3598150] DString to Tcl_Obj memleak (afredd) + +2012-12-27 (bug fix)[3598580] Tcl_ListObjReplace() refcount fix (nijtmans) + +2013-01-04 (bug fix) memleak in [format] compiler (fellows) + +2013-01-08 (bug fix)[3092089,3587096] [file normalize] on junction points + +2013-01-09 (bug fix)[3599395] status line processing (nijtmans) +2013-01-23 (bug fix)[2911139] repair async connection management (fellows) +=> http 2.8.6 + +2013-01-26 (bug fix)[3601804] Darwin segfault platformCPUID (nijtmans) + +2013-01-28 (enhancement) improve ensemble bytecode (fellows) + +2013-01-30 (enhancement) selected script code improvements (fradin) +=> tcltest 2.3.6 + +2013-01-30 (bug fix)[3599098] update to handle glibc banner changes (kupries) +=> platform 1.0.11 + +2013-01-31 (bug fix)[3598282] make install DESTDIR support (cassoff) + +2013-02-05 (bug fix)[3603434] [file normalize a:/] flaw in VFS (porter,griffin) + +2013-02-09 (bug fix)[3603695] $obj varname resolution rules (venable,fellows) + +2013-02-11 (bug fix)[3603553] zlib flushing errors (vampiera,fellows) + +2013-02-14 (bug fix)[3604576] msgcat use of Windows registry (oehlmann,nijtmans) +=> msgcat 1.5.1 + +2013-02-19 (bug fix)[2438181] report errors in trace handlers (yorick) + +2013-02-21 (bug fix)[3605447] unbreak [namespace export -clear] (porter) + +2013-02-23 (bug fix)[3599194] fallback IPv6 routines (afredd,max) + +2013-02-27 (bug fix)[3606139] stop crash in [regexp] (lane) + +2013-03-03 (bug fix)[3606258] major serial port update (english) + +2013-03-06 (bug fix)[3606683] [regexp (((((a)*)*)*)*)* {}] hangs +(grathwohl,lane,porter) + +2013-03-12 (enhancement) better build support for Debian arch (shadura) + +2013-03-19 (bug fix)[2893771] [file stat] on locked files (thoyts,nijtmans) + +2013-03-21 (bug fix)[2102614] [auto_mkindex] ensemble support (griffin) + +2013-03-27 Tcl_Zlib*() routines tolerate NULL interps (porter + +2013-04-04 (bug fix) Support URLs with query but no path (max) +=> http 2.8.7 + +2013-04-08 (bug fix)[3610026] regexp crash on color overflow (linnakangas) + +2013-04-29 (enhancement) [array set] compile improvement (fellows) + +2013-04-30 (enhancement) broaden glibc version detection (kupries) +=> platform 1.0.12 + +2013-05-06 (platform support) Cygwin64 (nijtmans) + +2013-05-15 (enhancement) Improved [list {*}...] compile (fellows) + +2013-05-16 (platform support) mingw-4.0 (nijtmans) + +2013-05-19 (platform support) FreeBSD updates (cerutti) + +2013-05-20 (bug fix)[3613567] access error temp file creation (keene) + +2013-05-20 (bug fix)[3613569] temp file open fail can crash [load] (keene) + +2013-05-22 (bug fix)[3613609] [lsort -nocase] failed on non-ASCII (fellows) + +2013-05-28 (bug fix)[3036566] Use language packs (Vista+) locale (oehlmann) => msgcat 1.5.2 +2013-05-29 (bug fix)[3614102] [apply {{} {list [if 1]}}] stack woes (porter) + +2013-06-03 Restored lost performance appending to long strings (elby,porter) + +2013-06-05 (bug fix)[2835313] [while 1 {foo [continue]}] crash (fellows) + +2013-06-17 (bug fix)[a876646] [:cntrl:] includes \x00 to \x1f (nijtmans) + +2013-06-27 (bug fix)[983509] missing encodings for config values (nijtmans) + +2013-06-27 (bug fix)[34538b] apply DST in 2099 (lang) + +2013-07-02 (bug fix)[32afa6] corrected dirent64 check (griffin) + +2013-07-06 tzdata updated to Olson's tzdata2013d (kenny) + +2013-07-10 (bug fix)[86fb5e] [info frame] in compiled ensembles (porter) + +2013-07-18 (bug fix)[1c17fb] revisd syntax errorinfo that shows error (porter) + +2013-07-26 (bug fix)[6585b2] regexp {(\w).*?\1} abb (lane) + +2013-07-29 [string is space \u202f] => 1 (nijtmans) + +2013-08-01 [a0bc85] Limited support for fork with threads (for Rivet) (nijtmans) + +2013-08-01 (bug fix)[1905562] RE recursion limit increased to support +reported usage of large expressions (porter) + +2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows)2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows) + +2013-08-03 (enhancement)[3611643] [auto_mkindex] support TclOO (fellows) + +2013-08-14 (bug fix)[a16752] Missing command delete callbacks (porter) + +2013-08-15 (bug fix)[3610404] reresolve traced forwards (porter) + +2013-08-15 Errors from execution traces become errors of the command (porter) + +2013-08-23 (bug fix)[8ff0cb9] Tcl_NR*Eval*() schedule only, as doc'd (porter) + +2013-08-29 (bug fix)[2486550] enable [interp invokehidden {} yield] (porter) + +2013-09-01 (bug fix)[b98fa55] [binary decode] fail on whitespace (reche,fellows) + +Many optmizations, improvements, and tightened stack management in bytecode. + +--- Released 8.6.1, Septemer 18, 2013 --- See ChangeLog for details --- -- cgit v0.12 From 53dc4dcdeeafe3c4154fb9dd3caf2c7d8423434b Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 16:45:56 +0000 Subject: Favor timeline over ChangeLog --- changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changes b/changes index ba7ce74..c51ff93 100644 --- a/changes +++ b/changes @@ -7784,4 +7784,4 @@ Many revisions to better support a Cygwin environment (nijtmans) 2013-08-15 Errors from execution traces become errors of the command (porter) ---- Released 8.5.15, September 16, 2013 --- See ChangeLog for details --- +--- Released 8.5.15, September 16, 2013 --- http://core.tcl.tk/tcl/ for details -- cgit v0.12 From 3116380710cb660fa7afcfd314b607763ada8ef6 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 16:47:50 +0000 Subject: Favor timeline over ChangeLog --- changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changes b/changes index 0339919..5428c3e 100644 --- a/changes +++ b/changes @@ -8292,4 +8292,4 @@ reported usage of large expressions (porter) Many optmizations, improvements, and tightened stack management in bytecode. ---- Released 8.6.1, Septemer 18, 2013 --- See ChangeLog for details --- +--- Released 8.6.1, Septemer 18, 2013 --- http://core.tcl.tk/tcl/ for details -- cgit v0.12 From 6a3868f2ccfb0ab9f2532d7b47849953f6b6f273 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 17:07:41 +0000 Subject: typo --- pkgs/README | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pkgs/README b/pkgs/README index 01c6f43..868bd4f 100644 --- a/pkgs/README +++ b/pkgs/README @@ -39,7 +39,7 @@ needs to conform to the following conventions. distclean: Delete all generated files. dist: Produce a copy of the package's source code distribution. - Must respect the DIST_ROOT variable determing where to + Must respect the DIST_ROOT variable determining where to write the generated directory. Packages that are written to make use of the Tcl Extension Architecture (TEA) -- cgit v0.12 From c5cad32cd648b6b43d3378412e88789d871f9749 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 17:39:34 +0000 Subject: make dist --- unix/tclConfig.h.in | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index 23d6026..e55dcd0 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -115,6 +115,9 @@ /* Define to 1 if you have the `gmtime_r' function. */ #undef HAVE_GMTIME_R +/* Compiler support for module scope symbols */ +#undef HAVE_HIDDEN + /* Do we have the intptr_t type? */ #undef HAVE_INTPTR_T @@ -343,9 +346,6 @@ /* Do we have ? */ #undef NO_VALUES_H -/* Compiler support for module scope symbols */ -#undef HAVE_HIDDEN - /* Do we have wait3() */ #undef NO_WAIT3 -- cgit v0.12 From 4d70c5f1e1c701e08aba87cfe904436f6670afc3 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 18:50:08 +0000 Subject: doc fix exposed by `make html` --- doc/file.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/file.n b/doc/file.n index 0b0ee9d..c117ee1 100644 --- a/doc/file.n +++ b/doc/file.n @@ -484,7 +484,7 @@ not the effective ones. .TP \fBWindows\fR\0\0\0\0 . -The \fbfile owned\fR subcommand currently always reports that the current user +The \fBfile owned\fR subcommand currently always reports that the current user is the owner of the file, without regard for what the operating system believes to be true, making an ownership test useless. This issue (#3613671) may be fixed in a future release of Tcl. -- cgit v0.12 From 9878106deb1fb3cf0c6c338f006ca9b168162eb7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 4 Sep 2013 07:22:45 +0000 Subject: Fix 3 trivial (possible) errors, discovered by covertity.com --- generic/tclUtil.c | 3 +-- unix/tclUnixFCmd.c | 4 ++-- unix/tclUnixSock.c | 2 ++ 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 27e2474..b089132 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3580,10 +3580,9 @@ UpdateStringOfEndOffset( register Tcl_Obj *objPtr) { char buffer[TCL_INTEGER_SPACE + 5]; - register int len; + register int len = 3; memcpy(buffer, "end", 4); - len = sizeof("end") - 1; if (objPtr->internalRep.longValue != 0) { buffer[len++] = '-'; len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index e27f78f..e270b6a 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -462,10 +462,10 @@ DoCopyFile( switch ((int) (statBufPtr->st_mode & S_IFMT)) { #ifndef DJGPP case S_IFLNK: { - char linkBuf[MAXPATHLEN]; + char linkBuf[MAXPATHLEN+1]; int length; - length = readlink(src, linkBuf, sizeof(linkBuf)); + length = readlink(src, linkBuf, MAXPATHLEN); /* INTL: Native. */ if (length == -1) { return TCL_ERROR; diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 9c3d7eb..a6360c2 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1358,6 +1358,7 @@ Tcl_OpenTcpServer( my_errno = errno; } close(sock); + sock = -1; continue; } if (port == 0 && chosenport == 0) { @@ -1380,6 +1381,7 @@ Tcl_OpenTcpServer( my_errno = errno; } close(sock); + sock = -1; continue; } if (statePtr == NULL) { -- cgit v0.12 From c938932757c599ede8ffa7b3ece3388ca07e714c Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 4 Sep 2013 09:36:22 +0000 Subject: [98c8b3ec12] Make test fail in less catastrophic manner. --- tests/zlib.test | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/tests/zlib.test b/tests/zlib.test index 2ea185f..0712929 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -276,7 +276,10 @@ test zlib-8.10 {transformation and fconfigure} -setup { puts -nonewline $outSide $spdyHeaders chan pop $outSide set compressed [read $inSide] - catch {zlib inflate $compressed} err opt + catch { + zlib inflate $compressed + throw UNREACHABLE "should be unreachable" + } err opt list [string length [zlib deflate $spdyHeaders]] \ [string length $compressed] \ $err [dict get $opt -errorcode] -- cgit v0.12 From c6bb98e76328014f65ff65473404b5467cdd3823 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 4 Sep 2013 12:45:51 +0000 Subject: Cleaned up test command trying to make valgrind happy. --- generic/tclTest.c | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 96973d7..f121d0d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -4408,8 +4408,26 @@ TestseterrorcodeCmd( Tcl_SetResult(interp, "too many args", TCL_STATIC); return TCL_ERROR; } - Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], - argv[5], NULL); + switch (argc) { + case 1: + Tcl_SetErrorCode(interp, "NONE", NULL); + break; + case 2: + Tcl_SetErrorCode(interp, argv[1], NULL); + break; + case 3: + Tcl_SetErrorCode(interp, argv[1], argv[2], NULL); + break; + case 4: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL); + break; + case 5: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL); + break; + case 6: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], + argv[5], NULL); + } return TCL_ERROR; } -- cgit v0.12 From 493b04cbc0a18f28160f6a1abdf5f33ccdf4763a Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 5 Sep 2013 12:45:11 +0000 Subject: Error in order of #include lines broke some windows builds. --- generic/tclParse.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclParse.c b/generic/tclParse.c index c5cb1d1..ee0d4c4 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -13,9 +13,9 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include #include "tclInt.h" #include "tclParse.h" +#include /* * The following table provides parsing information about each possible 8-bit -- cgit v0.12 From 30710a181cec66e45ca810d5f5fb39b91b309a8a Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 5 Sep 2013 15:47:29 +0000 Subject: Use ne instead of [string length] for less shimmer risk. --- library/tm.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/tm.tcl b/library/tm.tcl index 955e84d..55efda6 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -238,7 +238,7 @@ proc ::tcl::tm::UnknownHandler {original name args} { continue } - if {[string length [package ifneeded $pkgname $pkgversion]]} { + if {[package ifneeded $pkgname $pkgversion] ne {}} { # There's already a provide script registered for # this version of this package. Since all units of # code claiming to be the same version of the same -- cgit v0.12 From 97f959515137025afedfa551566dd4c4cbe94fa3 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 5 Sep 2013 17:21:41 +0000 Subject: Partial revert of [a16752c252] bug fix to stop crashes in buggy tclcompiler. --- generic/tclBasic.c | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 314b5fc..c3ab871 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1967,7 +1967,8 @@ Tcl_CreateCommand( * * Side effects: * If a command named "cmdName" already exists for interp, it is - * first deleted. Then the new command is created from the arguments. + * first deleted. Then the new command is created from the arguments. + * [***] (See below for exception). * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based @@ -2034,8 +2035,27 @@ Tcl_CreateObjCommand( if (!isNew) { cmdPtr = Tcl_GetHashValue(hPtr); + /* Command already exists. */ + + /* + * [***] This is wrong. See Tcl Bug a16752c252. + * However, this buggy behavior is kept under particular + * circumstances to accommodate deployed binaries of the + * "tclcompiler" program. http://sourceforge.net/projects/tclpro/ + * that crash if the bug is fixed. + */ + + if (cmdPtr->objProc == TclInvokeStringCommand + && cmdPtr->clientData == clientData + && cmdPtr->deleteData == clientData + && cmdPtr->deleteProc == deleteProc) { + cmdPtr->objProc = proc; + cmdPtr->objClientData = clientData; + return (Tcl_Command) cmdPtr; + } + /* - * Command already exists; delete it. Be careful to preserve any + * Otherwise, we delete the old command. Be careful to preserve any * existing import links so we can restore them down below. That way, * you can redefine a command and its import status will remain * intact. -- cgit v0.12 From 2b788a21e46559d0e4de15b7b9adc5fb81d59f12 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 8 Sep 2013 10:21:37 +0000 Subject: [3611643] Stop polluting the global namespace. Refactor the index entry generation so it is done right, once. Handle more of [namespace ensemble create]'s behavior. --- library/auto.tcl | 69 +++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 43 insertions(+), 26 deletions(-) diff --git a/library/auto.tcl b/library/auto.tcl index 78c219e..02edcc4 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -513,6 +513,32 @@ proc auto_mkindex_parser::fullname {name} { return [string map [list \0 \$] $name] } +# auto_mkindex_parser::indexEntry -- +# +# Used by commands like "proc" within the auto_mkindex parser to add a +# correctly-quoted entry to the index. This is shared code so it is done +# *right*, in one place. +# +# Arguments: +# name - Name that is being added to index. + +proc auto_mkindex_parser::indexEntry {name} { + variable index + variable scriptFile + + # We convert all metacharacters to their backslashed form, and pre-split + # the file name that we know about (which will be a proper list, and so + # correctly quoted). + + set name [string range [list \}[fullname $name]] 2 end] + set filenameParts [file split $scriptFile] + + append index [format \ + {set auto_index(%s) [list source [file join $dir %s]]%s} \ + $name $filenameParts \n] + return +} + if {[llength $::auto_mkindex_parser::initCommands]} { return } @@ -524,15 +550,7 @@ if {[llength $::auto_mkindex_parser::initCommands]} { # Adds an entry to the auto index list for the given procedure name. auto_mkindex_parser::command proc {name args} { - variable index - variable scriptFile - # Do some fancy reformatting on the "source" call to handle platform - # differences with respect to pathnames. Use format just so that the - # command is a little easier to read (otherwise it'd be full of - # backslashed dollar signs, etc. - append index [list set auto_index([fullname $name])] \ - [format { [list source [file join $dir %s]]} \ - [file split $scriptFile]] "\n" + indexEntry $name } # Conditionally add support for Tcl byte code files. There are some tricky @@ -559,14 +577,7 @@ auto_mkindex_parser::hook { # procedure name. auto_mkindex_parser::commandInit tbcload::bcproc {name args} { - variable index - variable scriptFile - # Do some nice reformatting of the "source" call, to get around - # path differences on different platforms. We use the format - # command just so that the code is a little easier to read. - append index [list set auto_index([fullname $name])] \ - [format { [list source [file join $dir %s]]} \ - [file split $scriptFile]] "\n" + indexEntry $name } } } @@ -610,6 +621,13 @@ auto_mkindex_parser::command namespace {op args} { variable contextStack if {[lindex $args 0] eq "create"} { set name ::[join [lreverse $contextStack] ::] + catch { + set name [dict get [lrange $args 1 end] -command] + if {![string match ::* $name]} { + set name ::[join [lreverse $contextStack] ::]$name + } + regsub -all ::+ $name :: name + } # create artifical proc to force an entry in the tclIndex $parser eval [list ::proc $name {} {}] } @@ -619,15 +637,14 @@ auto_mkindex_parser::command namespace {op args} { # AUTO MKINDEX: oo::class create name ?definition? # Adds an entry to the auto index list for the given class name. -foreach cmd {oo::class class} { - auto_mkindex_parser::command $cmd {ecmd name {body ""}} { - if {$cmd eq "create"} { - variable index - variable scriptFile - append index [format "set %s \[list source \[%s]]\n" \ - [list auto_index([fullname $name])] \ - [list file join $dir {*}[file split $scriptFile]]] - } +auto_mkindex_parser::command oo::class {op name {body ""}} { + if {$op eq "create"} { + indexEntry $name + } +} +auto_mkindex_parser::command class {op name {body ""}} { + if {$op eq "create"} { + indexEntry $name } } -- cgit v0.12 From e0623615e3e41739740f01c94c66447eb95442e7 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 9 Sep 2013 13:34:06 +0000 Subject: [3609693] Must strip the internal representation of procedure-like methods in order to ensure that any bound references to instance variables are removed. --- generic/tclOOMethod.c | 50 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 48 insertions(+), 2 deletions(-) diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 81293c7..61215de 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1290,11 +1290,57 @@ CloneProcedureMethod( ClientData *newClientData) { ProcedureMethod *pmPtr = clientData; - ProcedureMethod *pm2Ptr = ckalloc(sizeof(ProcedureMethod)); + ProcedureMethod *pm2Ptr; + Tcl_Obj *bodyObj, *argsObj; + CompiledLocal *localPtr; + /* + * Copy the argument list. + */ + + argsObj = Tcl_NewObj(); + for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL; + localPtr=localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_Obj *argObj = Tcl_NewObj(); + + Tcl_ListObjAppendElement(NULL, argObj, + Tcl_NewStringObj(localPtr->name, -1)); + if (localPtr->defValuePtr != NULL) { + Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); + } + Tcl_ListObjAppendElement(NULL, argsObj, argObj); + } + } + + /* + * Must strip the internal representation in order to ensure that any + * bound references to instance variables are removed. [Bug 3609693] + */ + + bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); + TclFreeIntRep(bodyObj); + + /* + * Create the actual copy of the method record, manufacturing a new proc + * record. + */ + + pm2Ptr = ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; - pm2Ptr->procPtr->refCount++; + Tcl_IncrRefCount(argsObj); + Tcl_IncrRefCount(bodyObj); + if (TclCreateProc(interp, NULL, "", argsObj, bodyObj, + &pm2Ptr->procPtr) != TCL_OK) { + Tcl_DecrRefCount(argsObj); + Tcl_DecrRefCount(bodyObj); + ckfree(pm2Ptr); + return TCL_ERROR; + } + Tcl_DecrRefCount(argsObj); + Tcl_DecrRefCount(bodyObj); + if (pmPtr->cloneClientdataProc) { pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData); } -- cgit v0.12 From 822fd2d405d58ee9b5a0e485819a8515ced8517e Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 11 Sep 2013 02:32:04 +0000 Subject: Stop the save and restore of currStackDepth. Just manage it correctly so it doesn't need correcting. --- generic/tclCompExpr.c | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 2a48117..c2b5a1a 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -490,8 +490,6 @@ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ - int depth; /* Remember the currStackDepth of the - * CompileEnv here. */ int offset; /* Data used to compute jump lengths to pass * to TclFixupForwardJump() */ int convert; /* Temporary storage used to compute whether @@ -2269,7 +2267,6 @@ CompileExprTree( newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - jumpPtr->depth = envPtr->currStackDepth; convert = 1; break; case AND: @@ -2283,7 +2280,6 @@ CompileExprTree( newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - jumpPtr->depth = envPtr->currStackDepth; break; } } else if (nodePtr->mark == MARK_RIGHT) { @@ -2323,7 +2319,7 @@ CompileExprTree( CLANG_ASSERT(jumpPtr); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpPtr->next->jump); - envPtr->currStackDepth = jumpPtr->depth; + TclAdjustStackDepth(-1, envPtr); jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); jumpPtr->convert = convert; convert = 1; @@ -2383,7 +2379,6 @@ CompileExprTree( TclFixupForwardJump(envPtr, &jumpPtr->jump, jumpPtr->offset - jumpPtr->jump.codeOffset, 127); convert |= jumpPtr->convert; - envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); @@ -2411,7 +2406,6 @@ CompileExprTree( TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump, 127); convert = 0; - envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); -- cgit v0.12 From c4a5440ed157b3a38dc7b9f05138f9d9c2ceb084 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 11 Sep 2013 04:49:08 +0000 Subject: Make use of the existing JumpFixup fields. Eliminate extra storage field 'offset' in JumpList that we don't require. --- generic/tclCompExpr.c | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index c2b5a1a..0021323 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -490,8 +490,6 @@ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ - int offset; /* Data used to compute jump lengths to pass - * to TclFixupForwardJump() */ int convert; /* Temporary storage used to compute whether * numeric conversion will be needed following * the operator we're compiling. */ @@ -2320,7 +2318,6 @@ CompileExprTree( TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpPtr->next->jump); TclAdjustStackDepth(-1, envPtr); - jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); jumpPtr->convert = convert; convert = 1; break; @@ -2374,10 +2371,10 @@ CompileExprTree( if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, (envPtr->codeNext - envPtr->codeStart) - jumpPtr->next->jump.codeOffset, 127)) { - jumpPtr->offset += 3; + jumpPtr->next->jump.codeOffset += 3; } TclFixupForwardJump(envPtr, &jumpPtr->jump, - jumpPtr->offset - jumpPtr->jump.codeOffset, 127); + jumpPtr->next->jump.codeOffset + 2 -jumpPtr->jump.codeOffset, 127); convert |= jumpPtr->convert; freePtr = jumpPtr; jumpPtr = jumpPtr->next; -- cgit v0.12 From 612c7a7d4a319d2be46e93ee9fdd33eec72dd7b1 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 11 Sep 2013 05:07:52 +0000 Subject: Eliminate another surplus storage field. Make a(n ab)use of the existing JumpFixup fields instead. --- generic/tclCompExpr.c | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 0021323..4afb069 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -490,9 +490,6 @@ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ - int convert; /* Temporary storage used to compute whether - * numeric conversion will be needed following - * the operator we're compiling. */ struct JumpList *next; /* Point to next item on the stack */ } JumpList; @@ -2318,7 +2315,9 @@ CompileExprTree( TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpPtr->next->jump); TclAdjustStackDepth(-1, envPtr); - jumpPtr->convert = convert; + if (convert) { + jumpPtr->jump.jumpType = TCL_TRUE_JUMP; + } convert = 1; break; case AND: @@ -2368,6 +2367,10 @@ CompileExprTree( break; case COLON: CLANG_ASSERT(jumpPtr); + if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) { + jumpPtr->jump.jumpType = TCL_FALSE_JUMP; + convert = 1; + } if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, (envPtr->codeNext - envPtr->codeStart) - jumpPtr->next->jump.codeOffset, 127)) { @@ -2375,7 +2378,6 @@ CompileExprTree( } TclFixupForwardJump(envPtr, &jumpPtr->jump, jumpPtr->next->jump.codeOffset + 2 -jumpPtr->jump.codeOffset, 127); - convert |= jumpPtr->convert; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); -- cgit v0.12 From 8fd5bbdc7c92308b942426286b37adef8afb5a6a Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 12 Sep 2013 17:42:36 +0000 Subject: Stop allocating JumpFixups for jumps that can never need any fixing up. --- generic/tclCompExpr.c | 37 +++++++++++++++---------------------- 1 file changed, 15 insertions(+), 22 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 4afb069..7684c70 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2269,12 +2269,6 @@ CompileExprTree( newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; break; } } else if (nodePtr->mark == MARK_RIGHT) { @@ -2328,6 +2322,8 @@ CompileExprTree( break; } } else { + int pc1, pc2; + switch (nodePtr->lexeme) { case START: case QUESTION: @@ -2377,7 +2373,9 @@ CompileExprTree( jumpPtr->next->jump.codeOffset += 3; } TclFixupForwardJump(envPtr, &jumpPtr->jump, - jumpPtr->next->jump.codeOffset + 2 -jumpPtr->jump.codeOffset, 127); + jumpPtr->next->jump.codeOffset + 2 + - jumpPtr->jump.codeOffset, 127); + freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); @@ -2388,32 +2386,27 @@ CompileExprTree( case AND: case OR: CLANG_ASSERT(jumpPtr); - TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) - ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, - &jumpPtr->next->jump); + pc1 = CurrentOffset(envPtr); + TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 + : INST_JUMP_TRUE1, 0, envPtr); TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpPtr->next->next->jump); + pc2 = CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP1, 0, envPtr); TclAdjustStackDepth(-1, envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->jump, 127); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1, + envPtr->codeStart + pc1 + 1); if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { - jumpPtr->next->next->jump.codeOffset += 3; + pc2 += 3; } TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump, - 127); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, + envPtr->codeStart + pc2 + 1); convert = 0; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); break; default: TclEmitOpcode(instruction[nodePtr->lexeme], envPtr); -- cgit v0.12 From 27c4d781f4bfb6ea056b4b93a9787bc49fe8d582 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 12 Sep 2013 19:21:20 +0000 Subject: Swap the two fixups used when compiling the ternary operator. Push them on the stack only when needed, and pop as soon as possible. --- generic/tclCompExpr.c | 33 ++++++++++++++++----------------- 1 file changed, 16 insertions(+), 17 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 7684c70..106855a 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2256,12 +2256,6 @@ CompileExprTree( switch (nodePtr->lexeme) { case QUESTION: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; convert = 1; break; case AND: @@ -2302,12 +2296,17 @@ CompileExprTree( break; } case QUESTION: + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); break; case COLON: - CLANG_ASSERT(jumpPtr); + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpPtr->next->jump); + &jumpPtr->jump); TclAdjustStackDepth(-1, envPtr); if (convert) { jumpPtr->jump.jumpType = TCL_TRUE_JUMP; @@ -2322,7 +2321,7 @@ CompileExprTree( break; } } else { - int pc1, pc2; + int pc1, pc2, target; switch (nodePtr->lexeme) { case START: @@ -2364,21 +2363,21 @@ CompileExprTree( case COLON: CLANG_ASSERT(jumpPtr); if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) { - jumpPtr->jump.jumpType = TCL_FALSE_JUMP; + jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP; convert = 1; } - if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, + target = jumpPtr->jump.codeOffset + 2; + if (TclFixupForwardJump(envPtr, &jumpPtr->jump, (envPtr->codeNext - envPtr->codeStart) - - jumpPtr->next->jump.codeOffset, 127)) { - jumpPtr->next->jump.codeOffset += 3; + - jumpPtr->jump.codeOffset, 127)) { + target += 3; } - TclFixupForwardJump(envPtr, &jumpPtr->jump, - jumpPtr->next->jump.codeOffset + 2 - - jumpPtr->jump.codeOffset, 127); - freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); + TclFixupForwardJump(envPtr, &jumpPtr->jump, + target - jumpPtr->jump.codeOffset, 127); + freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); -- cgit v0.12 From 0440ab215bf5a3d23ff92148fd2d83bac1b7f483 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 12 Sep 2013 19:27:48 +0000 Subject: Push fixup on the stack only when needed. --- generic/tclCompExpr.c | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 106855a..fce870b 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2254,16 +2254,8 @@ CompileExprTree( if (nodePtr->mark == MARK_LEFT) { next = nodePtr->left; - switch (nodePtr->lexeme) { - case QUESTION: + if (nodePtr->lexeme == QUESTION) { convert = 1; - break; - case AND: - case OR: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - break; } } else if (nodePtr->mark == MARK_RIGHT) { next = nodePtr->right; @@ -2314,10 +2306,12 @@ CompileExprTree( convert = 1; break; case AND: - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); - break; case OR: - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpPtr->jump); + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) + ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, &jumpPtr->jump); break; } } else { -- cgit v0.12 From e94119e59b27e214c0c9ac4e50e6d0f7bb25235c Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 13 Sep 2013 03:33:43 +0000 Subject: More macro use. --- generic/tclCompCmds.c | 8 ++------ generic/tclCompExpr.c | 4 +--- 2 files changed, 3 insertions(+), 9 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 8edb2d9..fdc8ec1 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2228,7 +2228,7 @@ TclCompileForCmd( { Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; - int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; + int bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; DefineLineInformation; /* TIP #280 */ @@ -2309,13 +2309,9 @@ TclCompileForCmd( * terminates the for. */ - testCodeOffset = CurrentOffset(envPtr); - - jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { + if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) { bodyCodeOffset += 3; nextCodeOffset += 3; - testCodeOffset += 3; } SetLineInformation(2); diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index fce870b..d8e4d9f 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2361,9 +2361,7 @@ CompileExprTree( convert = 1; } target = jumpPtr->jump.codeOffset + 2; - if (TclFixupForwardJump(envPtr, &jumpPtr->jump, - (envPtr->codeNext - envPtr->codeStart) - - jumpPtr->jump.codeOffset, 127)) { + if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { target += 3; } freePtr = jumpPtr; -- cgit v0.12 From fa65ef51ba0c2de8eff89080da3e636fe4581320 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 13 Sep 2013 10:53:32 +0000 Subject: Suggested fix for [bdd91c7e43]: tclsh crashes in [interp delete] --- generic/tclExecute.c | 1 + unix/configure | 0 2 files changed, 1 insertion(+) mode change 100755 => 100644 unix/configure diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8fb8e63..e657828 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2311,6 +2311,7 @@ TclExecuteByteCode( initCatchTop += moved; catchTop += moved; + bcFramePtr = (CmdFrame *) (initCatchTop + codePtr->maxExceptDepth + 1); initTosPtr += moved; tosPtr += moved; esPtr = iPtr->execEnvPtr->execStackPtr; diff --git a/unix/configure b/unix/configure old mode 100755 new mode 100644 -- cgit v0.12 From 08390e5c47392230bda04736d41312f3864618c9 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 13 Sep 2013 16:02:11 +0000 Subject: Added note to ChangeLog pointing to the fossil timeline for better logging. --- ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/ChangeLog b/ChangeLog index fca182b..fd8c7c7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +A NOTE ON THE CHANGELOG: +Starting in early 2011, Tcl source code has been under the management of +fossil, hosted at http://core.tcl.tk/tcl/ . Fossil presents a "Timeline" +view of changes made that is superior in every way to a hand edited log file. +Because of this, many Tcl developers are now out of the habit of maintaining +this log file. You may still find useful things in it, but the Timeline is +a better first place to look now. +============================================================================ + 2013-08-30 Don Porter * generic/tcl.h: Bump to 8.5.15 for release. -- cgit v0.12 From 365b8787458eb7760f6e8f7979e987eb3c70c991 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 14 Sep 2013 07:07:03 +0000 Subject: [2152292] Corrected implementation of uuencoding. --- doc/binary.n | 17 +++---- generic/tclBinary.c | 125 ++++++++++++++++++++++++++++++++++++++++++++++++++-- tests/binary.test | 43 ++++++++++++------ 3 files changed, 158 insertions(+), 27 deletions(-) diff --git a/doc/binary.n b/doc/binary.n index a40afe6..95be36e 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -96,25 +96,22 @@ largely superseded by the \fBbase64\fR binary encoding. .RS .PP During encoding, the following options are supported: -'\" This is wrong! The uuencode format had more complexity than this! .TP \fB\-maxlen \fIlength\fR . Indicates that the output should be split into lines of no more than -\fIlength\fR characters. By default, lines are not split. -.TP -\fB\-wrapchar \fIcharacter\fR -. -Indicates that, when lines are split because of the \fB\-maxlen\fR option, -\fIcharacter\fR should be used to separate lines. By default, this is a -newline character, -.QW \en . +\fIlength\fR characters. By default, lines are split every 61 characters, and +this must be in the range 3 to 85 due to limitations in the encoding. .PP During decoding, the following options are supported: .TP \fB\-strict\fR . -Instructs the decoder to throw an error if it encounters whitespace characters. Otherwise it ignores them. +Instructs the decoder to throw an error if it encounters whitespace +characters. Otherwise it ignores them. +.PP +Note that neither the encoder nor the decoder handle the header and footer of +the uuencode format. .RE .VE 8.6 .SH "BINARY FORMAT" diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 7625d39..71da309 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -87,10 +87,13 @@ static int BinaryDecodeHex(ClientData clientData, static int BinaryEncode64(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int BinaryDecodeUu(ClientData clientData, +static int BinaryDecode64(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int BinaryDecode64(ClientData clientData, +static int BinaryEncodeUu(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int BinaryDecodeUu(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -140,7 +143,7 @@ static const EnsembleImplMap binaryMap[] = { }; static const EnsembleImplMap encodeMap[] = { { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, (ClientData)HexDigits, 0 }, - { "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits, 0 }, + { "uuencode", BinaryEncodeUu, NULL, NULL, NULL, 0 }, { "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 }, { NULL, NULL, NULL, NULL, NULL, 0 } }; @@ -2439,7 +2442,7 @@ BinaryDecodeHex( * This implements a generic 6 bit binary encoding. Input is broken into * 6 bit chunks and a lookup table passed in via clientData is used to * turn these values into output characters. This is used to implement - * base64 and uuencode binary encodings. + * base64 binary encodings. * * Results: * Interp result set to an encoded byte array object @@ -2498,6 +2501,12 @@ BinaryEncode64( if (Tcl_GetIntFromObj(interp, objv[i+1], &maxlen) != TCL_OK) { return TCL_ERROR; } + if (maxlen < 0) { + Tcl_SetResult(interp, "line length out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "LINE_LENGTH", NULL); + return TCL_ERROR; + } break; case OPT_WRAPCHAR: wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); @@ -2550,6 +2559,114 @@ BinaryEncode64( /* *---------------------------------------------------------------------- * + * BinaryEncodeUu -- + * + * This implements the uuencode binary encoding. Input is broken into 6 + * bit chunks and a lookup table is used to turn these values into output + * characters. This differs from the generic code above in that line + * lengths are also encoded. + * + * Results: + * Interp result set to an encoded byte array object + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +static int +BinaryEncodeUu( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *resultObj; + unsigned char *data, *start, *cursor; + int offset, count, rawLength, n, i, bits, index; + int lineLength = 61; + enum {OPT_MAXLEN}; + static const char *const optStrings[] = { "-maxlen", NULL }; + + if (objc < 2 || objc%2 != 0) { + Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? data"); + return TCL_ERROR; + } + for (i = 1; i < objc-1; i += 2) { + if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", + TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case OPT_MAXLEN: + if (Tcl_GetIntFromObj(interp, objv[i+1], &lineLength) != TCL_OK) { + return TCL_ERROR; + } + if (lineLength < 3 || lineLength > 85) { + Tcl_SetResult(interp, "line length out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "LINE_LENGTH", NULL); + return TCL_ERROR; + } + break; + } + } + + /* + * Allocate the buffer. This is a little bit too long, but is "good + * enough". + */ + + resultObj = Tcl_NewObj(); + offset = 0; + data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); + rawLength = (lineLength - 1) * 3 / 4; + start = cursor = Tcl_SetByteArrayLength(resultObj, + (lineLength + 1) * ((count + (rawLength - 1)) / rawLength)); + n = bits = 0; + + /* + * Encode the data. Each output line first has the length of raw data + * encoded by the output line described in it by one encoded byte, then + * the encoded data follows (encoding each 6 bits as one character). + * Encoded lines are always terminated by a newline. + */ + + while (offset < count) { + int lineLen = count - offset; + + if (lineLen > rawLength) { + lineLen = rawLength; + } + *cursor++ = UueDigits[lineLen]; + for (i=0 ; i 6 ; bits -= 6) { + *cursor++ = UueDigits[(n >> (bits-6)) & 0x3f]; + } + } + if (bits > 0) { + n <<= 8; + *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f]; + bits = 0; + } + *cursor++ = '\n'; + } + + /* + * Fix the length of the output bytearray. + */ + + Tcl_SetByteArrayLength(resultObj, cursor-start); + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * BinaryDecodeUu -- * * Decode a uuencoded string. diff --git a/tests/binary.test b/tests/binary.test index d424837..4b71b77 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2705,34 +2705,51 @@ test binary-74.1 {binary encode uuencode} -body { } -returnCodes error -match glob -result "wrong # args: *" test binary-74.2 {binary encode uuencode} -body { binary encode uuencode abc -} -result {86)C} +} -result {#86)C +} test binary-74.3 {binary encode uuencode} -body { binary encode uuencode {} } -result {} test binary-74.4 {binary encode uuencode} -body { binary encode uuencode [string repeat abc 20] -} -result [string repeat 86)C 20] +} -result "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" test binary-74.5 {binary encode uuencode} -body { binary encode uuencode \0\1\2\3\4\0\1\2\3 -} -result "``\$\"`P0``0(#" +} -result ")``\$\"`P0``0(#\n" test binary-74.6 {binary encode uuencode} -body { binary encode uuencode \0 -} -result {````} +} -result {!`` +} test binary-74.7 {binary encode uuencode} -body { binary encode uuencode \0\0 -} -result {````} +} -result "\"``` +" test binary-74.8 {binary encode uuencode} -body { binary encode uuencode \0\0\0 -} -result {````} +} -result {#```` +} test binary-74.9 {binary encode uuencode} -body { binary encode uuencode \0\0\0\0 -} -result {````````} -test binary-74.10 {binary encode uuencode} -body { - binary encode uuencode -maxlen 0 -wrapchar | abcabcabc -} -result {86)C86)C86)C} -test binary-74.11 {binary encode uuencode} -body { - binary encode uuencode -maxlen 1 -wrapchar | abcabcabc -} -result {8|6|)|C|8|6|)|C|8|6|)|C} +} -result {$`````` +} +test binary-74.10 {binary encode uuencode} -returnCodes error -body { + binary encode uuencode -maxlen 30 -wrapchar | abcabcabc +} -result {bad option "-wrapchar": must be -maxlen} +test binary-74.11 {binary encode uuencode} -returnCodes error -body { + binary encode uuencode -maxlen 1 abcabcabc +} -result {line length out of range} +test binary-74.12 {binary encode uuencode} -body { + binary encode uuencode -maxlen 3 abcabcabc +} -result {!80 +!8@ +!8P +!80 +!8@ +!8P +!80 +!8@ +!8P +} test binary-75.1 {binary decode uuencode} -body { binary decode uuencode -- cgit v0.12 From 54850c7528f0be7322a652295751b4aae4fd8317 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 14 Sep 2013 08:51:23 +0000 Subject: Add back -wrapchar option to "binary encode uuencode". --- doc/binary.n | 9 ++++++++- generic/tclBinary.c | 25 +++++++++++++++++++------ tests/binary.test | 17 ++++------------- 3 files changed, 31 insertions(+), 20 deletions(-) diff --git a/doc/binary.n b/doc/binary.n index 95be36e..9f22fb1 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -64,7 +64,7 @@ Indicates that the output should be split into lines of no more than . Indicates that, when lines are split because of the \fB\-maxlen\fR option, \fIcharacter\fR should be used to separate lines. By default, this is a -newline character, +newline character. .QW \en . .PP During decoding, the following options are supported: @@ -102,6 +102,13 @@ During encoding, the following options are supported: Indicates that the output should be split into lines of no more than \fIlength\fR characters. By default, lines are split every 61 characters, and this must be in the range 3 to 85 due to limitations in the encoding. +.TP +\fB\-wrapchar \fIcharacter\fR +. +Indicates that, when lines are split because of the \fB\-maxlen\fR option, +\fIcharacter\fR should be used to separate lines. By default, this is a +newline character. +.QW \en . .PP During decoding, the following options are supported: .TP diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 71da309..98a4d31 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2584,13 +2584,15 @@ BinaryEncodeUu( { Tcl_Obj *resultObj; unsigned char *data, *start, *cursor; - int offset, count, rawLength, n, i, bits, index; + int offset, count, rawLength, n, i, j, bits, index; int lineLength = 61; - enum {OPT_MAXLEN}; - static const char *const optStrings[] = { "-maxlen", NULL }; + const char *wrapchar = "\n"; + int wrapcharlen = 1; + enum {OPT_MAXLEN, OPT_WRAPCHAR }; + static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; if (objc < 2 || objc%2 != 0) { - Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? ?-wrapchar char? data"); return TCL_ERROR; } for (i = 1; i < objc-1; i += 2) { @@ -2610,6 +2612,15 @@ BinaryEncodeUu( return TCL_ERROR; } break; + case OPT_WRAPCHAR: + wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); + if (wrapcharlen < 0 || wrapcharlen > 2) { + Tcl_SetResult(interp, "wrap char out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "WRAP_CHAR", NULL); + return TCL_ERROR; + } + break; } } @@ -2623,7 +2634,7 @@ BinaryEncodeUu( data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); rawLength = (lineLength - 1) * 3 / 4; start = cursor = Tcl_SetByteArrayLength(resultObj, - (lineLength + 1) * ((count + (rawLength - 1)) / rawLength)); + (lineLength + wrapcharlen) * ((count + (rawLength - 1)) / rawLength)); n = bits = 0; /* @@ -2652,7 +2663,9 @@ BinaryEncodeUu( *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f]; bits = 0; } - *cursor++ = '\n'; + for (j=0; j Date: Sat, 14 Sep 2013 08:59:41 +0000 Subject: Hm, this check doesn't really add anything. --- generic/tclBinary.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 98a4d31..69f5baf 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2614,12 +2614,6 @@ BinaryEncodeUu( break; case OPT_WRAPCHAR: wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); - if (wrapcharlen < 0 || wrapcharlen > 2) { - Tcl_SetResult(interp, "wrap char out of range", TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", - "WRAP_CHAR", NULL); - return TCL_ERROR; - } break; } } -- cgit v0.12 From bfe331b12ab628579f7505c776804ff2e7e1fcad Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 14 Sep 2013 18:25:45 +0000 Subject: And the decoder too. --- doc/binary.n | 2 +- generic/tclBinary.c | 104 +++++++++++++++++++++++++++++++++++++++++++--------- tests/binary.test | 41 +++++++++++---------- 3 files changed, 109 insertions(+), 38 deletions(-) diff --git a/doc/binary.n b/doc/binary.n index 95be36e..b301f4d 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -107,7 +107,7 @@ During decoding, the following options are supported: .TP \fB\-strict\fR . -Instructs the decoder to throw an error if it encounters whitespace +Instructs the decoder to throw an error if it encounters unexpected whitespace characters. Otherwise it ignores them. .PP Note that neither the encoder nor the decoder handle the header and footer of diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 71da309..c0dd926 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2690,8 +2690,8 @@ BinaryDecodeUu( Tcl_Obj *resultObj = NULL; unsigned char *data, *datastart, *dataend; unsigned char *begin, *cursor; - int i, index, size, count = 0, cut = 0, strict = 0; - char c; + int i, index, size, count = 0, strict = 0, lineLen; + unsigned char c; enum {OPT_STRICT }; static const char *const optStrings[] = { "-strict", NULL }; @@ -2717,44 +2717,112 @@ BinaryDecodeUu( dataend = data + count; size = ((count + 3) & ~3) * 3 / 4; begin = cursor = Tcl_SetByteArrayLength(resultObj, size); + lineLen = -1; + + /* + * The decoding loop. First, we get the length of line (strictly, the + * number of data bytes we expect to generate from the line) we're + * processing this time round if it is not already known (i.e., when the + * lineLen variable is set to the magic value, -1). + */ + while (data < dataend) { char d[4] = {0, 0, 0, 0}; + if (lineLen < 0) { + c = *data++; + if (c < 32 || c > 96) { + if (strict || !isspace(c)) { + goto badUu; + } + i--; + continue; + } + lineLen = (c - 32) & 0x3f; + } + + /* + * Now we read a four-character grouping. + */ + for (i=0 ; i<4 ; i++) { if (data < dataend) { d[i] = c = *data++; - if (c < 33 || c > 96) { - if (strict || !isspace(UCHAR(c))) { - goto badUu; + if (c < 32 || c > 96) { + if (strict) { + if (!isspace(c)) { + goto badUu; + } else if (c == '\n') { + goto shortUu; + } } i--; continue; } - } else { - cut++; } } - if (cut > 3) { - cut = 3; + + /* + * Translate that grouping into (up to) three binary bytes output. + */ + + if (lineLen > 0) { + *cursor++ = (((d[0] - 0x20) & 0x3f) << 2) + | (((d[1] - 0x20) & 0x3f) >> 4); + if (--lineLen > 0) { + *cursor++ = (((d[1] - 0x20) & 0x3f) << 4) + | (((d[2] - 0x20) & 0x3f) >> 2); + if (--lineLen > 0) { + *cursor++ = (((d[2] - 0x20) & 0x3f) << 6) + | (((d[3] - 0x20) & 0x3f)); + lineLen--; + } + } + } + + /* + * If we've reached the end of the line, skip until we process a + * newline. + */ + + if (lineLen == 0 && data < dataend) { + lineLen = -1; + do { + c = *data++; + if (c == '\n') { + break; + } else if (c >= 32 && c <= 96) { + data--; + break; + } else if (strict || !isspace(c)) { + goto badUu; + } + } while (data < dataend); } - *cursor++ = (((d[0] - 0x20) & 0x3f) << 2) - | (((d[1] - 0x20) & 0x3f) >> 4); - *cursor++ = (((d[1] - 0x20) & 0x3f) << 4) - | (((d[2] - 0x20) & 0x3f) >> 2); - *cursor++ = (((d[2] - 0x20) & 0x3f) << 6) - | (((d[3] - 0x20) & 0x3f)); } - if (cut > size) { - cut = size; + + /* + * Sanity check, clean up and finish. + */ + + if (lineLen > 0 && strict) { + goto shortUu; } - Tcl_SetByteArrayLength(resultObj, cursor - begin - cut); + Tcl_SetByteArrayLength(resultObj, cursor - begin); Tcl_SetObjResult(interp, resultObj); return TCL_OK; + shortUu: + Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data")); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL); + TclDecrRefCount(resultObj); + return TCL_ERROR; + badUu: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid uuencode character \"%c\" at position %d", c, (int) (data - datastart - 1))); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); TclDecrRefCount(resultObj); return TCL_ERROR; } diff --git a/tests/binary.test b/tests/binary.test index 4b71b77..607a070 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2755,72 +2755,75 @@ test binary-75.1 {binary decode uuencode} -body { binary decode uuencode } -returnCodes error -match glob -result "wrong # args: *" test binary-75.2 {binary decode uuencode} -body { - binary decode uuencode 86)C + binary decode uuencode "#86)C\n" } -result {abc} test binary-75.3 {binary decode uuencode} -body { binary decode uuencode {} } -result {} +test binary-75.3.1 {binary decode uuencode} -body { + binary decode uuencode `\n +} -result {} test binary-75.4 {binary decode uuencode} -body { - binary decode uuencode [string repeat "86)C" 20] + binary decode uuencode "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" } -result [string repeat abc 20] test binary-75.5 {binary decode uuencode} -body { - binary decode uuencode "``\$\"`P0``0(#" + binary decode uuencode ")``\$\"`P0``0(#" } -result "\0\1\2\3\4\0\1\2\3" test binary-75.6 {binary decode uuencode} -body { - string length [binary decode uuencode {`}] + string length [binary decode uuencode "`\n"] } -result 0 test binary-75.7 {binary decode uuencode} -body { - string length [binary decode uuencode {``}] + string length [binary decode uuencode "!`\n"] } -result 1 test binary-75.8 {binary decode uuencode} -body { - string length [binary decode uuencode {```}] + string length [binary decode uuencode "\"``\n"] } -result 2 test binary-75.9 {binary decode uuencode} -body { - string length [binary decode uuencode {````}] + string length [binary decode uuencode "#```\n"] } -result 3 test binary-75.10 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n[string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\n>[string repeat 86)C 10]" binary decode uuencode $s } -result [string repeat abc 20] test binary-75.11 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n [string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\n\t>\t[string repeat 86)C 10]\r" binary decode uuencode $s } -result [string repeat abc 20] test binary-75.12 {binary decode uuencode} -body { binary decode uuencode -strict "|86)C" } -returnCodes error -match glob -result {invalid uuencode character "|" at position 0} test binary-75.13 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]|[string repeat 86)C 10]" + set s ">[string repeat 86)C 10]|[string repeat 86)C 10]" binary decode uuencode -strict $s -} -returnCodes error -match glob -result {invalid uuencode character "|" at position 40} +} -returnCodes error -match glob -result {invalid uuencode character "|" at position 41} test binary-75.14 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n [string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\na[string repeat 86)C 10]" binary decode uuencode -strict $s } -returnCodes error -match glob -result {invalid uuencode character *} test binary-75.20 {binary decode uuencode} -body { - set r [binary decode uuencode 8] + set r [binary decode uuencode " 8"] list [string length $r] $r } -result {0 {}} test binary-75.21 {binary decode uuencode} -body { - set r [binary decode uuencode 86] + set r [binary decode uuencode "!86"] list [string length $r] $r } -result {1 a} test binary-75.22 {binary decode uuencode} -body { - set r [binary decode uuencode 86)] + set r [binary decode uuencode "\"86)"] list [string length $r] $r } -result {2 ab} test binary-75.23 {binary decode uuencode} -body { - set r [binary decode uuencode 86)C] + set r [binary decode uuencode "#86)C"] list [string length $r] $r } -result {3 abc} test binary-75.24 {binary decode uuencode} -body { - set s "04)\# " + set s "#04)\# " binary decode uuencode $s } -result ABC test binary-75.25 {binary decode uuencode} -body { - set s "04)\#z" + set s "#04)\#z" binary decode uuencode $s -} -returnCodes error -match glob -result {invalid uuencode character "z" at position 4} +} -returnCodes error -match glob -result {invalid uuencode character "z" at position 5} test binary-75.26 {binary decode uuencode} -body { string length [binary decode uuencode " "] } -result 0 -- cgit v0.12 From eee6883d2afb2f3a4784208da88dfa7fc5aa420f Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 16 Sep 2013 08:52:12 +0000 Subject: Be careful: separator needs to be bytes, not internal-encoded. --- generic/tclBinary.c | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 2053319..114984f 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2586,13 +2586,15 @@ BinaryEncodeUu( unsigned char *data, *start, *cursor; int offset, count, rawLength, n, i, j, bits, index; int lineLength = 61; - const char *wrapchar = "\n"; - int wrapcharlen = 1; - enum {OPT_MAXLEN, OPT_WRAPCHAR }; + const unsigned char SingleNewline[] = { (unsigned char) '\n' }; + const unsigned char *wrapchar = SingleNewline; + int wrapcharlen = sizeof(SingleNewline); + enum { OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; if (objc < 2 || objc%2 != 0) { - Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? ?-wrapchar char? data"); + Tcl_WrongNumArgs(interp, 1, objv, + "?-maxlen len? ?-wrapchar char? data"); return TCL_ERROR; } for (i = 1; i < objc-1; i += 2) { @@ -2613,7 +2615,7 @@ BinaryEncodeUu( } break; case OPT_WRAPCHAR: - wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); + wrapchar = Tcl_GetByteArrayFromObj(objv[i+1], &wrapcharlen); break; } } @@ -2628,7 +2630,8 @@ BinaryEncodeUu( data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); rawLength = (lineLength - 1) * 3 / 4; start = cursor = Tcl_SetByteArrayLength(resultObj, - (lineLength + wrapcharlen) * ((count + (rawLength - 1)) / rawLength)); + (lineLength + wrapcharlen) * + ((count + (rawLength - 1)) / rawLength)); n = bits = 0; /* @@ -2657,7 +2660,7 @@ BinaryEncodeUu( *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f]; bits = 0; } - for (j=0; j Date: Mon, 16 Sep 2013 09:03:50 +0000 Subject: Refactor to remove unused flexibility. --- generic/tclBinary.c | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 114984f..58583f4 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -142,9 +142,9 @@ static const EnsembleImplMap binaryMap[] = { { NULL, NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap encodeMap[] = { - { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, (ClientData)HexDigits, 0 }, + { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, { "uuencode", BinaryEncodeUu, NULL, NULL, NULL, 0 }, - { "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 }, + { "base64", BinaryEncode64, NULL, NULL, NULL, 0 }, { NULL, NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap decodeMap[] = { @@ -2315,7 +2315,6 @@ BinaryEncodeHex( Tcl_Obj *resultObj = NULL; unsigned char *data = NULL; unsigned char *cursor = NULL; - const char *digits = clientData; int offset = 0, count = 0; if (objc != 2) { @@ -2327,8 +2326,8 @@ BinaryEncodeHex( data = Tcl_GetByteArrayFromObj(objv[1], &count); cursor = Tcl_SetByteArrayLength(resultObj, count * 2); for (offset = 0; offset < count; ++offset) { - *cursor++ = digits[((data[offset] >> 4) & 0x0f)]; - *cursor++ = digits[(data[offset] & 0x0f)]; + *cursor++ = HexDigits[((data[offset] >> 4) & 0x0f)]; + *cursor++ = HexDigits[(data[offset] & 0x0f)]; } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -2478,7 +2477,6 @@ BinaryEncode64( { Tcl_Obj *resultObj; unsigned char *data, *cursor, *limit; - const char *digits = clientData; int maxlen = 0; const char *wrapchar = "\n"; int wrapcharlen = 1; @@ -2537,17 +2535,17 @@ BinaryEncode64( for (i = 0; i < 3 && offset+i < count; ++i) { d[i] = data[offset + i]; } - OUTPUT(digits[d[0] >> 2]); - OUTPUT(digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]); + OUTPUT(B64Digits[d[0] >> 2]); + OUTPUT(B64Digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]); if (offset+1 < count) { - OUTPUT(digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]); + OUTPUT(B64Digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]); } else { - OUTPUT(digits[64]); + OUTPUT(B64Digits[64]); } if (offset+2 < count) { - OUTPUT(digits[d[2] & 0x3f]); + OUTPUT(B64Digits[d[2] & 0x3f]); } else { - OUTPUT(digits[64]); + OUTPUT(B64Digits[64]); } } } -- cgit v0.12 From 3146ffb96b37ad7490c5b7dba5ccf482275882ba Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 16 Sep 2013 23:18:54 +0000 Subject: [7b32d8d13b] Insert missing field initialization. --- generic/tclAssembly.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 100e9ef..946c729 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -2617,6 +2617,7 @@ AllocBB( bb->minStackDepth = 0; bb->maxStackDepth = 0; bb->finalStackDepth = 0; + bb->catchDepth = 0; bb->enclosingCatch = NULL; bb->foreignExceptionBase = -1; bb->foreignExceptionCount = 0; -- cgit v0.12 From 649d0983f9491954791d5a3ff10364d807f9becf Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 17 Sep 2013 09:13:40 +0000 Subject: small improvements to the documentation --- doc/binary.n | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/doc/binary.n b/doc/binary.n index 0cdf465..cbbebd1 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -36,6 +36,13 @@ The \fBbinary encode\fR and \fBbinary decode\fR subcommands convert binary data to or from string encodings such as base64 (used in MIME messages for example). .VE 8.6 +.PP +Note that other operations on binary data, such as taking a subsequence of it, +getting its length, or reinterpreting it as a string in some encoding, are +done by other Tcl commands (respectively \fBstring range\fR, +\fBstring length\fR and \fBencoding convertfrom\fR in the example cases). A +binary string in Tcl is merely one where all the characters it contains are in +the range \eu0000\-\eu00FF. .SH "BINARY ENCODE AND DECODE" .VS 8.6 .PP @@ -64,7 +71,7 @@ Indicates that the output should be split into lines of no more than . Indicates that, when lines are split because of the \fB\-maxlen\fR option, \fIcharacter\fR should be used to separate lines. By default, this is a -newline character. +newline character, .QW \en . .PP During decoding, the following options are supported: @@ -95,7 +102,8 @@ between Unix systems and on USENET, but is less common these days, having been largely superseded by the \fBbase64\fR binary encoding. .RS .PP -During encoding, the following options are supported: +During encoding, the following options are supported (though changing them may +produce files that other implementations of decoders cannot process): .TP \fB\-maxlen \fIlength\fR . @@ -107,7 +115,7 @@ this must be in the range 3 to 85 due to limitations in the encoding. . Indicates that, when lines are split because of the \fB\-maxlen\fR option, \fIcharacter\fR should be used to separate lines. By default, this is a -newline character. +newline character, .QW \en . .PP During decoding, the following options are supported: @@ -859,6 +867,7 @@ architectures, use their textual representation (as produced by .PP This is a procedure to write a Tcl string to a binary-encoded channel as UTF-8 data preceded by a length word: +.PP .CS proc \fIwriteString\fR {channel string} { set data [encoding convertto utf-8 $string] @@ -869,6 +878,7 @@ proc \fIwriteString\fR {channel string} { .PP This procedure reads a string from a channel that was written by the previously presented \fIwriteString\fR procedure: +.PP .CS proc \fIreadString\fR {channel} { if {![\fBbinary scan\fR [read $channel 4] I length]} { @@ -881,6 +891,7 @@ proc \fIreadString\fR {channel} { .PP This converts the contents of a file (named in the variable \fIfilename\fR) to base64 and prints them: +.PP .CS set f [open $filename rb] set data [read $f] @@ -888,9 +899,10 @@ close $f puts [\fBbinary encode\fR base64 \-maxlen 64 $data] .CE .SH "SEE ALSO" -format(n), scan(n), tcl_platform(n) +encoding(n), format(n), scan(n), string(n), tcl_platform(n) .SH KEYWORDS binary, format, scan '\" Local Variables: '\" mode: nroff +'\" fill-column: 78 '\" End: -- cgit v0.12 From debbae5fd9e53fb7ad6958a27331c77ab7ebc215 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 17 Sep 2013 09:20:58 +0000 Subject: ChangeLog entry --- ChangeLog | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/ChangeLog b/ChangeLog index 8e1a8b9..eaa5fc8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +2013-09-17 Donal Fellows + + * generic/tclBinary.c (BinaryEncodeUu, BinaryDecodeUu): [Bug 2152292]: + Corrected implementation of the core of uuencode handling so that the + line length processing is correctly applied. + ***POTENTIAL INCOMPATIBILITY*** + Existing code that was using the old versions and working around the + limitations will now need to do far less. The -maxlen option now has + strict limits on the range of supported lengths; this is a limitation + of the format itself. + 2013-09-09 Donal Fellows * generic/tclOOMethod.c (CloneProcedureMethod): [Bug 3609693]: Strip -- cgit v0.12 From a2df72aecb12eefacae9be3771ea67651024d645 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 18 Sep 2013 12:32:26 +0000 Subject: Bump TclOO version to 1.0.1 --- ChangeLog | 25 +++++++++++++++---------- generic/tclOO.h | 2 +- generic/tclOOBasic.c | 2 +- generic/tclOODefineCmds.c | 2 +- tests/oo.test | 4 ++-- tests/ooNext2.test | 2 +- unix/tclooConfig.sh | 2 +- win/tclooConfig.sh | 2 +- 8 files changed, 23 insertions(+), 18 deletions(-) diff --git a/ChangeLog b/ChangeLog index eaa5fc8..3dc8c5e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,8 @@ -2013-09-17 Donal Fellows +2013-09-18 Donal Fellows + + Bump TclOO version to 1.0.1 for release. + +2013-09-17 Donal Fellows * generic/tclBinary.c (BinaryEncodeUu, BinaryDecodeUu): [Bug 2152292]: Corrected implementation of the core of uuencode handling so that the @@ -59,12 +63,13 @@ 2013-06-27 Jan Nijtmans - * generic/tclConfig.c: Bug [9b2e636361]: Tcl_CreateInterp() needs initialized - * generic/tclMain.c: encodings. + * generic/tclConfig.c: Bug [9b2e636361]: Tcl_CreateInterp() needs + * generic/tclMain.c: initialized encodings. 2013-06-18 Jan Nijtmans - * generic/tclEvent.c: Bug [3611974]: InitSubsystems multiple thread issue. + * generic/tclEvent.c: Bug [3611974]: InitSubsystems multiple thread + issue. 2013-06-17 Jan Nijtmans @@ -176,10 +181,10 @@ * generic/tclStubInit.c: Add support for Cygwin64, which has a 64-bit * generic/tclDecls.h: "long" type. Binary compatibility with win64 - requires that all stub entries use 32-bit long's, therefore the - need for various wrapper functions/macros. For Tcl 9 a better - solution is needed, but that cannot be done without introducing - binary incompatibility. + requires that all stub entries use 32-bit long's, therefore the need + for various wrapper functions/macros. For Tcl 9 a better solution is + needed, but that cannot be done without introducing binary + incompatibility. 2013-04-30 Andreas Kupries @@ -197,8 +202,8 @@ * generic/tclDecls.h: Implement Tcl_NewBooleanObj, Tcl_DbNewBooleanObj and Tcl_SetBooleanObj as macros using Tcl_NewIntObj, Tcl_DbNewLongObj - and Tcl_SetIntObj. Starting with Tcl 8.5, this is exactly the same, - it only eliminates code duplication. + and Tcl_SetIntObj. Starting with Tcl 8.5, this is exactly the same, it + only eliminates code duplication. * generic/tclInt.h: Eliminate use of NO_WIDE_TYPE everywhere: It's exactly the same as TCL_WIDE_INT_IS_LONG diff --git a/generic/tclOO.h b/generic/tclOO.h index cf253b1..d5ab8a0 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -39,7 +39,7 @@ extern const char *TclOOInitializeStubs( * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.0" +#define TCLOO_VERSION "1.0.1" #define TCLOO_PATCHLEVEL TCLOO_VERSION /* diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index aba06a5..853e2ec 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -4,7 +4,7 @@ * This file contains implementations of the "simple" commands and * methods from the object-system core. * - * Copyright (c) 2005-2012 by Donal K. Fellows + * Copyright (c) 2005-2013 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index f0983cc..5a6c0ad 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2012 by Donal K. Fellows + * Copyright (c) 2006-2013 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tests/oo.test b/tests/oo.test index 054bc46..37bbadb 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2,12 +2,12 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 2006-2012 Donal K. Fellows +# Copyright (c) 2006-2013 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0 +package require TclOO 1.0.1 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/tests/ooNext2.test b/tests/ooNext2.test index d77e8d1..a47aa91 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0 +package require TclOO 1.0.1 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh index 721825b..08cc4c5 100644 --- a/unix/tclooConfig.sh +++ b/unix/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.0 +TCLOO_VERSION=1.0.1 diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh index 721825b..08cc4c5 100644 --- a/win/tclooConfig.sh +++ b/win/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.0 +TCLOO_VERSION=1.0.1 -- cgit v0.12 From 7bc81bcbb076abbcd5fc6803a99673d8a192e4cf Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 04:03:57 +0000 Subject: [3487626] Backport fix for knownBug test dict-23.2. --- generic/tclCompCmds.c | 7 +++++++ tests/dict.test | 2 +- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index b6e9527..f96470d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -6149,6 +6149,7 @@ TclCompileEnsemble( Tcl_Parse synthetic; int len, numBytes, result, flags = 0, i; const char *word; + DefineLineInformation; if (parsePtr->numWords < 2) { return TCL_ERROR; @@ -6388,8 +6389,14 @@ TclCompileEnsemble( * Hand off compilation to the subcommand compiler. At last! */ + mapPtr->loc[eclIndex].line++; + mapPtr->loc[eclIndex].next++; + result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); + mapPtr->loc[eclIndex].line--; + mapPtr->loc[eclIndex].next--; + /* * Clean up if necessary. */ diff --git a/tests/dict.test b/tests/dict.test index b92893e..a673957 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1212,7 +1212,7 @@ test dict-23.1 {dict compilation crash: Bug 3487626} { } }} [linenumber] } 5 -test dict-23.2 {dict compilation crash: Bug 3487626} knownBug { +test dict-23.2 {dict compilation crash: Bug 3487626} { # Something isn't quite right in line number and continuation line # tracking; at time of writing, this test produces 7, not 5, which # indicates that the extra newlines in the non-script argument are -- cgit v0.12 From 3204893f0915b8e1013dc77a8c814387be63811b Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 04:11:01 +0000 Subject: [3487626] knownBug tests dict-23.2 and dist-24.21 already fixed on trunk. --- tests/dict.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/dict.test b/tests/dict.test index 02c9050..e898637 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1604,7 +1604,7 @@ test dict-23.1 {dict compilation crash: Bug 3487626} { } }} [linenumber]}} } 5 -test dict-23.2 {dict compilation crash: Bug 3487626} knownBug { +test dict-23.2 {dict compilation crash: Bug 3487626} { # Something isn't quite right in line number and continuation line # tracking; at time of writing, this test produces 7, not 5, which # indicates that the extra newlines in the non-script argument are @@ -1838,7 +1838,7 @@ test dict-24.20.1 {dict compilation crash: 'dict for' bug 3487626} { } }} [linenumber]}} } 5 -test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} knownBug { +test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} { apply {{} {apply {n { set e {} set k {} -- cgit v0.12 From 134ada8ff9b267a2efc8c862474d79c92d36019c Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 04:20:53 +0000 Subject: Stop segfault due to OBOE in CompileWord() calls in [dict lappend] compiler. --- generic/tclCompCmds.c | 4 ++-- tests/dict.test | 6 ++++++ 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index f96470d..fa4762d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1313,8 +1313,8 @@ TclCompileDictLappendCmd( return TCL_ERROR; } dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr); - CompileWord(envPtr, keyTokenPtr, interp, 3); - CompileWord(envPtr, valueTokenPtr, interp, 4); + CompileWord(envPtr, keyTokenPtr, interp, 2); + CompileWord(envPtr, valueTokenPtr, interp, 3); TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); return TCL_OK; } diff --git a/tests/dict.test b/tests/dict.test index a673957..6271779 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1243,6 +1243,12 @@ j } }} [linenumber] } 5 +test dict-23.3 {CompileWord OBOE} { + # segfault when buggy + apply {{} {tcl::dict::lappend foo bar \ + [format baz]}} +} {bar baz} + rename linenumber {} # cleanup -- cgit v0.12 From a414da9341799e7ed149df1964392b02142a3314 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 12:20:13 +0000 Subject: Line numbers wrong in compiled foreach body. --- generic/tclCompCmds.c | 6 ++---- tests/foreach.test | 11 +++++++++++ 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index fa4762d..2013568 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1628,7 +1628,7 @@ TclCompileForeachCmd( Tcl_Token *tokenPtr, *bodyTokenPtr; unsigned char *jumpPc; JumpFixup jumpFalseFixup; - int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex; + int jumpBackDist, jumpBackOffset, infoIndex, range; int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; int savedStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ @@ -1669,8 +1669,6 @@ TclCompileForeachCmd( return TCL_ERROR; } - bodyIndex = i-1; - /* * Allocate storage for the varcList and varvList arrays if necessary. */ @@ -1837,7 +1835,7 @@ TclCompileForeachCmd( * Inline compile the loop body. */ - SetLineInformation (bodyIndex); + SetLineInformation (numWords - 1); ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); diff --git a/tests/foreach.test b/tests/foreach.test index 7df7481..ac7a279 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -254,6 +254,17 @@ test foreach-9.1 {compiled empty var list} { list [catch { foo } msg] $msg } {1 {foreach varlist is empty}} +test foreach-9.2 {line numbers} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + foreach x y {*}{ + } {return [incr n -[linenumber]]} + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + test foreach-10.1 {foreach: [Bug 1671087]} -setup { proc demo {} { set vals {1 2 3 4} -- cgit v0.12 From ad07565ec073b413895d29fa06f19a63b39aa83e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 19 Sep 2013 12:37:13 +0000 Subject: consistant use of capitals. --- win/Makefile.in | 8 ++++---- win/makefile.bc | 28 ++++++++++++++-------------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/win/Makefile.in b/win/Makefile.in index 235313f..6748f1b 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -586,23 +586,23 @@ install-binaries: binaries fi; \ done @if [ -f $(DDE_DLL_FILE) ]; then \ - echo installing $(DDE_DLL_FILE); \ + echo Installing $(DDE_DLL_FILE); \ $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \ $(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \ $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \ fi @if [ -f $(DDE_LIB_FILE) ]; then \ - echo installing $(DDE_LIB_FILE); \ + echo Installing $(DDE_LIB_FILE); \ $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \ fi @if [ -f $(REG_DLL_FILE) ]; then \ - echo installing $(REG_DLL_FILE); \ + echo Installing $(REG_DLL_FILE); \ $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \ $(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \ $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \ fi @if [ -f $(REG_LIB_FILE) ]; then \ - echo installing $(REG_LIB_FILE); \ + echo Installing $(REG_LIB_FILE); \ $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \ fi diff --git a/win/makefile.bc b/win/makefile.bc index 07b2333..3310b01 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -402,57 +402,57 @@ $(CAT32): $(WINDIR)\cat.c install-binaries: $(TCLSH) $(MKDIR) "$(BIN_INSTALL_DIR)" $(MKDIR) "$(LIB_INSTALL_DIR)" - @echo installing $(TCLDLLNAME) + @echo Installing $(TCLDLLNAME) @copy "$(TCLDLL)" "$(BIN_INSTALL_DIR)" @copy "$(TCLLIB)" "$(LIB_INSTALL_DIR)" - @echo installing "$(TCLSH)" + @echo Installing "$(TCLSH)" @copy "$(TCLSH)" "$(BIN_INSTALL_DIR)" - @echo installing $(TCLPIPEDLLNAME) + @echo Installing $(TCLPIPEDLLNAME) @copy "$(TCLPIPEDLL)" "$(BIN_INSTALL_DIR)" - @echo installing $(TCLSTUBLIBNAME) + @echo Installing $(TCLSTUBLIBNAME) @copy "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)" install-libraries: -@$(MKDIR) "$(LIB_INSTALL_DIR)" -@$(MKDIR) "$(INCLUDE_INSTALL_DIR)" -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)" - @echo installing http1.0 + @echo Installing http1.0 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0" -@copy "$(ROOT)\library\http1.0\http.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0" -@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0" - @echo installing http2.7 + @echo Installing http2.7 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.7" -@copy "$(ROOT)\library\http\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.7" -@copy "$(ROOT)\library\http\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.7" - @echo installing opt0.4 + @echo Installing opt0.4 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4" -@copy "$(ROOT)\library\opt\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" -@copy "$(ROOT)\library\opt\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" - @echo installing msgcat1.5 + @echo Installing msgcat1.5 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.5" -@copy "$(ROOT)\library\msgcat\msgcat.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5" -@copy "$(ROOT)\library\msgcat\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5" - @echo installing tcltest2.3 + @echo Installing tcltest2.3 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\tcltest2.3" -@copy "$(ROOT)\library\tcltest\tcltest.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3" -@copy "$(ROOT)\library\tcltest\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3" - @echo installing platform1.0 + @echo Installing platform1.0 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\platform1.0" -@copy "$(ROOT)\library\platform\platform.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0" -@copy "$(ROOT)\library\platform\shell.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0" -@copy "$(ROOT)\library\platform\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0" - @echo installing $(TCLDDEDLLNAME) + @echo Installing $(TCLDDEDLLNAME) -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\dde1.3" -@copy "$(TCLDDEDLL)" "$(SCRIPT_INSTALL_DIR)\dde1.3" -@copy "$(ROOT)\library\dde\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\dde1.3" - @echo installing $(TCLREGDLLNAME) + @echo Installing $(TCLREGDLLNAME) -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\reg1.2" -@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.2" -@copy "$(ROOT)\library\reg\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\reg1.2" - @echo installing encoding files + @echo Installing encoding files -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\encoding" -@copy "$(ROOT)\library\encoding\*.enc" "$(SCRIPT_INSTALL_DIR)\encoding" - @echo installing library files + @echo Installing library files -@copy "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)" -@copy "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)" -@copy "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)" -- cgit v0.12 From 1b0845930c4443b53093d14ad56bf2d932ec40b2 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 13:06:06 +0000 Subject: Line numbers wrong in compiled [dict set]. --- generic/tclCompCmds.c | 8 +++----- tests/dict.test | 6 ++++++ 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 2013568..260bd28 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -683,11 +683,10 @@ TclCompileDictSetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; Proc *procPtr = envPtr->procPtr; DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; - int dictVarIndex, nameChars; + int i, dictVarIndex, nameChars; const char *name; /* @@ -720,8 +719,7 @@ TclCompileDictSetCmd( */ tokenPtr = TokenAfter(varTokenPtr); - numWords = parsePtr->numWords-1; - for (i=1 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -730,7 +728,7 @@ TclCompileDictSetCmd( * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr); + TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; } diff --git a/tests/dict.test b/tests/dict.test index 6271779..83f1ca7 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1248,6 +1248,12 @@ test dict-23.3 {CompileWord OBOE} { apply {{} {tcl::dict::lappend foo bar \ [format baz]}} } {bar baz} +test dict-23.4 {CompileWord OBOE} { + apply {n { + dict set foo {*}{ + } [return [incr n -[linenumber]]] val + }} [linenumber] +} 1 rename linenumber {} -- cgit v0.12 From 4a2c3b6440015a638c1bb94da6d04620c797f12d Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 13:39:40 +0000 Subject: [31661d2135] Plug memory leak. --- generic/tclExecute.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e402634..4d7bdd5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4327,7 +4327,7 @@ TEBCresume( if (listPtr->refCount == 1) { TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5))); - for (index=toIdx+1 ; indexelemCount = toIdx+1; -- cgit v0.12 From 657b49a9d1d82445fd0b53afacf3077ef9d1c1eb Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 14:06:46 +0000 Subject: Stop segfault due to OBOE in CompileWord() calls in [dict incr] compiler. --- generic/tclCompCmds.c | 2 +- tests/dict.test | 5 +++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 260bd28..3445c09 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -806,7 +806,7 @@ TclCompileDictIncrCmd( * Emit the key and the code to actually do the increment. */ - CompileWord(envPtr, keyTokenPtr, interp, 3); + CompileWord(envPtr, keyTokenPtr, interp, 2); TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; diff --git a/tests/dict.test b/tests/dict.test index 83f1ca7..fec000d 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1254,6 +1254,11 @@ test dict-23.4 {CompileWord OBOE} { } [return [incr n -[linenumber]]] val }} [linenumber] } 1 +test dict-23.5 {CompileWord OBOE} { + # segfault when buggy + apply {{} {tcl::dict::incr foo \ + [format bar]}} +} {bar 1} rename linenumber {} -- cgit v0.12 From 5aee161167696db6b88db2b42a0d8963bb1cda6a Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 19 Sep 2013 14:21:21 +0000 Subject: [3606943]: Corrected description of method search order. --- ChangeLog | 5 +++++ doc/next.n | 11 +++++++---- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index 3dc8c5e..b144110 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2013-09-19 Donal Fellows + + * doc/next.n (METHOD SEARCH ORDER): Bug [3606943]: Corrected + description of method search order. + 2013-09-18 Donal Fellows Bump TclOO version to 1.0.1 for release. diff --git a/doc/next.n b/doc/next.n index 0ad752a..fe7bddf 100644 --- a/doc/next.n +++ b/doc/next.n @@ -62,14 +62,14 @@ The method chain is cached for future use. When constructing the method chain, method implementations are searched for in the following order: .IP [1] -In the object. -.IP [2] In the classes mixed into the object, in class traversal order. The list of mixins is checked in natural order. -.IP [3] +.IP [2] In the classes mixed into the classes of the object, with sources of mixing in being searched in class traversal order. Within each class, the list of mixins is processed in natural order. +.IP [3] +In the object itself. .IP [4] In the object's class. .IP [5] @@ -77,7 +77,10 @@ In the superclasses of the class, following each superclass in a depth-first fashion in the natural order of the superclass list. .PP Any particular method implementation always comes as \fIlate\fR in the -resulting list of implementations as possible. +resulting list of implementations as possible; this means that if some class, +A, is both mixed into a class, B, and is also a superclass of B, the instances +of B will always treat A as a superclass from the perspective of inheritance. +This is true even when the multiple inheritance is processed indirectly. .SS FILTERS .PP When an object has a list of filter names set upon it, or is an instance of a -- cgit v0.12 From cb5d76ed2b76f22cd7c3cf4f41ac3ef0a0f030df Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 14:48:02 +0000 Subject: Line numbers wrong in compiled [dict get]. --- generic/tclCompCmds.c | 7 +++---- tests/dict.test | 6 ++++++ 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 3445c09..efb7ff2 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -822,7 +822,7 @@ TclCompileDictGetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; + int i; DefineLineInformation; /* TIP #280 */ /* @@ -834,17 +834,16 @@ TclCompileDictGetCmd( return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - numWords = parsePtr->numWords-1; /* * Only compile this because we need INST_DICT_GET anyway. */ - for (i=0 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr); + TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr); return TCL_OK; } diff --git a/tests/dict.test b/tests/dict.test index fec000d..149599b 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1259,6 +1259,12 @@ test dict-23.5 {CompileWord OBOE} { apply {{} {tcl::dict::incr foo \ [format bar]}} } {bar 1} +test dict-23.6 {CompileWord OBOE} { + apply {n { + dict get {a b} {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} 1 rename linenumber {} -- cgit v0.12 From 7887926261176ebf53677f83fa051cb4cfcc2cf7 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 14:55:05 +0000 Subject: Line numbers wrong in compiled [dict for]. --- generic/tclCompCmds.c | 2 +- tests/dict.test | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index efb7ff2..348910c 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -934,7 +934,7 @@ TclCompileDictForCmd( * errors at this point. */ - CompileWord(envPtr, dictTokenPtr, interp, 3); + CompileWord(envPtr, dictTokenPtr, interp, 2); TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); emptyTargetOffset = CurrentOffset(envPtr); TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); diff --git a/tests/dict.test b/tests/dict.test index 149599b..bd7b920 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1265,6 +1265,12 @@ test dict-23.6 {CompileWord OBOE} { } [return [incr n -[linenumber]]] }} [linenumber] } 1 +test dict-23.7 {CompileWord OBOE} { + apply {n { + dict for {a b} [return [incr n -[linenumber]]] {*}{ + } {} + }} [linenumber] +} 2 rename linenumber {} -- cgit v0.12 From e4dfb0d689c07715c52b1a8b95391e5af075c02f Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 15:04:47 +0000 Subject: Line numbers wrong in compiled [dict update]. --- generic/tclCompCmds.c | 2 +- tests/dict.test | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 348910c..51a566e 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1159,7 +1159,7 @@ TclCompileDictUpdateCmd( infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr); for (i=0 ; i Date: Thu, 19 Sep 2013 15:44:21 +0000 Subject: Line numbers wrong in compiled [upvar]. --- generic/tclCompCmds.c | 16 ++++++++-------- tests/upvar.test | 11 +++++++++++ 2 files changed, 19 insertions(+), 8 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 51a566e..6189b29 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -5781,16 +5781,14 @@ TclCompileUpvarCmd( Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; int simpleVarName, isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ - Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_Obj *objPtr; if (envPtr->procPtr == NULL) { - Tcl_DecrRefCount(objPtr); return TCL_ERROR; } numWords = parsePtr->numWords; if (numWords < 3) { - Tcl_DecrRefCount(objPtr); return TCL_ERROR; } @@ -5798,6 +5796,7 @@ TclCompileUpvarCmd( * Push the frame index if it is known at compile time */ + objPtr = Tcl_NewObj(); tokenPtr = TokenAfter(parsePtr->tokenPtr); if(TclWordKnownAtCompileTime(tokenPtr, objPtr)) { CallFrame *framePtr; @@ -5816,16 +5815,17 @@ TclCompileUpvarCmd( if(numWords%2) { return TCL_ERROR; } + /* TODO: Push the known value instead? */ CompileWord(envPtr, tokenPtr, interp, 1); otherTokenPtr = TokenAfter(tokenPtr); - i = 4; + i = 2; } else { if(!(numWords%2)) { return TCL_ERROR; } PushLiteral(envPtr, "1", 1); otherTokenPtr = tokenPtr; - i = 3; + i = 1; } } else { Tcl_DecrRefCount(objPtr); @@ -5838,12 +5838,12 @@ TclCompileUpvarCmd( * be called at runtime. */ - for(; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { + for(; i Date: Thu, 19 Sep 2013 16:04:48 +0000 Subject: Line numbers wrong in compiled [namespace upvar]. --- generic/tclCompCmds.c | 8 ++++---- tests/upvar.test | 21 +++++++++++++++++++++ 2 files changed, 25 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 6189b29..8e26a30 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -5920,7 +5920,7 @@ TclCompileNamespaceCmd( */ tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + CompileWord(envPtr, tokenPtr, interp, 2); /* * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a @@ -5929,13 +5929,13 @@ TclCompileNamespaceCmd( */ localTokenPtr = tokenPtr; - for(i=4; i<=numWords; i+=2) { + for(i=3; i Date: Thu, 19 Sep 2013 16:06:53 +0000 Subject: renumber tests for branch merge --- tests/upvar.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/upvar.test b/tests/upvar.test index df7f551..f90abef 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -553,7 +553,7 @@ test upvar-NS-1.9 {nsupvar links to correct variable} \ -returnCodes error \ -cleanup {namespace delete test_ns_1} -test upvar-NS-2.1 {CompileWord OBOE} -setup { +test upvar-NS-3.1 {CompileWord OBOE} -setup { proc linenumber {} {dict get [info frame -1] line} } -body { apply {n { @@ -563,7 +563,7 @@ test upvar-NS-2.1 {CompileWord OBOE} -setup { } -cleanup { rename linenumber {} } -result 1 -test upvar-NS-2.2 {CompileWord OBOE} -setup { +test upvar-NS-3.2 {CompileWord OBOE} -setup { proc linenumber {} {dict get [info frame -1] line} } -body { apply {n { -- cgit v0.12 From c91c7b7cf1a5d17289e85b2ca29782437b967039 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 16:33:36 +0000 Subject: Line numbers wrong in compiled [global] and [variable]. --- generic/tclCompCmds.c | 18 ++++++++++++------ tests/upvar.test | 10 ++++++++++ 2 files changed, 22 insertions(+), 6 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 8e26a30..809a6c6 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -6007,14 +6007,17 @@ TclCompileGlobalCmd( */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - for(i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { + for(i=1; itokenPtr; - for(i=2; i<=numWords; i+=2) { + for(i=1; i Date: Thu, 19 Sep 2013 17:01:58 +0000 Subject: Line numbers wrong in compiled [dict exists]. --- generic/tclCompCmds.c | 7 +++---- tests/dict.test | 6 ++++++ 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 9829b9c..64c110d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1002,7 +1002,7 @@ TclCompileDictExistsCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; + int i; DefineLineInformation; /* TIP #280 */ /* @@ -1015,17 +1015,16 @@ TclCompileDictExistsCmd( return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - numWords = parsePtr->numWords-1; /* * Now we do the code generation. */ - for (i=0 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr); + TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } diff --git a/tests/dict.test b/tests/dict.test index 797ab46..6c254eb 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1899,6 +1899,12 @@ test dict-23.8 {CompileWord OBOE} { } [return [incr n -[linenumber]]] x {} }} [linenumber] } 1 +test dict-23.9 {CompileWord OBOE} { + apply {n { + dict exists {} {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} 1 rename linenumber {} test dict-24.22 {dict map results (non-compiled)} { -- cgit v0.12 From 3cc058aa46554be19c3f7e3226e32fa45952e1c6 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 17:21:41 +0000 Subject: Line numbers wrong in compiled [dict with]. --- generic/tclCompCmds.c | 10 +++++----- tests/dict.test | 30 ++++++++++++++++++++++++++++++ 2 files changed, 35 insertions(+), 5 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 64c110d..7e6b6da 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1875,7 +1875,7 @@ TclCompileDictWithCmd( tokenPtr = TokenAfter(varTokenPtr); for (i=2 ; inumWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); @@ -1902,7 +1902,7 @@ TclCompileDictWithCmd( tokenPtr = varTokenPtr; for (i=1 ; inumWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); @@ -1916,7 +1916,7 @@ TclCompileDictWithCmd( * Case: Direct dict in non-simple var with empty body. */ - CompileWord(envPtr, varTokenPtr, interp, 0); + CompileWord(envPtr, varTokenPtr, interp, 1); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LOAD_STK, envPtr); PushStringLiteral(envPtr, ""); @@ -1951,13 +1951,13 @@ TclCompileDictWithCmd( */ if (dictVar == -1) { - CompileWord(envPtr, varTokenPtr, interp, 0); + CompileWord(envPtr, varTokenPtr, interp, 1); Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr); } tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { for (i=2 ; inumWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); diff --git a/tests/dict.test b/tests/dict.test index 6c254eb..a583de8 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1905,6 +1905,36 @@ test dict-23.9 {CompileWord OBOE} { } [return [incr n -[linenumber]]] }} [linenumber] } 1 +test dict-23.10 {CompileWord OBOE} { + apply {n { + dict with foo {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.11 {CompileWord OBOE} { + apply {n { + dict with ::foo {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.12 {CompileWord OBOE} { + apply {n { + dict with {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.13 {CompileWord OBOE} { + apply {n { + dict with {*}{ + } [return [incr n -[linenumber]]] {bar} + }} [linenumber] +} 1 +test dict-23.14 {CompileWord OBOE} { + apply {n { + dict with foo {*}{ + } [return [incr n -[linenumber]]] {bar} + }} [linenumber] +} 1 rename linenumber {} test dict-24.22 {dict map results (non-compiled)} { -- cgit v0.12 From fbac621bfc03de0d375e4df6b5f1f0cd7b99d0b5 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 18:53:01 +0000 Subject: Line numbers wrong in compiled [unset]. --- generic/tclCompCmdsGR.c | 1 + generic/tclCompCmdsSZ.c | 14 +++++++------- tests/var.test | 13 +++++++++++++ 3 files changed, 21 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 4e4a3af..43ea3d3 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -587,6 +587,7 @@ TclCompileInfoCommandsCmd( * that the result needs to be list-ified. */ + /* TODO: Just push the known value */ CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); TclEmitOpcode( INST_DUP, envPtr); diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index d1eb9db..6c55e2e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2814,26 +2814,26 @@ TclCompileUnsetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int isScalar, localIndex, numWords, flags, i; + int isScalar, localIndex, flags, i; Tcl_Obj *leadingWord; DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ - numWords = parsePtr->numWords-1; flags = 1; + i = 1; varTokenPtr = TokenAfter(parsePtr->tokenPtr); leadingWord = Tcl_NewObj(); - if (numWords > 0 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { + if (parsePtr->numWords > 1 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { int len; const char *bytes = Tcl_GetStringFromObj(leadingWord, &len); if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { flags = 0; varTokenPtr = TokenAfter(varTokenPtr); - numWords--; + i++; } else if (len == 2 && !strncmp("--", bytes, 2)) { varTokenPtr = TokenAfter(varTokenPtr); - numWords--; + i++; } } else { /* @@ -2846,7 +2846,7 @@ TclCompileUnsetCmd( } TclDecrRefCount(leadingWord); - for (i=0 ; inumWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a @@ -2856,7 +2856,7 @@ TclCompileUnsetCmd( */ PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + &localIndex, &isScalar, i); /* * Emit instructions to unset the variable. diff --git a/tests/var.test b/tests/var.test index 5939100..6d4be26 100644 --- a/tests/var.test +++ b/tests/var.test @@ -862,6 +862,19 @@ test var-20.8 {array set compilation correctness: Bug 3603163} -setup { }} array size x } -result 0 + +test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + set foo bar + unset foo {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + catch {namespace delete ns} catch {unset arr} -- cgit v0.12 From 8e1f9e82da20e4eee11747a782705a3061e7cebc Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 19:02:42 +0000 Subject: comment --- generic/tclCompCmdsSZ.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 6c55e2e..468c1c0 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1864,6 +1864,7 @@ TclCompileTailcallCmd( } /* make room for the nsObjPtr */ + /* TODO: Doesn't this have to be a known value? */ CompileWord(envPtr, tokenPtr, interp, 0); for (i=1 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); -- cgit v0.12 From f95a5e7c8241472de7873a2daa7798f06dcda8eb Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 19 Sep 2013 19:37:05 +0000 Subject: [3970f54c4e]: Corrected regression in argument order processing in [unset]. --- generic/tclCompCmdsSZ.c | 40 +++++++++++++++++++++++++--------------- tests/var.test | 3 +++ 2 files changed, 28 insertions(+), 15 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 468c1c0..b90bff8 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2815,19 +2815,37 @@ TclCompileUnsetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int isScalar, localIndex, flags, i; - Tcl_Obj *leadingWord; + int isScalar, localIndex, flags = 1, i; DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ - flags = 1; - i = 1; + + /* + * Verify that all words are known at compile time so that we can handle + * them without needing to do a nasty push/rotate. [Bug 3970f54c4e] + */ + + for (i=1,varTokenPtr=parsePtr->tokenPtr ; inumWords ; i++) { + varTokenPtr = TokenAfter(varTokenPtr); + if (!TclWordKnownAtCompileTime(varTokenPtr, NULL)) { + return TCL_ERROR; + } + } + + /* + * Check for options; if they're present we'll know for sure because we + * know we're all constant arguments. + */ + varTokenPtr = TokenAfter(parsePtr->tokenPtr); - leadingWord = Tcl_NewObj(); - if (parsePtr->numWords > 1 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { + i = 1; + if (parsePtr->numWords > 1) { + Tcl_Obj *leadingWord = Tcl_NewObj(); + const char *bytes; int len; - const char *bytes = Tcl_GetStringFromObj(leadingWord, &len); + (void) TclWordKnownAtCompileTime(varTokenPtr, leadingWord); + bytes = Tcl_GetStringFromObj(leadingWord, &len); if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { flags = 0; varTokenPtr = TokenAfter(varTokenPtr); @@ -2836,16 +2854,8 @@ TclCompileUnsetCmd( varTokenPtr = TokenAfter(varTokenPtr); i++; } - } else { - /* - * Cannot guarantee that the first word is not '-nocomplain' at - * evaluation with reasonable effort, so spill to interpreted version. - */ - TclDecrRefCount(leadingWord); - return TCL_ERROR; } - TclDecrRefCount(leadingWord); for ( ; inumWords ; i++) { /* diff --git a/tests/var.test b/tests/var.test index 6d4be26..208b361 100644 --- a/tests/var.test +++ b/tests/var.test @@ -748,6 +748,9 @@ test var-15.1 {segfault in [unset], [Bug 735335]} { namespace eval test A useSomeUnlikelyNameHere namespace eval test unset useSomeUnlikelyNameHere } {} +test var-15.2 {compiled unset evaluation order, Bug 3970f54c4e} { + apply {{} {unset foo [return ok]}} +} ok test var-16.1 {CallVarTraces: save/restore interp error state} { trace add variable ::errorCode write " ;#" -- cgit v0.12 From 1479c62f1c1b7a95d8c6f186ef085777184095ad Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 19 Sep 2013 22:37:06 +0000 Subject: [3970f54c4e]: Improved fix that is more tolerant of a single variable varname. --- generic/tclCompCmdsSZ.c | 82 ++++++++++++++++++++++++++++++++++--------------- 1 file changed, 57 insertions(+), 25 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index b90bff8..44cb66e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2815,49 +2815,81 @@ TclCompileUnsetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int isScalar, localIndex, flags = 1, i; + int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0; DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ /* - * Verify that all words are known at compile time so that we can handle - * them without needing to do a nasty push/rotate. [Bug 3970f54c4e] + * Verify that all words - except the first non-option one - are known at + * compile time so that we can handle them without needing to do a nasty + * push/rotate. [Bug 3970f54c4e] */ for (i=1,varTokenPtr=parsePtr->tokenPtr ; inumWords ; i++) { + Tcl_Obj *leadingWord = Tcl_NewObj(); + varTokenPtr = TokenAfter(varTokenPtr); - if (!TclWordKnownAtCompileTime(varTokenPtr, NULL)) { + if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { + TclDecrRefCount(leadingWord); + + /* + * We can tolerate non-trivial substitutions in the first variable + * to be unset. If a '--' or '-nocomplain' was present, anything + * goes in that one place! (All subsequent variable names must be + * constants since we don't want to have to push them all first.) + */ + + if (varCount == 0) { + if (haveFlags) { + continue; + } + + /* + * In fact, we're OK as long as we're the first argument *and* + * we provably don't start with a '-'. If that is true, then + * even if everything else is varying, we still can't be a + * flag. Otherwise we'll spill to runtime to place a limit on + * the trickiness. + */ + + if (varTokenPtr->type == TCL_TOKEN_WORD + && varTokenPtr[1].type == TCL_TOKEN_TEXT + && varTokenPtr[1].size > 0 + && varTokenPtr[1].start[0] != '-') { + continue; + } + } return TCL_ERROR; } + if (i == 1) { + const char *bytes; + int len; + + bytes = Tcl_GetStringFromObj(leadingWord, &len); + if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { + flags = 0; + haveFlags = 1; + } else if (len == 2 && !strncmp("--", bytes, 2)) { + haveFlags = 1; + } else { + varCount++; + } + } else { + varCount++; + } + TclDecrRefCount(leadingWord); } /* - * Check for options; if they're present we'll know for sure because we - * know we're all constant arguments. + * Issue instructions to unset each of the named variables. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - i = 1; - if (parsePtr->numWords > 1) { - Tcl_Obj *leadingWord = Tcl_NewObj(); - const char *bytes; - int len; - - (void) TclWordKnownAtCompileTime(varTokenPtr, leadingWord); - bytes = Tcl_GetStringFromObj(leadingWord, &len); - if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { - flags = 0; - varTokenPtr = TokenAfter(varTokenPtr); - i++; - } else if (len == 2 && !strncmp("--", bytes, 2)) { - varTokenPtr = TokenAfter(varTokenPtr); - i++; - } - TclDecrRefCount(leadingWord); + if (haveFlags) { + varTokenPtr = TokenAfter(varTokenPtr); } - - for ( ; inumWords ; i++) { + for (i=1+haveFlags ; inumWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a -- cgit v0.12 From 9e6b54e433d9d2908605f52a434d242c7148818b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 20 Sep 2013 09:11:51 +0000 Subject: Make sure that panic's during finalization are handled by the custom panicproc not by the default panicproc, because stderr might not be available. When the default panicproc is in use, this doesn't make any difference. --- generic/tclEvent.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 686b80d..941d566 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1171,8 +1171,6 @@ Tcl_Finalize(void) TclFinalizeEncodingSubsystem(); - Tcl_SetPanicProc(NULL); - /* * Repeat finalization of the thread local storage once more. Although * this step is already done by the Tcl_FinalizeThread call above, series -- cgit v0.12