From db45aa4434d4a7af38b8c14072648bf9965d462b Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 5 Jul 2016 17:03:59 +0000 Subject: New tests to demo the remaining flaw in ensemble dispatch revisions. Itcl 4 also demonstrated these problems. --- generic/tclEnsemble.c | 8 +++++++- tests/oo.test | 12 ++++++++++++ 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index a9698be..818534e 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -1852,7 +1852,13 @@ NsEnsembleImplementationCmdNR( Tcl_ListObjLength(NULL, prefixObj, &prefixObjc); - if (objc == 2) { + if (0 && objc == 2) { + /* + * Branch disabled until it works. See oo-1[67].1.1 + * + * Key here is the difference between the canonical list invocation + * and compilation/execution paths. + */ copyPtr = prefixObj; Tcl_IncrRefCount(copyPtr); TclNRAddCallback(interp, FreeObj, copyPtr, NULL, NULL, NULL); diff --git a/tests/oo.test b/tests/oo.test index 895f7ed..48e093a 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2017,6 +2017,12 @@ test oo-15.10 {variable binding must not bleed through oo::copy} -setup { test oo-16.1 {OO: object introspection} -body { info object } -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?arg ...?\"" +test oo-16.1.1 {OO: object introspection} -body { + catch {info object} m o + dict get $o -errorinfo +} -result "wrong \# args: should be \"info object subcommand ?arg ...?\" + while executing +\"info object\"" test oo-16.2 {OO: object introspection} -body { info object class NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} @@ -2156,6 +2162,12 @@ test oo-16.14 {OO: object introspection: TIP #436} -setup { test oo-17.1 {OO: class introspection} -body { info class } -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?arg ...?\"" +test oo-17.1.1 {OO: class introspection} -body { + catch {info class} m o + dict get $o -errorinfo +} -result "wrong \# args: should be \"info class subcommand ?arg ...?\" + while executing +\"info class\"" test oo-17.2 {OO: class introspection} -body { info class superclass NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} -- cgit v0.12 From 891343f5d41ec457a94e65d9ae347de0f039c68a Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 6 Jul 2016 15:12:53 +0000 Subject: [bd7f17bce8] Revise ensemble dispatch to call TclNREvalObjv() which supports the TCL_EVAL_INVOKE flag that is needed. --- generic/tclEnsemble.c | 26 ++++++++++---------------- 1 file changed, 10 insertions(+), 16 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 818534e..fb41580 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -1848,31 +1848,24 @@ NsEnsembleImplementationCmdNR( { Tcl_Obj *copyPtr; /* The actual list of words to dispatch to. * Will be freed by the dispatch engine. */ - int prefixObjc; + Tcl_Obj **copyObjv; + int copyObjc, prefixObjc; Tcl_ListObjLength(NULL, prefixObj, &prefixObjc); - if (0 && objc == 2) { - /* - * Branch disabled until it works. See oo-1[67].1.1 - * - * Key here is the difference between the canonical list invocation - * and compilation/execution paths. - */ - copyPtr = prefixObj; - Tcl_IncrRefCount(copyPtr); - TclNRAddCallback(interp, FreeObj, copyPtr, NULL, NULL, NULL); + if (objc == 2) { + copyPtr = TclListObjCopy(NULL, prefixObj); } else { - int copyObjc = objc - 2 + prefixObjc; - - copyPtr = Tcl_NewListObj(copyObjc, NULL); + copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL); Tcl_ListObjAppendList(NULL, copyPtr, prefixObj); Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, - ensemblePtr->numParameters, objv+1); + ensemblePtr->numParameters, objv + 1); Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, objc - 2 - ensemblePtr->numParameters, objv + 2 + ensemblePtr->numParameters); } + Tcl_IncrRefCount(copyPtr); + TclNRAddCallback(interp, FreeObj, copyPtr, NULL, NULL, NULL); TclDecrRefCount(prefixObj); /* @@ -1892,7 +1885,8 @@ NsEnsembleImplementationCmdNR( */ TclSkipTailcall(interp); - return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN); + Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); + return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } unknownOrAmbiguousSubcommand: -- cgit v0.12 From 3b1d8286ed07d9ddcea89d5e11497062a77dc85e Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 6 Jul 2016 15:50:34 +0000 Subject: Simplify all the Tcl_NRPostProc declarations. --- generic/tclBasic.c | 2 +- generic/tclCmdIL.c | 3 +-- generic/tclCmdMZ.c | 12 ++++-------- generic/tclDictObj.c | 18 ++++++------------ generic/tclIOUtil.c | 3 +-- generic/tclInt.h | 3 +-- generic/tclOO.c | 9 +++------ generic/tclOOCall.c | 9 +++------ generic/tclOOMethod.c | 6 ++---- generic/tclTest.c | 3 +-- 10 files changed, 23 insertions(+), 45 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b0c31cc..7235be1 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -128,7 +128,7 @@ static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; -static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); +static Tcl_NRPostProc NRCommand; static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index c93e593..0a1b4fe 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -105,8 +105,7 @@ typedef struct SortInfo { */ static int DictionaryCompare(const char *left, const char *right); -static int IfConditionCallback(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc IfConditionCallback; static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp, diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 13f9e7d..885a0bc 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -22,14 +22,10 @@ static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode, Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); -static int SwitchPostProc(ClientData data[], Tcl_Interp *interp, - int result); -static int TryPostBody(ClientData data[], Tcl_Interp *interp, - int result); -static int TryPostFinal(ClientData data[], Tcl_Interp *interp, - int result); -static int TryPostHandler(ClientData data[], Tcl_Interp *interp, - int result); +static Tcl_NRPostProc SwitchPostProc; +static Tcl_NRPostProc TryPostBody; +static Tcl_NRPostProc TryPostFinal; +static Tcl_NRPostProc TryPostHandler; static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index c8474e6..428173d 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -70,18 +70,12 @@ static inline void DeleteChainTable(struct Dict *dict); static inline Tcl_HashEntry *CreateChainEntry(struct Dict *dict, Tcl_Obj *keyPtr, int *newPtr); static inline int DeleteChainEntry(struct Dict *dict, Tcl_Obj *keyPtr); -static int FinalizeDictUpdate(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeDictWith(ClientData data[], - Tcl_Interp *interp, int result); -static int DictForNRCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const *objv); -static int DictMapNRCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const *objv); -static int DictForLoopCallback(ClientData data[], - Tcl_Interp *interp, int result); -static int DictMapLoopCallback(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc FinalizeDictUpdate; +static Tcl_NRPostProc FinalizeDictWith; +static Tcl_ObjCmdProc DictForNRCmd; +static Tcl_ObjCmdProc DictMapNRCmd; +static Tcl_NRPostProc DictForLoopCallback; +static Tcl_NRPostProc DictMapLoopCallback; /* * Table of dict subcommand names and implementations. diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 1330c02..3aa0ce5 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -71,8 +71,7 @@ typedef struct ThreadSpecificData { * Prototypes for functions defined later in this file. */ -static int EvalFileCallback(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc EvalFileCallback; static FilesystemRecord*FsGetFirstFilesystem(void); static void FsThrExitProc(ClientData cd); static Tcl_Obj * FsListMounts(Tcl_Obj *pathPtr, const char *pattern); diff --git a/generic/tclInt.h b/generic/tclInt.h index fba4c7b..afed61b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2851,8 +2851,7 @@ MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; -MODULE_SCOPE int TclClearRootEnsemble(ClientData data[], - Tcl_Interp *interp, int result); +MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, diff --git a/generic/tclOO.c b/generic/tclOO.c index 0454bfe..ec666ee 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -68,12 +68,9 @@ static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, static void DeletedDefineNamespace(ClientData clientData); static void DeletedObjdefNamespace(ClientData clientData); static void DeletedHelpersNamespace(ClientData clientData); -static int FinalizeAlloc(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeNext(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeObjectCall(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc FinalizeAlloc; +static Tcl_NRPostProc FinalizeNext; +static Tcl_NRPostProc FinalizeObjectCall; static int InitFoundation(Tcl_Interp *interp); static void KillFoundation(ClientData clientData, Tcl_Interp *interp); diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index facf90d..1797760 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -70,15 +70,12 @@ static void AddSimpleClassChainToCallContext(Class *classPtr, Class *const filterDecl); static int CmpStr(const void *ptr1, const void *ptr2); static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr); -static int FinalizeMethodRefs(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc FinalizeMethodRefs; static void FreeMethodNameRep(Tcl_Obj *objPtr); static inline int IsStillValid(CallChain *callPtr, Object *oPtr, int flags, int reuseMask); -static int ResetFilterFlags(ClientData data[], - Tcl_Interp *interp, int result); -static int SetFilterFlags(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc ResetFilterFlags; +static Tcl_NRPostProc SetFilterFlags; static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr); /* diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index a311ddb..99a8bfc 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -70,10 +70,8 @@ static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc, static int InvokeProcedureMethod(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -static int FinalizeForwardCall(ClientData data[], Tcl_Interp *interp, - int result); -static int FinalizePMCall(ClientData data[], Tcl_Interp *interp, - int result); +static Tcl_NRPostProc FinalizeForwardCall; +static Tcl_NRPostProc FinalizePMCall; static int PushMethodCallFrame(Tcl_Interp *interp, CallContext *contextPtr, ProcedureMethod *pmPtr, int objc, Tcl_Obj *const *objv, diff --git a/generic/tclTest.c b/generic/tclTest.c index 4695ab5..e33d263 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -413,8 +413,7 @@ static int TestHashSystemHashCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int NREUnwind_callback(ClientData data[], Tcl_Interp *interp, - int result); +static Tcl_NRPostProc NREUnwind_callback; static int TestNREUnwind(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -- cgit v0.12 From 5afe70d02240e1acbe825478808f3ef27847c025 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 6 Jul 2016 16:47:37 +0000 Subject: Create and use a utility Tcl_NRPostProc when decr ref count of values is all that is needed. --- generic/tclBasic.c | 19 +++++++++++++------ generic/tclEnsemble.c | 17 ++--------------- generic/tclInt.h | 1 + 3 files changed, 16 insertions(+), 21 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 7235be1..d6a460d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -146,7 +146,6 @@ static int TEOV_RunEnterTraces(Tcl_Interp *interp, Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc RewindCoroutineCallback; -static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; static Tcl_NRPostProc TEOEx_ListCallback; static Tcl_NRPostProc TEOV_Error; @@ -8371,7 +8370,7 @@ TclNRTailcallEval( * a now-gone namespace: cleanup and return. */ - TailcallCleanup(data, interp, result); + Tcl_DecrRefCount(listPtr); return result; } @@ -8380,18 +8379,26 @@ TclNRTailcallEval( */ TclMarkTailcall(interp); - TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL,NULL); + TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); iPtr->lookupNsPtr = (Namespace *) nsPtr; return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL); } -static int -TailcallCleanup( +int +TclNRReleaseValues( ClientData data[], Tcl_Interp *interp, int result) { - Tcl_DecrRefCount((Tcl_Obj *) data[0]); + int i = 0; + while (i < 4) { + if (data[i]) { + Tcl_DecrRefCount((Tcl_Obj *) data[i]); + } else { + break; + } + i++; + } return result; } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index fb41580..ee81aee 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -41,7 +41,6 @@ static int CompileBasicNArgCommand(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr); -static Tcl_NRPostProc FreeObj; static Tcl_NRPostProc FreeER; /* @@ -1865,7 +1864,7 @@ NsEnsembleImplementationCmdNR( objv + 2 + ensemblePtr->numParameters); } Tcl_IncrRefCount(copyPtr); - TclNRAddCallback(interp, FreeObj, copyPtr, NULL, NULL, NULL); + TclNRAddCallback(interp, TclNRReleaseValues, copyPtr, NULL, NULL, NULL); TclDecrRefCount(prefixObj); /* @@ -2064,18 +2063,6 @@ FreeER( return result; } -static int -FreeObj( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Tcl_Obj *objPtr = (Tcl_Obj *)data[0]; - - Tcl_DecrRefCount(objPtr); - return result; -} - void TclSpellFix( Tcl_Interp *interp, @@ -2151,7 +2138,7 @@ TclSpellFix( store[idx] = fix; Tcl_IncrRefCount(fix); - TclNRAddCallback(interp, FreeObj, fix, NULL, NULL, NULL); + TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL); } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index afed61b..a6cc627 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2741,6 +2741,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; +MODULE_SCOPE Tcl_NRPostProc TclNRReleaseValues; MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); -- cgit v0.12 From 0aa3b5113db3c6c750aa4bbcfdb657dec48c0de1 Mon Sep 17 00:00:00 2001 From: ashok Date: Thu, 7 Jul 2016 06:30:58 +0000 Subject: Bugfix [5d7ea04580]. Treat .cmd and .ps1 files are executable on Windows. --- doc/file.n | 4 +++- tests/cmdAH.test | 23 +++++++++++------------ tests/fileName.test | 14 ++++++++------ win/tclWinFile.c | 4 +++- 4 files changed, 25 insertions(+), 20 deletions(-) diff --git a/doc/file.n b/doc/file.n index 8e765da..eeb67ed 100644 --- a/doc/file.n +++ b/doc/file.n @@ -162,7 +162,9 @@ returns \fB/home\fR (or something similar). \fBfile executable \fIname\fR . Returns \fB1\fR if file \fIname\fR is executable by the current user, -\fB0\fR otherwise. +\fB0\fR otherwise. On Windows, which does not have an executable attribute, +the command treats all directories and any files with extensions +\fBexe\fR, \fBcom\fR, \fBcmd\fR, \fBbat\fR or \fBps1\fR as executable. .TP \fBfile exists \fIname\fR . diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 64cfeba..f2f7f8c 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -879,19 +879,18 @@ test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} { test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body { # On pc, must be a .exe, .com, etc. set x [file exe $gorpfile] - set gorpexe [makeFile foo gorp.exe] - lappend x [file exe $gorpexe] -} -cleanup { - removeFile $gorpexe -} -result {0 1} -test cmdAH-18.5.1 {Tcl_FileObjCmd: executable} -constraints {win} -body { - # On pc, must be a .exe, .com, etc. - set x [file exe $gorpfile] - set gorpexe [makeFile foo gorp.exe] - lappend x [file exe [string toupper $gorpexe]] + set gorpexes {} + foreach ext {exe com cmd bat ps1} { + set gorpexe [makeFile foo gorp.$ext] + lappend gorpexes $gorpexe + lappend x [file exe $gorpexe] [file exe [string toupper $gorpexe]] + } + set x } -cleanup { - removeFile $gorpexe -} -result {0 1} + foreach gorpexe $gorpexes { + removeFile $gorpexe + } +} -result {0 1 1 1 1 1 1 1 1 1 1} test cmdAH-18.6 {Tcl_FileObjCmd: executable} {} { # Directories are always executable. file exe $dirfile diff --git a/tests/fileName.test b/tests/fileName.test index 51f00d1..a19bd1e 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -1468,14 +1468,16 @@ if {[testConstraint testsetplatform]} { } test filename-17.2 {windows specific glob with executable} -body { makeDirectory execglob - makeFile contents execglob/abc.exe - makeFile contents execglob/abc.notexecutable - glob -nocomplain -dir [temporaryDirectory]/execglob -tails -types x * + foreach ext {exe com cmd bat ps1 notexecutable} { + makeFile contents execglob/abc.$ext + } + lsort [glob -nocomplain -dir [temporaryDirectory]/execglob -tails -types x *] } -constraints {win} -cleanup { - removeFile execglob/abc.exe - removeFile execglob/abc.notexecutable + foreach ext {exe com cmd bat ps1 notexecutable} { + removeFile execglob/abc.$ext + } removeDirectory execglob -} -result {abc.exe} +} -result {abc.bat abc.cmd abc.com abc.exe abc.ps1} test filename-17.3 {Bug 2571597} win { set p /a file pathtype $p diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 25c6ea4..4b0b884 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1769,7 +1769,7 @@ NativeAccess( * NativeIsExec -- * * Determines if a path is executable. On windows this is simply defined - * by whether the path ends in any of ".exe", ".com", or ".bat" + * by whether the path ends in a standard executable extension. * * Results: * 1 = executable, 0 = not. @@ -1793,6 +1793,8 @@ NativeIsExec( if ((_tcsicmp(path+len-3, TEXT("exe")) == 0) || (_tcsicmp(path+len-3, TEXT("com")) == 0) + || (_tcsicmp(path+len-3, TEXT("cmd")) == 0) + || (_tcsicmp(path+len-3, TEXT("ps1")) == 0) || (_tcsicmp(path+len-3, TEXT("bat")) == 0)) { return 1; } -- cgit v0.12