From 5b5bd699fff2526408d46527d5ea1c8433f51fc6 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 25 Feb 2018 12:04:55 +0000 Subject: Starting to build the implementation of the private methods and variables. Definition support. --- generic/tclInt.h | 4 +++ generic/tclOO.c | 2 ++ generic/tclOODefineCmds.c | 87 +++++++++++++++++++++++++++++++++++++++++++++-- generic/tclOOInt.h | 3 ++ 4 files changed, 93 insertions(+), 3 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 797e1cb..f41a5cc 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1146,6 +1146,10 @@ typedef struct CallFrame { * field contains an Object reference that has * been confirmed to refer to a class. Part of * TIP#257. */ +#define FRAME_IS_PRIVATE_DEFINE 0x10 + /* Marks this frame as being used for private + * declarations with [oo::define]. Usually + * OR'd with FRAME_IS_OO_DEFINE. TIP#500. */ /* * TIP #280 diff --git a/generic/tclOO.c b/generic/tclOO.c index 39e3fb2..4975303 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -31,6 +31,7 @@ static const struct { {"export", TclOODefineExportObjCmd, 0}, {"forward", TclOODefineForwardObjCmd, 0}, {"method", TclOODefineMethodObjCmd, 0}, + {"private", TclOODefinePrivateObjCmd, 0}, {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, {"self", TclOODefineSelfObjCmd, 0}, {"unexport", TclOODefineUnexportObjCmd, 0}, @@ -41,6 +42,7 @@ static const struct { {"export", TclOODefineExportObjCmd, 1}, {"forward", TclOODefineForwardObjCmd, 1}, {"method", TclOODefineMethodObjCmd, 1}, + {"private", TclOODefinePrivateObjCmd, 1}, {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, {"self", TclOODefineObjSelfObjCmd, 0}, {"unexport", TclOODefineUnexportObjCmd, 1}, diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 7c2a641..7710b71 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -17,6 +17,12 @@ #include "tclOOInt.h" /* + * The actual value used to mark private declaration frames. + */ + +#define PRIVATE_FRAME (FRAME_IS_OO_DEFINE | FRAME_IS_PRIVATE_DEFINE) + +/* * The maximum length of fully-qualified object name to use in an errorinfo * message. Longer than this will be curtailed. */ @@ -714,7 +720,8 @@ TclOOGetDefineCmdContext( Tcl_Object object; if ((iPtr->varFramePtr == NULL) - || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) { + || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE + && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "this command may only be called from within the context of" " an ::oo::define or ::oo::objdefine command", -1)); @@ -755,7 +762,8 @@ GetClassInOuterContext( Object *oPtr; CallFrame *savedFramePtr = iPtr->varFramePtr; - while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE) { + while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE + || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) { if (iPtr->varFramePtr->callerVarPtr == NULL) { Tcl_Panic("getting outer context when already in global context"); } @@ -1071,7 +1079,7 @@ TclOODefineSelfObjCmd( Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[1], 0, - ((Interp *)interp)->cmdFramePtr, 2); + ((Interp *)interp)->cmdFramePtr, 1); if (result == TCL_ERROR) { GenerateErrorInfo(interp, oPtr, objNameObj, "class object"); } @@ -1126,6 +1134,79 @@ TclOODefineObjSelfObjCmd( /* * ---------------------------------------------------------------------- * + * TclOODefinePrivateObjCmd -- + * + * Implementation of the "private" subcommand of the "oo::define" + * and "oo::objdefine" commands. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefinePrivateObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + int isInstancePrivate = (clientData != NULL); + /* Just so that we can generate the correct + * error message depending on the context of + * usage of this function. */ + Interp *iPtr = (Interp *) interp; + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int saved; /* The saved flag. We restore it on exit so + * that [private private ...] doesn't make + * things go weird. */ + int result; + + if (oPtr == NULL) { + return TCL_ERROR; + } + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "definitionCommand ..."); + return TCL_ERROR; + } + + /* + * Change the frame type flag while evaluating the body. + */ + + saved = iPtr->varFramePtr->isProcCallFrame; + iPtr->varFramePtr->isProcCallFrame = PRIVATE_FRAME; + + /* + * Evaluate the body; standard pattern. + */ + + AddRef(oPtr); + if (objc == 2) { + Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); + + Tcl_IncrRefCount(objNameObj); + result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); + if (result == TCL_ERROR) { + GenerateErrorInfo(interp, oPtr, objNameObj, + isInstancePrivate ? "object" : "class"); + } + TclDecrRefCount(objNameObj); + } else { + result = MagicDefinitionInvoke(interp, TclGetCurrentNamespace(interp), + 1, objc, objv); + } + TclOODecrRefCount(oPtr); + + /* + * Restore the frame type flag to what it was previously. + */ + + iPtr->varFramePtr->isProcCallFrame = saved; + return result; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineClassObjCmd -- * * Implementation of the "class" subcommand of the "oo::objdefine" diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 084c026..53fc0e9 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -431,6 +431,9 @@ MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData, MODULE_SCOPE int TclOODefineObjSelfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefinePrivateObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -- cgit v0.12 From 383c53f80e5569976680d358a135e25f7e402e9a Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 18 Mar 2018 18:04:50 +0000 Subject: This should be the implementation of private variables. --- generic/tclOO.c | 18 +++ generic/tclOODefineCmds.c | 278 ++++++++++++++++++++++++++++++---------------- generic/tclOOInt.h | 44 +++++++- generic/tclOOMethod.c | 20 +++- 4 files changed, 264 insertions(+), 96 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 4975303..0cc10a7 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -970,6 +970,7 @@ ReleaseClassContents( Method *mPtr; Foundation *fPtr = oPtr->fPtr; Tcl_Obj *variableObj; + PrivateVariableMapping *privateVariable; /* * Sanity check! @@ -1062,6 +1063,14 @@ ReleaseClassContents( ckfree(clsPtr->variables.list); } + FOREACH_STRUCT(privateVariable, clsPtr->privateVariables) { + TclDecrRefCount(privateVariable->variableObj); + TclDecrRefCount(privateVariable->fullNameObj); + } + if (i) { + ckfree(clsPtr->privateVariables.list); + } + if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); } @@ -1091,6 +1100,7 @@ ObjectNamespaceDeleted( Class *mixinPtr; Method *mPtr; Tcl_Obj *filterObj, *variableObj; + PrivateVariableMapping *privateVariable; Tcl_Interp *interp = oPtr->fPtr->interp; int i; @@ -1210,6 +1220,14 @@ ObjectNamespaceDeleted( ckfree(oPtr->variables.list); } + FOREACH_STRUCT(privateVariable, oPtr->privateVariables) { + TclDecrRefCount(privateVariable->variableObj); + TclDecrRefCount(privateVariable->fullNameObj); + } + if (i) { + ckfree(oPtr->privateVariables.list); + } + if (oPtr->chainCache) { TclOODeleteChainCache(oPtr->chainCache); } diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 7710b71..916fb41 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -124,6 +124,30 @@ static const struct DeclaredSlot slots[] = { SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet), {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; + +#define PRIVATE_VARIABLE_PATTERN "%d : %s" + +/* + * ---------------------------------------------------------------------- + * + * IsPrivateDefine -- + * + * Extracts whether the current context is handling private definitions. + * + * ---------------------------------------------------------------------- + */ + +static inline int +IsPrivateDefine( + Tcl_Interp *interp) +{ + Interp *iPtr = (Interp *) interp; + + if (!iPtr->varFramePtr) { + return 0; + } + return iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME; +} /* * ---------------------------------------------------------------------- @@ -431,6 +455,123 @@ TclOOClassSetMixins( /* * ---------------------------------------------------------------------- * + * InstallStandardVariableMapping, InstallPrivateVariableMapping -- + * + * Helpers for installing standard and private variable maps. + * + * ---------------------------------------------------------------------- + */ +static inline void +InstallStandardVariableMapping( + VariableNameList *vnlPtr, + int varc, + Tcl_Obj *const *varv) +{ + Tcl_Obj *variableObj; + int i, n, created; + Tcl_HashTable uniqueTable; + + for (i=0 ; ilist); + } else if (i) { + vnlPtr->list = ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc); + } else { + vnlPtr->list = ckalloc(sizeof(Tcl_Obj *) * varc); + } + } + vnlPtr->num = 0; + if (varc > 0) { + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; ilist[n++] = varv[i]; + } else { + Tcl_DecrRefCount(varv[i]); + } + } + vnlPtr->num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + if (n != varc) { + vnlPtr->list = ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * n); + } + Tcl_DeleteHashTable(&uniqueTable); + } +} + +static inline void +InstallPrivateVariableMapping( + PrivateVariableList *pvlPtr, + int varc, + Tcl_Obj *const *varv, + int creationEpoch) +{ + PrivateVariableMapping *privatePtr; + int i, n, created; + Tcl_HashTable uniqueTable; + + for (i=0 ; ivariableObj); + Tcl_DecrRefCount(privatePtr->fullNameObj); + } + if (i != varc) { + if (varc == 0) { + ckfree(pvlPtr->list); + } else if (i) { + pvlPtr->list = ckrealloc(pvlPtr->list, + sizeof(PrivateVariableMapping) * varc); + } else { + pvlPtr->list = ckalloc(sizeof(PrivateVariableMapping) * varc); + } + } + + pvlPtr->num = 0; + if (varc > 0) { + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; ilist[n++]); + privatePtr->variableObj = varv[i]; + privatePtr->fullNameObj = Tcl_ObjPrintf( + PRIVATE_VARIABLE_PATTERN, + creationEpoch, Tcl_GetString(varv[i])); + Tcl_IncrRefCount(privatePtr->fullNameObj); + } else { + Tcl_DecrRefCount(varv[i]); + } + } + pvlPtr->num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + if (n != varc) { + pvlPtr->list = ckrealloc(pvlPtr->list, + sizeof(PrivateVariableMapping) * n); + } + Tcl_DeleteHashTable(&uniqueTable); + } +} + +/* + * ---------------------------------------------------------------------- + * * RenameDeleteMethod -- * * Core of the code to rename and delete methods. @@ -1611,6 +1752,9 @@ TclOODefineForwardObjCmd( } isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") ? PUBLIC_METHOD : 0; + if (IsPrivateDefine(interp)) { + isPublic = TRUE_PRIVATE_METHOD; + } /* * Create the method structure. @@ -1670,6 +1814,9 @@ TclOODefineMethodObjCmd( } isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") ? PUBLIC_METHOD : 0; + if (IsPrivateDefine(interp)) { + isPublic = TRUE_PRIVATE_METHOD; + } /* * Create the method by using the right back-end API. @@ -2408,7 +2555,7 @@ ClassVarsGet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *variableObj; + Tcl_Obj *resultObj; int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { @@ -2426,8 +2573,18 @@ ClassVarsGet( } resultObj = Tcl_NewObj(); - FOREACH(variableObj, oPtr->classPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (IsPrivateDefine(interp)) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, oPtr->classPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, oPtr->classPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -2443,7 +2600,7 @@ ClassVarsSet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); int varc; - Tcl_Obj **varv, *variableObj; + Tcl_Obj **varv; int i; if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { @@ -2484,49 +2641,11 @@ ClassVarsSet( } } - for (i=0 ; iclassPtr->variables) { - Tcl_DecrRefCount(variableObj); - } - if (i != varc) { - if (varc == 0) { - ckfree(oPtr->classPtr->variables.list); - } else if (i) { - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->classPtr->variables.list, - sizeof(Tcl_Obj *) * varc); - } else { - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckalloc(sizeof(Tcl_Obj *) * varc); - } - } - - oPtr->classPtr->variables.num = 0; - if (varc > 0) { - int created, n; - Tcl_HashTable uniqueTable; - - Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; iclassPtr->variables.list[n++] = varv[i]; - } else { - Tcl_DecrRefCount(varv[i]); - } - } - oPtr->classPtr->variables.num = n; - - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ - - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->classPtr->variables.list, - sizeof(Tcl_Obj *) * n); - Tcl_DeleteHashTable(&uniqueTable); + if (IsPrivateDefine(interp)) { + InstallPrivateVariableMapping(&oPtr->classPtr->privateVariables, + varc, varv, oPtr->classPtr->thisPtr->creationEpoch); + } else { + InstallStandardVariableMapping(&oPtr->classPtr->variables, varc, varv); } return TCL_OK; } @@ -2715,7 +2834,7 @@ ObjVarsGet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *variableObj; + Tcl_Obj *resultObj; int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { @@ -2727,8 +2846,18 @@ ObjVarsGet( } resultObj = Tcl_NewObj(); - FOREACH(variableObj, oPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (IsPrivateDefine(interp)) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, oPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -2744,7 +2873,7 @@ ObjVarsSet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); int varc, i; - Tcl_Obj **varv, *variableObj; + Tcl_Obj **varv; if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2777,49 +2906,12 @@ ObjVarsSet( return TCL_ERROR; } } - for (i=0 ; ivariables) { - Tcl_DecrRefCount(variableObj); - } - if (i != varc) { - if (varc == 0) { - ckfree(oPtr->variables.list); - } else if (i) { - oPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->variables.list, - sizeof(Tcl_Obj *) * varc); - } else { - oPtr->variables.list = (Tcl_Obj **) - ckalloc(sizeof(Tcl_Obj *) * varc); - } - } - oPtr->variables.num = 0; - if (varc > 0) { - int created, n; - Tcl_HashTable uniqueTable; - - Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; ivariables.list[n++] = varv[i]; - } else { - Tcl_DecrRefCount(varv[i]); - } - } - oPtr->variables.num = n; - - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ - oPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->variables.list, - sizeof(Tcl_Obj *) * n); - Tcl_DeleteHashTable(&uniqueTable); + if (IsPrivateDefine(interp)) { + InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv, + oPtr->creationEpoch); + } else { + InstallStandardVariableMapping(&oPtr->variables, varc, varv); } return TCL_OK; } diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 53fc0e9..10c25ee 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -125,6 +125,18 @@ typedef struct ForwardMethod { } ForwardMethod; /* + * Structure used in private variable mappings. Describes the mapping of a + * single variable from the user's local name to the system's storage name. + * [TIP #500] + */ + +typedef struct { + Tcl_Obj *variableObj; /* Name used within methods. This is the part + * that is properly under user control. */ + Tcl_Obj *fullNameObj; /* Name used at the instance namespace level. */ +} PrivateVariableMapping; + +/* * Helper definitions that declare a "list" array. The two varieties are * either optimized for simplicity (in the case that the whole array is * typically assigned at once) or efficiency (in the case that the array is @@ -142,6 +154,13 @@ typedef struct ForwardMethod { struct { int num, size; listType_t *list; } /* + * These types are needed in function arguments. + */ + +typedef LIST_STATIC(Tcl_Obj *) VariableNameList; +typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList; + +/* * Now, the definition of what an object actually is. */ @@ -186,7 +205,10 @@ typedef struct Object { Tcl_ObjectMapMethodNameProc *mapMethodNameProc; /* Function to allow remapping of method * names. For itcl-ng. */ - LIST_STATIC(Tcl_Obj *) variables; + VariableNameList variables; + PrivateVariableList privateVariables; + /* Configurations for the variable resolver + * used inside methods. */ } Object; #define OBJECT_DELETED 1 /* Flag to say that an object has been @@ -268,7 +290,10 @@ typedef struct Class { * object doesn't override with its own mixins * (and filters and method implementations for * when getting method chains). */ - LIST_STATIC(Tcl_Obj *) variables; + VariableNameList variables; + PrivateVariableList privateVariables; + /* Configurations for the variable resolver + * used inside methods. */ } Class; /* @@ -374,6 +399,10 @@ typedef struct CallContext { #define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */ #define CONSTRUCTOR 0x08 /* This is a constructor. */ #define DESTRUCTOR 0x10 /* This is a destructor. */ +#define TRUE_PRIVATE_METHOD 0x20 + /* This is a private method only accessible + * from other methods defined on this class + * or instance. [TIP #500] */ /* * Structure containing definition information about basic class methods. @@ -564,10 +593,21 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); } else if (var = (ary).list[i], 1) /* + * A variation where the array is an array of structs. There's no issue with + * possible NULLs; every element of the array will be iterated over and the + * varable set to a pointer to each of those elements in turn. + * REQUIRES DECLARATION: int i; + */ + +#define FOREACH_STRUCT(var,ary) \ + for(i=0 ; var=&((ary).list[i]), i<(ary).num; i++) + +/* * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS * sets up the declarations needed for the main macro, FOREACH_HASH, which * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that * only iterates over values. + * REQUIRES DECLARATION: FOREACH_HASH_DECLS; */ #define FOREACH_HASH_DECLS \ diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index e8fad82..30100b1 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -928,7 +928,7 @@ PushMethodCallFrame( * variables used in methods. The compiled variable resolver is more * important, but both are needed as it is possible to have a variable * that is only referred to in ways that aren't compilable and we can't - * force LVT presence. [TIP #320] + * force LVT presence. [TIP #320, #500] * * ---------------------------------------------------------------------- */ @@ -986,6 +986,7 @@ ProcedureMethodCompiledVarConnect( CallFrame *framePtr = iPtr->varFramePtr; CallContext *contextPtr; Tcl_Obj *variableObj; + PrivateVariableMapping *privateVar; Tcl_HashEntry *hPtr; int i, isNew, cacheIt, varLen, len; const char *match, *varName; @@ -1019,6 +1020,15 @@ ProcedureMethodCompiledVarConnect( varName = TclGetStringFromObj(infoPtr->variableObj, &varLen); if (contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr != NULL) { + FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index] + .mPtr->declaringClassPtr->privateVariables) { + match = TclGetStringFromObj(privateVar->variableObj, &len); + if ((len == varLen) && !memcmp(match, varName, len)) { + variableObj = privateVar->fullNameObj; + cacheIt = 0; + goto gotMatch; + } + } FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr->variables) { match = TclGetStringFromObj(variableObj, &len); @@ -1028,6 +1038,14 @@ ProcedureMethodCompiledVarConnect( } } } else { + FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) { + match = TclGetStringFromObj(privateVar->variableObj, &len); + if ((len == varLen) && !memcmp(match, varName, len)) { + variableObj = privateVar->fullNameObj; + cacheIt = 1; + goto gotMatch; + } + } FOREACH(variableObj, contextPtr->oPtr->variables) { match = TclGetStringFromObj(variableObj, &len); if ((len == varLen) && !memcmp(match, varName, len)) { -- cgit v0.12 From 5a8d06b0762d730fdbb4d5b792a737c5f50540c5 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 5 Apr 2018 07:26:27 +0000 Subject: Start of private method dispatch machinery. --- generic/tclOO.c | 19 +++++++++++++++++++ generic/tclOOCall.c | 41 +++++++++++++++++++++++++++++++---------- generic/tclOOInt.h | 12 +++++++++++- generic/tclOOMethod.c | 6 ++++-- 4 files changed, 65 insertions(+), 13 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 5c41067..db9f399 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -2546,6 +2546,7 @@ TclOOObjectCmdCore( { CallContext *contextPtr; Tcl_Obj *methodNamePtr; + CallFrame *framePtr = ((Interp *) interp)->varFramePtr; int result; /* @@ -2560,6 +2561,24 @@ TclOOObjectCmdCore( } /* + * Determine if we're in a context that can see the extra, private methods + * in this class. + */ + + if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { + CallContext *callerContextPtr = framePtr->clientData; + Method *callerMethodPtr = + callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr; + + if (callerMethodPtr->declaringObjectPtr == oPtr) { + flags |= OBJECT_PRIVATE_METHOD; + } + if (callerMethodPtr->declaringClassPtr == oPtr->selfCls) { + flags |= CLASS_PRIVATE_METHOD; + } + } + + /* * Give plugged in code a chance to remap the method name. */ diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 7da9da0..aa30808 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -717,14 +717,26 @@ AddSimpleChainToCallContext( * object or this isn't a filter. */ { int i; + Tcl_HashEntry *hPtr; + Method *mPtr; - if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, - (char *) methodNameObj); + if (flags & OBJECT_PRIVATE_METHOD && oPtr->methodsPtr) { + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj); if (hPtr != NULL) { - Method *mPtr = Tcl_GetHashValue(hPtr); + mPtr = Tcl_GetHashValue(hPtr); + if (mPtr->flags & TRUE_PRIVATE_METHOD) { + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); + } + } + flags &= ~OBJECT_PRIVATE_METHOD; + flags |= DEFINITE_PROTECTED; + } else if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) { + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj); + if (hPtr != NULL) { + mPtr = Tcl_GetHashValue(hPtr); if (flags & PUBLIC_METHOD) { if (!(mPtr->flags & PUBLIC_METHOD)) { return; @@ -737,7 +749,6 @@ AddSimpleChainToCallContext( } } if (!(flags & SPECIAL)) { - Tcl_HashEntry *hPtr; Class *mixinPtr; FOREACH(mixinPtr, oPtr->mixins) { @@ -747,8 +758,11 @@ AddSimpleChainToCallContext( if (oPtr->methodsPtr) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj); if (hPtr != NULL) { - AddMethodToCallChain(Tcl_GetHashValue(hPtr), cbPtr, - doneFilters, filterDecl, flags); + mPtr = Tcl_GetHashValue(hPtr); + if (!(mPtr->flags & TRUE_PRIVATE_METHOD)) { + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); + } } } } @@ -1433,9 +1447,11 @@ AddSimpleClassChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i; + int i, private = (flags & CLASS_PRIVATE_METHOD); Class *superPtr; + flags &= ~CLASS_PRIVATE_METHOD; + /* * We hard-code the tail-recursive form. It's by far the most common case * *and* it is much more gentle on the stack. @@ -1464,7 +1480,9 @@ AddSimpleClassChainToCallContext( if (hPtr != NULL) { register Method *mPtr = Tcl_GetHashValue(hPtr); - if (!(flags & KNOWN_STATE)) { + if (private && mPtr->flags & TRUE_PRIVATE_METHOD) { + flags |= DEFINITE_PROTECTED; + } else if (!(flags & KNOWN_STATE)) { if (flags & PUBLIC_METHOD) { if (mPtr->flags & PUBLIC_METHOD) { flags |= DEFINITE_PUBLIC; @@ -1475,7 +1493,10 @@ AddSimpleClassChainToCallContext( flags |= DEFINITE_PROTECTED; } } - AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags); + if (private || !(mPtr->flags & TRUE_PRIVATE_METHOD)) { + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); + } } } diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 10c25ee..55847ca 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -395,7 +395,7 @@ typedef struct CallContext { #define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */ #define PRIVATE_METHOD 0x02 /* This is a private (class's direct instances - * only) method. */ + * only) method. Supports itcl. */ #define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */ #define CONSTRUCTOR 0x08 /* This is a constructor. */ #define DESTRUCTOR 0x10 /* This is a destructor. */ @@ -403,6 +403,16 @@ typedef struct CallContext { /* This is a private method only accessible * from other methods defined on this class * or instance. [TIP #500] */ +#define OBJECT_PRIVATE_METHOD 0x40 + /* This is a call of a method on an object + * that may include TRUE_PRIVATE_METHOD + * instance method implementations in its call + * chain. */ +#define CLASS_PRIVATE_METHOD 0x80 + /* This is a call of a method on an object + * that may include TRUE_PRIVATE_METHOD class + * method implementations in its call + * chain. */ /* * Structure containing definition information about basic class methods. diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 30100b1..82204f1 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -186,7 +186,8 @@ Tcl_NewInstanceMethod( mPtr->declaringObjectPtr = oPtr; mPtr->declaringClassPtr = NULL; if (flags) { - mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD); + mPtr->flags |= flags & + (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD); } oPtr->epoch++; return (Tcl_Method) mPtr; @@ -250,7 +251,8 @@ Tcl_NewMethod( mPtr->declaringObjectPtr = NULL; mPtr->declaringClassPtr = clsPtr; if (flags) { - mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD); + mPtr->flags |= flags & + (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD); } return (Tcl_Method) mPtr; -- cgit v0.12 From 8262e514d0b65f088e0799e9cea671f7efd1fa25 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 12 Apr 2018 23:54:58 +0000 Subject: Added introspectors mentioned in TIP. --- generic/tclOOInfo.c | 154 +++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 135 insertions(+), 19 deletions(-) diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 76eaef5..05e600f 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -22,6 +22,7 @@ static Tcl_ObjCmdProc InfoObjectClassCmd; static Tcl_ObjCmdProc InfoObjectDefnCmd; static Tcl_ObjCmdProc InfoObjectFiltersCmd; static Tcl_ObjCmdProc InfoObjectForwardCmd; +static Tcl_ObjCmdProc InfoObjectIdCmd; static Tcl_ObjCmdProc InfoObjectIsACmd; static Tcl_ObjCmdProc InfoObjectMethodsCmd; static Tcl_ObjCmdProc InfoObjectMethodTypeCmd; @@ -50,6 +51,7 @@ static Tcl_ObjCmdProc InfoClassVariablesCmd; static const EnsembleImplMap infoObjectCmds[] = { {"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0}, + {"creationid", InfoObjectIdCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, @@ -58,7 +60,7 @@ static const EnsembleImplMap infoObjectCmds[] = { {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0}, - {"variables", InfoObjectVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -80,7 +82,7 @@ static const EnsembleImplMap infoClassCmds[] = { {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"variables", InfoClassVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -517,15 +519,21 @@ InfoObjectMethodsCmd( Tcl_Obj *const objv[]) { Object *oPtr; - int flag = PUBLIC_METHOD, recurse = 0; + int flag = PUBLIC_METHOD, recurse = 0, scope = -1; FOREACH_HASH_DECLS; Tcl_Obj *namePtr, *resultObj; Method *mPtr; static const char *const options[] = { - "-all", "-localprivate", "-private", NULL + "-all", "-localprivate", "-private", "-scope", NULL }; enum Options { - OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE + OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE + }; + static const char *const scopes[] = { + "private", "public", "unexported" + }; + enum Scopes { + SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED }; if (objc < 2) { @@ -554,9 +562,36 @@ InfoObjectMethodsCmd( case OPT_PRIVATE: flag = 0; break; + case OPT_SCOPE: + if (++i >= objc) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing option for -scope")); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", + NULL); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, + &scope) != TCL_OK) { + return TCL_ERROR; + } + break; } } } + if (scope != -1) { + recurse = 0; + switch (scope) { + case SCOPE_PRIVATE: + flag = TRUE_PRIVATE_METHOD; + break; + case SCOPE_PUBLIC: + flag = PUBLIC_METHOD; + break; + case SCOPE_UNEXPORTED: + flag = 0; + break; + } + } resultObj = Tcl_NewObj(); if (recurse) { @@ -684,6 +719,38 @@ InfoObjectMixinsCmd( /* * ---------------------------------------------------------------------- * + * InfoObjectIdCmd -- + * + * Implements [info object creationid $objName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectIdCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "objName"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->creationEpoch)); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * InfoObjectNsCmd -- * * Implements [info object namespace $objName] @@ -719,7 +786,7 @@ InfoObjectNsCmd( * * InfoObjectVariablesCmd -- * - * Implements [info object variables $objName] + * Implements [info object variables $objName ?-private?] * * ---------------------------------------------------------------------- */ @@ -735,8 +802,8 @@ InfoObjectVariablesCmd( Tcl_Obj *variableObj, *resultObj; int i; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "objName"); + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); @@ -1128,7 +1195,7 @@ InfoClassInstancesCmd( * * InfoClassMethodsCmd -- * - * Implements [info class methods $clsName ?-private?] + * Implements [info class methods $clsName ?options...?] * * ---------------------------------------------------------------------- */ @@ -1140,15 +1207,21 @@ InfoClassMethodsCmd( int objc, Tcl_Obj *const objv[]) { - int flag = PUBLIC_METHOD, recurse = 0; + int flag = PUBLIC_METHOD, recurse = 0, scope = -1; Tcl_Obj *namePtr, *resultObj; Method *mPtr; Class *clsPtr; static const char *const options[] = { - "-all", "-localprivate", "-private", NULL + "-all", "-localprivate", "-private", "-scope", NULL }; enum Options { - OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE + OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE + }; + static const char *const scopes[] = { + "private", "public", "unexported" + }; + enum Scopes { + SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED }; if (objc < 2) { @@ -1177,9 +1250,36 @@ InfoClassMethodsCmd( case OPT_PRIVATE: flag = 0; break; + case OPT_SCOPE: + if (++i >= objc) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing option for -scope")); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", + NULL); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, + &scope) != TCL_OK) { + return TCL_ERROR; + } + break; } } } + if (scope != -1) { + recurse = 0; + switch (scope) { + case SCOPE_PRIVATE: + flag = TRUE_PRIVATE_METHOD; + break; + case SCOPE_PUBLIC: + flag = PUBLIC_METHOD; + break; + case SCOPE_UNEXPORTED: + flag = 0; + break; + } + } resultObj = Tcl_NewObj(); if (recurse) { @@ -1399,7 +1499,7 @@ InfoClassSupersCmd( * * InfoClassVariablesCmd -- * - * Implements [info class variables $clsName] + * Implements [info class variables $clsName ?-private?] * * ---------------------------------------------------------------------- */ @@ -1412,21 +1512,37 @@ InfoClassVariablesCmd( Tcl_Obj *const objv[]) { Class *clsPtr; - Tcl_Obj *variableObj, *resultObj; - int i; + Tcl_Obj *resultObj; + int i, private = 0; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "className"); + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?"); return TCL_ERROR; } + if (objc == 3) { + if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { + return TCL_ERROR; + } + private = 1; + } clsPtr = GetClassFromObj(interp, objv[1]); if (clsPtr == NULL) { return TCL_ERROR; } resultObj = Tcl_NewObj(); - FOREACH(variableObj, clsPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (private) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, clsPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; -- cgit v0.12 From 49879791f48b7a18d94b3f8ea1281e9eed7b0e37 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 13 Apr 2018 07:23:37 +0000 Subject: Duplicate the private variable config when cloning objects. --- generic/tclOO.c | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index db9f399..1080967 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1904,6 +1904,7 @@ Tcl_CopyObjectInstance( Class *mixinPtr; CallContext *contextPtr; Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3]; + PrivateVariableMapping *privateVariable; int i, result; /* @@ -1973,7 +1974,7 @@ Tcl_CopyObjectInstance( } /* - * Copy the object's variable resolution list to the new object. + * Copy the object's variable resolution lists to the new object. */ DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *); @@ -1981,6 +1982,13 @@ Tcl_CopyObjectInstance( Tcl_IncrRefCount(variableObj); } + DUPLICATE(o2Ptr->privateVariables, oPtr->privateVariables, + PrivateVariableMapping); + FOREACH_STRUCT(privateVariable, o2Ptr->privateVariables) { + Tcl_IncrRefCount(privateVariable->variableObj); + Tcl_IncrRefCount(privateVariable->fullNameObj); + } + /* * Copy the object's flags to the new object, clearing those that must be * kept object-local. The duplicate is never deleted at this point, nor is @@ -2069,7 +2077,7 @@ Tcl_CopyObjectInstance( } /* - * Copy the source class's variable resolution list. + * Copy the source class's variable resolution lists. */ DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *); @@ -2077,6 +2085,13 @@ Tcl_CopyObjectInstance( Tcl_IncrRefCount(variableObj); } + DUPLICATE(cls2Ptr->privateVariables, clsPtr->privateVariables, + PrivateVariableMapping); + FOREACH_STRUCT(privateVariable, cls2Ptr->privateVariables) { + Tcl_IncrRefCount(privateVariable->variableObj); + Tcl_IncrRefCount(privateVariable->fullNameObj); + } + /* * Duplicate the source class's mixins (which cannot be circular * references to the duplicate). -- cgit v0.12 From 637c7dbc7ef7c87a8528e00c422624be5b102bed Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 15 Apr 2018 10:29:48 +0000 Subject: Added tests for [info object creationid] --- generic/tclOOInfo.c | 2 +- tests/oo.test | 69 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 69 insertions(+), 2 deletions(-) diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 05e600f..bdb67ae 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -51,7 +51,7 @@ static Tcl_ObjCmdProc InfoClassVariablesCmd; static const EnsembleImplMap infoObjectCmds[] = { {"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0}, - {"creationid", InfoObjectIdCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"creationid", InfoObjectIdCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, diff --git a/tests/oo.test b/tests/oo.test index 2d23a3c..f2bce76 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2202,7 +2202,7 @@ test oo-16.2 {OO: object introspection} -body { } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} test oo-16.3 {OO: object introspection} -body { info object gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} test oo-16.4 {OO: object introspection} -setup { oo::class create meta { superclass oo::class } [meta create instance1] create instance2 @@ -2332,6 +2332,73 @@ test oo-16.14 {OO: object introspection: TIP #436} -setup { } -cleanup { meta destroy } -result {class {0 0} meta {0 0 0} type {0 0 0 0 0 0} mix {0 0 0 0 0 0}} +test oo-16.15 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + info object creationid [cls new] +} -cleanup { + cls destroy +} -result {^\d+$} -match regexp +test oo-16.16 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + set obj [cls new] + set id [info object creationid $obj] + rename $obj gorp + set id2 [info object creationid gorp] + list $id $id2 +} -cleanup { + cls destroy +} -result {^(\d+) \1$} -match regexp +test oo-16.17 {OO: object introspection: creationid #500} -body { + info object creationid nosuchobject +} -returnCodes error -result {nosuchobject does not refer to an object} +test oo-16.18 {OO: object introspection: creationid #500} -body { + info object creationid +} -returnCodes error -result {wrong # args: should be "info object creationid objName"} +test oo-16.18 {OO: object introspection: creationid #500} -body { + info object creationid oo::object gorp +} -returnCodes error -result {wrong # args: should be "info object creationid objName"} +test oo-16.19 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + set id1 [info object creationid [set o1 [cls new]]] + set id2 [info object creationid [set o2 [cls new]]] + if {$id1 == $id2} { + format "objects %s and %s have same creation id: %d" $o1 $o2 $id1 + } else { + string cat not-equal + } +} -cleanup { + cls destroy +} -result not-equal +test oo-16.20 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + set id1 [info object creationid [set o1 [cls new]]] + $o1 destroy + set id2 [info object creationid [set o2 [cls new]]] + if {$id1 == $id2} { + format "objects %s and %s have same creation id: %d" $o1 $o2 $id1 + } else { + string cat not-equal + } +} -cleanup { + cls destroy +} -result not-equal +test oo-16.21 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + set id1 [info object creationid [set o1 [cls new]]] + set id2 [info object creationid [set o2 [oo::copy $o1]]] + if {$id1 == $id2} { + format "objects %s and %s have same creation id: %d" $o1 $o2 $id1 + } else { + string cat not-equal + } +} -cleanup { + cls destroy +} -result not-equal test oo-17.1 {OO: class introspection} -body { info class -- cgit v0.12 From 28e500cbf94b82fc75c2a0a5007458fc6756504e Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 15 Apr 2018 14:47:26 +0000 Subject: Testing the private variables. --- generic/tclOOInfo.c | 24 +++++++++++++--- tests/oo.test | 82 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 102 insertions(+), 4 deletions(-) diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index bdb67ae..d189528 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -799,21 +799,37 @@ InfoObjectVariablesCmd( Tcl_Obj *const objv[]) { Object *oPtr; - Tcl_Obj *variableObj, *resultObj; - int i; + Tcl_Obj *resultObj; + int i, private = 0; if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?"); return TCL_ERROR; } + if (objc == 3) { + if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { + return TCL_ERROR; + } + private = 1; + } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } resultObj = Tcl_NewObj(); - FOREACH(variableObj, oPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (private) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, oPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; diff --git a/tests/oo.test b/tests/oo.test index f2bce76..fb29464 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4169,6 +4169,88 @@ test oo-36.10 {TIP #470: introspection within oo::define} -setup { Cls destroy catch {rename oo::objdefine::testself {}} } -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}} + +test oo-37.1 {TIP 500: private variables don't cross-interfere with each other or normal ones} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + private variable x + constructor {} { + set x 1 + } + method getA {} { + return $x + } + } + oo::class create clsB { + superclass clsA + private { + variable x + } + constructor {} { + set x 2 + next + } + method getB {} { + return $x + } + } + oo::class create clsC { + superclass clsB + variable x + constructor {} { + set x 3 + next + } + method getC {} { + return $x + } + } + clsC create obj + oo::objdefine obj { + private { + variable x + } + method setup {} { + set x 4 + } + method getO {} { + return $x + } + } + obj setup + list [obj getA] [obj getB] [obj getC] [obj getO] \ + [lsort [string map [list [info object creationid clsA] CLASS-A \ + [info object creationid clsB] CLASS-B \ + [info object creationid obj] OBJ] \ + [info object vars obj]]] +} -cleanup { + parent destroy +} -result {1 2 3 4 {{CLASS-A : x} {CLASS-B : x} {OBJ : x} x}} +test oo-37.2 {TIP 500: private variables introspection} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + private { + variable x1 + variable x2 + } + variable y1 y2 + } + cls create obj + oo::objdefine obj { + private variable a1 a2 + variable b1 b2 + } + list [lsort [info class variables cls]] \ + [lsort [info class variables cls -private]] \ + [lsort [info object variables obj]] \ + [lsort [info object variables obj -private]] +} -cleanup { + parent destroy +} -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}} cleanupTests return -- cgit v0.12 From ad02c0b532b8fd75ad05376bcc62f88318c83ca5 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 15 Apr 2018 15:11:38 +0000 Subject: Added basic tests of the 'private' definition command. --- tests/oo.test | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 50 insertions(+), 2 deletions(-) diff --git a/tests/oo.test b/tests/oo.test index fb29464..491ac20 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4170,7 +4170,55 @@ test oo-36.10 {TIP #470: introspection within oo::define} -setup { catch {rename oo::objdefine::testself {}} } -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}} -test oo-37.1 {TIP 500: private variables don't cross-interfere with each other or normal ones} -setup { +test oo-37.1 {TIP 500: private command propagates errors} -setup { + oo::class create cls +} -body { + oo::define cls { + private ::error "this is an error" + } +} -cleanup { + cls destroy +} -returnCodes error -result {this is an error} +test oo-37.2 {TIP 500: private command propagates errors} -setup { + oo::class create cls +} -body { + oo::define cls { + private { + ::error "this is an error" + } + } +} -cleanup { + cls destroy +} -returnCodes error -result {this is an error} +test oo-37.3 {TIP 500: private command propagates errors} -setup { + oo::object create obj +} -body { + oo::objdefine obj { + private ::error "this is an error" + } +} -cleanup { + obj destroy +} -returnCodes error -result {this is an error} +test oo-37.4 {TIP 500: private command propagates errors} -setup { + oo::object create obj +} -body { + oo::objdefine obj { + private { + ::error "this is an error" + } + } +} -cleanup { + obj destroy +} -returnCodes error -result {this is an error} +test oo-37.5 {TIP 500: private command can't be used outside definitions} -body { + oo::define::private error "xyz" +} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} +test oo-37.6 {TIP 500: private command can't be used outside definitions} -body { + oo::objdefine::private error "xyz" +} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} + + +test oo-38.1 {TIP 500: private variables don't cross-interfere with each other or normal ones} -setup { oo::class create parent } -body { oo::class create clsA { @@ -4228,7 +4276,7 @@ test oo-37.1 {TIP 500: private variables don't cross-interfere with each other o } -cleanup { parent destroy } -result {1 2 3 4 {{CLASS-A : x} {CLASS-B : x} {OBJ : x} x}} -test oo-37.2 {TIP 500: private variables introspection} -setup { +test oo-38.2 {TIP 500: private variables introspection} -setup { oo::class create parent } -body { oo::class create cls { -- cgit v0.12 From f58e9ed8421d4020d88ac31edc1e1954fd7838c4 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 5 May 2018 17:23:17 +0000 Subject: Private methods seem to be working... --- generic/tclOO.c | 25 +++++---- generic/tclOOBasic.c | 3 +- generic/tclOOCall.c | 156 ++++++++++++++++++++++++++++++++++++++++----------- generic/tclOOInfo.c | 3 +- generic/tclOOInt.h | 11 +--- tests/oo.test | 110 +++++++++++++++++++++++++++++++++++- 6 files changed, 253 insertions(+), 55 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 1080967..6aa03fa 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1174,7 +1174,7 @@ ObjectNamespaceDeleted( if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) { CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); + TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL); int result; Tcl_InterpState state; @@ -1651,7 +1651,7 @@ Tcl_NewObjectInstance( if (objc >= 0) { CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); + TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); if (contextPtr != NULL) { int isRoot, result; @@ -1724,7 +1724,7 @@ TclNRNewObjectInstance( *objectPtr = (Tcl_Object) oPtr; return TCL_OK; } - contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); + contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); if (contextPtr == NULL) { *objectPtr = (Tcl_Object) oPtr; return TCL_OK; @@ -2164,7 +2164,8 @@ Tcl_CopyObjectInstance( } TclResetRewriteEnsemble(interp, 1); - contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL); + contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL, + NULL, NULL); if (contextPtr) { args[0] = TclOOObjectName(interp, o2Ptr); args[1] = oPtr->fPtr->clonedName; @@ -2562,6 +2563,8 @@ TclOOObjectCmdCore( CallContext *contextPtr; Tcl_Obj *methodNamePtr; CallFrame *framePtr = ((Interp *) interp)->varFramePtr; + Object *callerObjPtr = NULL; + Class *callerClsPtr = NULL; int result; /* @@ -2585,11 +2588,11 @@ TclOOObjectCmdCore( Method *callerMethodPtr = callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr; - if (callerMethodPtr->declaringObjectPtr == oPtr) { - flags |= OBJECT_PRIVATE_METHOD; + if (callerMethodPtr->declaringObjectPtr) { + callerObjPtr = callerMethodPtr->declaringObjectPtr; } - if (callerMethodPtr->declaringClassPtr == oPtr->selfCls) { - flags |= CLASS_PRIVATE_METHOD; + if (callerMethodPtr->declaringClassPtr) { + callerClsPtr = callerMethodPtr->declaringClassPtr; } } @@ -2620,7 +2623,8 @@ TclOOObjectCmdCore( Tcl_IncrRefCount(mappedMethodName); contextPtr = TclOOGetCallContext(oPtr, mappedMethodName, - flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr); + flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, + callerClsPtr, methodNamePtr); TclDecrRefCount(mappedMethodName); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2637,7 +2641,8 @@ TclOOObjectCmdCore( noMapping: contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, - flags | (oPtr->flags & FILTER_HANDLING), NULL); + flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, + callerClsPtr, NULL); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "impossible to invoke method \"%s\": no defined method or" diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index d874cba..dc49356 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -347,7 +347,8 @@ TclOO_Object_Destroy( } if (!(oPtr->flags & DESTRUCTOR_CALLED)) { oPtr->flags |= DESTRUCTOR_CALLED; - contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); + contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, + NULL); if (contextPtr != NULL) { contextPtr->callPtr->flags |= DESTRUCTOR; contextPtr->skip = 0; diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index aa30808..55f7e5b 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -60,6 +60,13 @@ static inline void AddMethodToCallChain(Method *const mPtr, Tcl_HashTable *const doneFilters, Class *const filterDecl, int flags); static inline void AddSimpleChainToCallContext(Object *const oPtr, + Object *const contextObj, Class *const contextCls, + Tcl_Obj *const methodNameObj, + struct ChainBuilder *const cbPtr, + Tcl_HashTable *const doneFilters, int flags, + Class *const filterDecl); +static void AddPrivatesFromClassChainToCallContext(Class *classPtr, + Class *const contextCls, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags, @@ -703,6 +710,12 @@ AddClassMethodNames( static inline void AddSimpleChainToCallContext( Object *const oPtr, /* Object to add call chain entries for. */ + Object *const contextObj, /* Context object; when equal to oPtr, it + * means that private methods may also be + * added. [TIP 500] */ + Class *const contextCls, /* Context class; the currently considered + * class is equal to this, private methods may + * also be added. [TIP 500] */ Tcl_Obj *const methodNameObj, /* Name of method to add the call chain * entries for. */ @@ -720,7 +733,7 @@ AddSimpleChainToCallContext( Tcl_HashEntry *hPtr; Method *mPtr; - if (flags & OBJECT_PRIVATE_METHOD && oPtr->methodsPtr) { + if ((oPtr == contextObj) && oPtr->methodsPtr) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj); if (hPtr != NULL) { @@ -730,7 +743,6 @@ AddSimpleChainToCallContext( flags); } } - flags &= ~OBJECT_PRIVATE_METHOD; flags |= DEFINITE_PROTECTED; } else if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj); @@ -752,6 +764,11 @@ AddSimpleChainToCallContext( Class *mixinPtr; FOREACH(mixinPtr, oPtr->mixins) { + if (contextCls) { + AddPrivatesFromClassChainToCallContext(mixinPtr, contextCls, + methodNameObj, cbPtr, doneFilters, + flags|TRAVERSED_MIXIN, filterDecl); + } AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, doneFilters, flags|TRAVERSED_MIXIN, filterDecl); } @@ -766,6 +783,10 @@ AddSimpleChainToCallContext( } } } + if (contextCls) { + AddPrivatesFromClassChainToCallContext(oPtr->selfCls, contextCls, + methodNameObj, cbPtr, doneFilters, flags, filterDecl); + } AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr, doneFilters, flags, filterDecl); } @@ -971,6 +992,12 @@ TclOOGetCallContext( * Only the bits PUBLIC_METHOD, CONSTRUCTOR, * PRIVATE_METHOD, DESTRUCTOR and * FILTER_HANDLING are useful. */ + Object *contextObj, /* Context object; when equal to oPtr, it + * means that private methods may also be + * added. [TIP 500] */ + Class *contextCls, /* Context class; the currently considered + * class is equal to this, private methods may + * also be added. [TIP 500] */ Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is * to be in the same object as the * methodNameObj. */ @@ -1070,10 +1097,11 @@ TclOOGetCallContext( */ if (flags & FORCE_UNKNOWN) { - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, 0, NULL); + AddSimpleChainToCallContext(oPtr, NULL, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, + NULL); + AddSimpleChainToCallContext(oPtr, NULL, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (callPtr->numChain == 0) { @@ -1102,10 +1130,10 @@ TclOOGetCallContext( OBJECT_MIXIN); } FOREACH(filterObj, oPtr->filters) { - AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, - BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0, - NULL); + AddSimpleChainToCallContext(oPtr, contextObj, contextCls, + filterObj, &cb, &doneFilters, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(oPtr, contextObj, contextCls, + filterObj, &cb, &doneFilters, 0, NULL); } AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters, BUILDING_MIXINS); @@ -1120,9 +1148,10 @@ TclOOGetCallContext( * handle class mixins right. */ - AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, - flags|BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL); + AddSimpleChainToCallContext(oPtr, contextObj, contextCls, methodNameObj, + &cb, NULL, flags|BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(oPtr, contextObj, contextCls, methodNameObj, + &cb, NULL, flags, NULL); /* * Check to see if the method has no implementation. If so, we probably @@ -1140,10 +1169,11 @@ TclOOGetCallContext( TclOODeleteChain(callPtr); return NULL; } - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, 0, NULL); + AddSimpleChainToCallContext(oPtr, NULL, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, + NULL); + AddSimpleChainToCallContext(oPtr, NULL, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (count == callPtr->numChain) { @@ -1301,9 +1331,10 @@ TclOOGetStereotypeCallChain( * Add the actual method implementations. */ - AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, + AddSimpleChainToCallContext(&obj, NULL, NULL, methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL); + AddSimpleChainToCallContext(&obj, NULL, NULL, methodNameObj, &cb, NULL, + flags, NULL); /* * Check to see if the method has no implementation. If so, we probably @@ -1312,10 +1343,10 @@ TclOOGetStereotypeCallChain( */ if (count == callPtr->numChain) { - AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, - NULL, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, - NULL, 0, NULL); + AddSimpleChainToCallContext(&obj, NULL, NULL, + fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(&obj, NULL, NULL, + fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (count == callPtr->numChain) { @@ -1395,9 +1426,9 @@ AddClassFiltersToCallContext( (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew); if (isNew) { - AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, + AddSimpleChainToCallContext(oPtr, NULL, NULL, filterObj, cbPtr, doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr); - AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, + AddSimpleChainToCallContext(oPtr, NULL, NULL, filterObj, cbPtr, doneFilters, clearedFlags, clsPtr); } } @@ -1432,8 +1463,11 @@ AddClassFiltersToCallContext( */ static void -AddSimpleClassChainToCallContext( +AddPrivatesFromClassChainToCallContext( Class *classPtr, /* Class to add the call chain entries for. */ + Class *const contextCls, /* Context class; the currently considered + * class is equal to this, private methods may + * also be added. [TIP 500] */ Tcl_Obj *const methodNameObj, /* Name of method to add the call chain * entries for. */ @@ -1447,10 +1481,70 @@ AddSimpleClassChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i, private = (flags & CLASS_PRIVATE_METHOD); + int i; Class *superPtr; - flags &= ~CLASS_PRIVATE_METHOD; + /* + * We hard-code the tail-recursive form. It's by far the most common case + * *and* it is much more gentle on the stack. + * + * Note that mixins must be processed before the main class hierarchy. + * [Bug 1998221] + */ + + tailRecurse: + FOREACH(superPtr, classPtr->mixins) { + AddPrivatesFromClassChainToCallContext(superPtr, contextCls, + methodNameObj, cbPtr, doneFilters, flags|TRAVERSED_MIXIN, + filterDecl); + } + + if (classPtr == contextCls) { + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, + (char *) methodNameObj); + + if (hPtr != NULL) { + register Method *mPtr = Tcl_GetHashValue(hPtr); + + if (mPtr->flags & TRUE_PRIVATE_METHOD) { + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); + } + } + } + + switch (classPtr->superclasses.num) { + case 1: + classPtr = classPtr->superclasses.list[0]; + goto tailRecurse; + default: + FOREACH(superPtr, classPtr->superclasses) { + AddPrivatesFromClassChainToCallContext(superPtr, contextCls, + methodNameObj, cbPtr, doneFilters, flags, filterDecl); + } + case 0: + return; + } +} + +static void +AddSimpleClassChainToCallContext( + Class *classPtr, /* Class to add the call chain entries for. */ + Tcl_Obj *const methodNameObj, + /* Name of method to add the call chain + * entries for. */ + struct ChainBuilder *const cbPtr, + /* Where to add the call chain entries. */ + Tcl_HashTable *const doneFilters, + /* Where to record what call chain entries + * have been processed. */ + int flags, /* What sort of call chain are we building. */ + Class *const filterDecl) /* The class that declared the filter. If + * NULL, either the filter was declared by the + * object or this isn't a filter. */ +{ + int i; + Class *superPtr; /* * We hard-code the tail-recursive form. It's by far the most common case @@ -1480,9 +1574,7 @@ AddSimpleClassChainToCallContext( if (hPtr != NULL) { register Method *mPtr = Tcl_GetHashValue(hPtr); - if (private && mPtr->flags & TRUE_PRIVATE_METHOD) { - flags |= DEFINITE_PROTECTED; - } else if (!(flags & KNOWN_STATE)) { + if (!(flags & KNOWN_STATE)) { if (flags & PUBLIC_METHOD) { if (mPtr->flags & PUBLIC_METHOD) { flags |= DEFINITE_PUBLIC; @@ -1493,7 +1585,7 @@ AddSimpleClassChainToCallContext( flags |= DEFINITE_PROTECTED; } } - if (private || !(mPtr->flags & TRUE_PRIVATE_METHOD)) { + if (!(mPtr->flags & TRUE_PRIVATE_METHOD)) { AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags); } diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index d189528..30cf8af 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -1597,7 +1597,8 @@ InfoObjectCallCmd( * Get the call context and render its call chain. */ - contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL); + contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL, + NULL); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot construct any call chain", -1)); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 55847ca..1937680 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -403,16 +403,6 @@ typedef struct CallContext { /* This is a private method only accessible * from other methods defined on this class * or instance. [TIP #500] */ -#define OBJECT_PRIVATE_METHOD 0x40 - /* This is a call of a method on an object - * that may include TRUE_PRIVATE_METHOD - * instance method implementations in its call - * chain. */ -#define CLASS_PRIVATE_METHOD 0x80 - /* This is a call of a method on an object - * that may include TRUE_PRIVATE_METHOD class - * method implementations in its call - * chain. */ /* * Structure containing definition information about basic class methods. @@ -546,6 +536,7 @@ MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr); MODULE_SCOPE void TclOODelMethodRef(Method *method); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, + Object *contextObjPtr, Class *contextClsPtr, Tcl_Obj *cacheInThisObj); MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr, Tcl_Obj *methodNameObj, int flags); diff --git a/tests/oo.test b/tests/oo.test index 491ac20..1075d0d 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4217,7 +4217,6 @@ test oo-37.6 {TIP 500: private command can't be used outside definitions} -body oo::objdefine::private error "xyz" } -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} - test oo-38.1 {TIP 500: private variables don't cross-interfere with each other or normal ones} -setup { oo::class create parent } -body { @@ -4299,6 +4298,115 @@ test oo-38.2 {TIP 500: private variables introspection} -setup { } -cleanup { parent destroy } -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}} + +test oo-38.1 {TIP 500: private methods internal call} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my step + my step + my step + return + } + private { + method step {} { + incr x 2 + } + } + method x {} { + return $x + } + } + clsA create obj + obj act + list [obj x] [catch {obj step} msg] $msg +} -cleanup { + parent destroy +} -result {7 1 {unknown method "step": must be act, destroy or x}} +test oo-38.2 {TIP 500: private methods internal call} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my step + my step + my step + return + } + private { + method step {} { + incr x 2 + } + } + method x {} { + return $x + } + } + oo::class create clsB { + superclass clsA + variable x + method step {} { + incr x 5 + } + } + clsB create obj + obj act + list [obj x] [obj step] +} -cleanup { + parent destroy +} -result {7 12} +test oo-38.3 {TIP 500: private methods internal call} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my Step + my Step + my Step + return + } + method x {} { + return $x + } + } + oo::class create clsB { + superclass clsA + variable x + method Step {} { + incr x 5 + } + } + clsB create obj + obj act + set result [obj x] + oo::define clsA { + private { + method Step {} { + incr x 2 + } + } + } + obj act + lappend result [obj x] +} -cleanup { + parent destroy +} -result {16 22} cleanupTests return -- cgit v0.12 From 2a19591dc76f5811ee0ebacb3610cad0ff165aec Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 6 May 2018 07:13:30 +0000 Subject: Fix up instance privates. --- generic/tclOOCall.c | 183 +++++++++++++++++++++++++++++++++------------------- tests/oo.test | 44 +++++++++++++ 2 files changed, 160 insertions(+), 67 deletions(-) diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 55f7e5b..becf7ff 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -59,13 +59,16 @@ static inline void AddMethodToCallChain(Method *const mPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, Class *const filterDecl, int flags); -static inline void AddSimpleChainToCallContext(Object *const oPtr, - Object *const contextObj, Class *const contextCls, +static inline int AddInstancePrivateToCallContext(Object *const oPtr, + Tcl_Obj *const methodNameObj, + struct ChainBuilder *const cbPtr, int flags); +static inline int AddSimpleChainToCallContext(Object *const oPtr, + Class *const contextCls, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags, Class *const filterDecl); -static void AddPrivatesFromClassChainToCallContext(Class *classPtr, +static int AddPrivatesFromClassChainToCallContext(Class *classPtr, Class *const contextCls, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, @@ -697,22 +700,58 @@ AddClassMethodNames( /* * ---------------------------------------------------------------------- * + * AddInstancePrivateToCallContext -- + * + * Add private methods from the instance. Called when the calling Tcl + * context is a TclOO method declared by an object that is the same as + * the current object. Returns true iff a private method was actually + * found and added to the call chain (as this suppresses caching). + * + * ---------------------------------------------------------------------- + */ + +static inline int +AddInstancePrivateToCallContext( + Object *const oPtr, /* Object to add call chain entries for. */ + Tcl_Obj *const methodName, /* Name of method to add the call chain + * entries for. */ + struct ChainBuilder *const cbPtr, + /* Where to add the call chain entries. */ + int flags) /* What sort of call chain are we building. */ +{ + Tcl_HashEntry *hPtr; + Method *mPtr; + int donePrivate = 0; + + if (oPtr->methodsPtr) { + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName); + if (hPtr != NULL) { + mPtr = Tcl_GetHashValue(hPtr); + if (mPtr->flags & TRUE_PRIVATE_METHOD) { + AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags); + donePrivate = 1; + } + } + } + return donePrivate; +} + +/* + * ---------------------------------------------------------------------- + * * AddSimpleChainToCallContext -- * * The core of the call-chain construction engine, this handles calling a * particular method on a particular object. Note that filters and * unknown handling are already handled by the logic that uses this - * function. + * function. Returns true if a private method was one of those found. * * ---------------------------------------------------------------------- */ -static inline void +static inline int AddSimpleChainToCallContext( Object *const oPtr, /* Object to add call chain entries for. */ - Object *const contextObj, /* Context object; when equal to oPtr, it - * means that private methods may also be - * added. [TIP 500] */ Class *const contextCls, /* Context class; the currently considered * class is equal to this, private methods may * also be added. [TIP 500] */ @@ -729,34 +768,25 @@ AddSimpleChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i; + int i, foundPrivate = 0; Tcl_HashEntry *hPtr; Method *mPtr; - if ((oPtr == contextObj) && oPtr->methodsPtr) { - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj); - - if (hPtr != NULL) { - mPtr = Tcl_GetHashValue(hPtr); - if (mPtr->flags & TRUE_PRIVATE_METHOD) { - AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, - flags); - } - } - flags |= DEFINITE_PROTECTED; - } else if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) { + if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj); if (hPtr != NULL) { mPtr = Tcl_GetHashValue(hPtr); - if (flags & PUBLIC_METHOD) { - if (!(mPtr->flags & PUBLIC_METHOD)) { - return; + if (!(mPtr->flags & TRUE_PRIVATE_METHOD)) { + if (flags & PUBLIC_METHOD) { + if (!(mPtr->flags & PUBLIC_METHOD)) { + return 0; + } else { + flags |= DEFINITE_PUBLIC; + } } else { - flags |= DEFINITE_PUBLIC; + flags |= DEFINITE_PROTECTED; } - } else { - flags |= DEFINITE_PROTECTED; } } } @@ -765,9 +795,9 @@ AddSimpleChainToCallContext( FOREACH(mixinPtr, oPtr->mixins) { if (contextCls) { - AddPrivatesFromClassChainToCallContext(mixinPtr, contextCls, - methodNameObj, cbPtr, doneFilters, - flags|TRAVERSED_MIXIN, filterDecl); + foundPrivate |= AddPrivatesFromClassChainToCallContext( + mixinPtr, contextCls, methodNameObj, cbPtr, + doneFilters, flags|TRAVERSED_MIXIN, filterDecl); } AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, doneFilters, flags|TRAVERSED_MIXIN, filterDecl); @@ -784,11 +814,13 @@ AddSimpleChainToCallContext( } } if (contextCls) { - AddPrivatesFromClassChainToCallContext(oPtr->selfCls, contextCls, - methodNameObj, cbPtr, doneFilters, flags, filterDecl); + foundPrivate |= AddPrivatesFromClassChainToCallContext(oPtr->selfCls, + contextCls, methodNameObj, cbPtr, doneFilters, flags, + filterDecl); } AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr, doneFilters, flags, filterDecl); + return foundPrivate; } /* @@ -1005,7 +1037,7 @@ TclOOGetCallContext( CallContext *contextPtr; CallChain *callPtr; struct ChainBuilder cb; - int i, count, doFilters; + int i, count, doFilters, donePrivate = 0; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; @@ -1097,10 +1129,10 @@ TclOOGetCallContext( */ if (flags & FORCE_UNKNOWN) { - AddSimpleChainToCallContext(oPtr, NULL, NULL, + AddSimpleChainToCallContext(oPtr, NULL, oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, NULL, NULL, + AddSimpleChainToCallContext(oPtr, NULL, oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; @@ -1130,9 +1162,9 @@ TclOOGetCallContext( OBJECT_MIXIN); } FOREACH(filterObj, oPtr->filters) { - AddSimpleChainToCallContext(oPtr, contextObj, contextCls, + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, filterObj, &cb, &doneFilters, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, contextObj, contextCls, + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, filterObj, &cb, &doneFilters, 0, NULL); } AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters, @@ -1148,10 +1180,14 @@ TclOOGetCallContext( * handle class mixins right. */ - AddSimpleChainToCallContext(oPtr, contextObj, contextCls, methodNameObj, - &cb, NULL, flags|BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, contextObj, contextCls, methodNameObj, - &cb, NULL, flags, NULL); + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); + if (oPtr == contextObj) { + donePrivate |= AddInstancePrivateToCallContext(oPtr, methodNameObj, + &cb, flags); + } + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + methodNameObj, &cb, NULL, flags, NULL); /* * Check to see if the method has no implementation. If so, we probably @@ -1169,10 +1205,10 @@ TclOOGetCallContext( TclOODeleteChain(callPtr); return NULL; } - AddSimpleChainToCallContext(oPtr, NULL, NULL, + AddSimpleChainToCallContext(oPtr, NULL, oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, NULL, NULL, + AddSimpleChainToCallContext(oPtr, NULL, oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; @@ -1180,7 +1216,7 @@ TclOOGetCallContext( TclOODeleteChain(callPtr); return NULL; } - } else if (doFilters) { + } else if (doFilters && !donePrivate) { if (hPtr == NULL) { if (oPtr->flags & USE_CLASS_CACHE) { if (oPtr->selfCls->classChainCache == NULL) { @@ -1331,10 +1367,10 @@ TclOOGetStereotypeCallChain( * Add the actual method implementations. */ - AddSimpleChainToCallContext(&obj, NULL, NULL, methodNameObj, &cb, NULL, + AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(&obj, NULL, NULL, methodNameObj, &cb, NULL, - flags, NULL); + AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, flags, + NULL); /* * Check to see if the method has no implementation. If so, we probably @@ -1343,10 +1379,10 @@ TclOOGetStereotypeCallChain( */ if (count == callPtr->numChain) { - AddSimpleChainToCallContext(&obj, NULL, NULL, - fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(&obj, NULL, NULL, - fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); + AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj, + &cb, NULL, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj, + &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (count == callPtr->numChain) { @@ -1426,9 +1462,9 @@ AddClassFiltersToCallContext( (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew); if (isNew) { - AddSimpleChainToCallContext(oPtr, NULL, NULL, filterObj, cbPtr, + AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr, doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr); - AddSimpleChainToCallContext(oPtr, NULL, NULL, filterObj, cbPtr, + AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr, doneFilters, clearedFlags, clsPtr); } } @@ -1455,21 +1491,22 @@ AddClassFiltersToCallContext( /* * ---------------------------------------------------------------------- * - * AddSimpleClassChainToCallContext -- + * AddPrivatesFromClassChainToCallContext -- * - * Construct a call-chain from a class hierarchy. + * Helper for AddSimpleChainToCallContext that is used to find private + * methds and add them to the call chain. Returns true when a private + * method is found and added. [TIP 500] * * ---------------------------------------------------------------------- */ -static void +static int AddPrivatesFromClassChainToCallContext( Class *classPtr, /* Class to add the call chain entries for. */ Class *const contextCls, /* Context class; the currently considered * class is equal to this, private methods may - * also be added. [TIP 500] */ - Tcl_Obj *const methodNameObj, - /* Name of method to add the call chain + * also be added. */ + Tcl_Obj *const methodName, /* Name of method to add the call chain * entries for. */ struct ChainBuilder *const cbPtr, /* Where to add the call chain entries. */ @@ -1481,7 +1518,7 @@ AddPrivatesFromClassChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i; + int i, foundPrivate = 0; Class *superPtr; /* @@ -1494,14 +1531,14 @@ AddPrivatesFromClassChainToCallContext( tailRecurse: FOREACH(superPtr, classPtr->mixins) { - AddPrivatesFromClassChainToCallContext(superPtr, contextCls, - methodNameObj, cbPtr, doneFilters, flags|TRAVERSED_MIXIN, - filterDecl); + foundPrivate |= AddPrivatesFromClassChainToCallContext(superPtr, + contextCls, methodName, cbPtr, doneFilters, + flags|TRAVERSED_MIXIN, filterDecl); } if (classPtr == contextCls) { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, - (char *) methodNameObj); + (char *) methodName); if (hPtr != NULL) { register Method *mPtr = Tcl_GetHashValue(hPtr); @@ -1509,6 +1546,7 @@ AddPrivatesFromClassChainToCallContext( if (mPtr->flags & TRUE_PRIVATE_METHOD) { AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags); + foundPrivate = 1; } } } @@ -1519,13 +1557,24 @@ AddPrivatesFromClassChainToCallContext( goto tailRecurse; default: FOREACH(superPtr, classPtr->superclasses) { - AddPrivatesFromClassChainToCallContext(superPtr, contextCls, - methodNameObj, cbPtr, doneFilters, flags, filterDecl); + foundPrivate |= AddPrivatesFromClassChainToCallContext(superPtr, + contextCls, methodName, cbPtr, doneFilters, flags, + filterDecl); } case 0: - return; + return foundPrivate; } } + +/* + * ---------------------------------------------------------------------- + * + * AddSimpleClassChainToCallContext -- + * + * Construct a call-chain from a class hierarchy. + * + * ---------------------------------------------------------------------- + */ static void AddSimpleClassChainToCallContext( diff --git a/tests/oo.test b/tests/oo.test index 1075d0d..8a1718e 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4407,6 +4407,50 @@ test oo-38.3 {TIP 500: private methods internal call} -setup { } -cleanup { parent destroy } -result {16 22} +test oo-38.4 {TIP 500: private methods internal call} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my step + return + } + method step {} { + incr x + } + method x {} { + return $x + } + } + clsA create obj + obj act + set result [obj x] + oo::objdefine obj { + variable x + private { + method step {} { + incr x 2 + } + } + } + obj act + lappend result [obj x] + oo::objdefine obj { + method act {} { + my step + next + } + } + obj act + lappend result [obj x] +} -cleanup { + parent destroy +} -result {2 3 6} cleanupTests return -- cgit v0.12 From 13bdb0305c528847cf3e006d30905860ca9ea1b1 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 6 May 2018 07:17:27 +0000 Subject: Corrections to test names. --- tests/oo.test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/oo.test b/tests/oo.test index 8a1718e..6ebeb99 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4299,7 +4299,7 @@ test oo-38.2 {TIP 500: private variables introspection} -setup { parent destroy } -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}} -test oo-38.1 {TIP 500: private methods internal call} -setup { +test oo-39.1 {TIP 500: private methods internal call; class private} -setup { oo::class create parent } -body { oo::class create clsA { @@ -4329,7 +4329,7 @@ test oo-38.1 {TIP 500: private methods internal call} -setup { } -cleanup { parent destroy } -result {7 1 {unknown method "step": must be act, destroy or x}} -test oo-38.2 {TIP 500: private methods internal call} -setup { +test oo-39.2 {TIP 500: private methods internal call; class private} -setup { oo::class create parent } -body { oo::class create clsA { @@ -4366,7 +4366,7 @@ test oo-38.2 {TIP 500: private methods internal call} -setup { } -cleanup { parent destroy } -result {7 12} -test oo-38.3 {TIP 500: private methods internal call} -setup { +test oo-39.3 {TIP 500: private methods internal call; class private} -setup { oo::class create parent } -body { oo::class create clsA { @@ -4407,7 +4407,7 @@ test oo-38.3 {TIP 500: private methods internal call} -setup { } -cleanup { parent destroy } -result {16 22} -test oo-38.4 {TIP 500: private methods internal call} -setup { +test oo-39.4 {TIP 500: private methods internal call; instance private} -setup { oo::class create parent } -body { oo::class create clsA { -- cgit v0.12 From 66525c95eedb95b9387daeb7f30df0cbb0476ab5 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 6 May 2018 14:20:29 +0000 Subject: Documentation. --- doc/define.n | 93 +++++++++++++++++++++++++++++++++++++++++++++++++++-- doc/info.n | 12 +++++++ generic/tclOOCall.c | 4 +-- 3 files changed, 105 insertions(+), 4 deletions(-) diff --git a/doc/define.n b/doc/define.n index c836c2f..d68e463 100644 --- a/doc/define.n +++ b/doc/define.n @@ -105,6 +105,13 @@ fully-qualified, the command will be searched for in each object's namespace, using the instances' namespace's path, or by looking in the global namespace. The method will be exported if \fIname\fR starts with a lower-case letter, and non-exported otherwise. +.RS +.PP +.VS TIP500 +If in a private definition context (see the \fBprivate\fR definition command, +below), this command creates private forwarded methods. +.VE TIP500 +.RE .TP \fBmethod\fI name argList bodyScript\fR . @@ -117,6 +124,13 @@ be a namespace that is unique to the current object. The method will be exported if \fIname\fR starts with a lower-case letter, and non-exported otherwise; this behavior can be overridden via \fBexport\fR and \fBunexport\fR. +.RS +.PP +.VS TIP500 +If in a private definition context (see the \fBprivate\fR definition command, +below), this command creates private procedure-like methods. +.VE TIP500 +.RE .TP \fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? .VS @@ -129,6 +143,16 @@ names a single class that is to be mixed in. By default, this slot works by replacement. .VE .TP +\fBprivate \fIcmd arg...\fR +.TP +\fBprivate \fIscript\fR +. +.VS TIP500 +This evaluates the \fIscript\fR (or the list of command and arguments given by +\fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the +current class will be private definitions. +.VE TIP500 +.TP \fBrenamemethod\fI fromName toName\fR . This renames the method called \fIfromName\fR in a class to \fItoName\fR. The @@ -191,11 +215,25 @@ variables to be automatically made available in the methods, constructor and destructor declared by the class being defined. Each variable name must not have any namespace separators and must not look like an array access. All variables will be -actually present in the instance object on which the method is executed. Note +actually present in the namespace of the instance object on which the method +is executed. Note that the variable lists declared by a superclass or subclass are completely disjoint, as are variable lists declared by instances; the list of variable names is just for methods (and constructors and destructors) declared by this class. By default, this slot works by appending. +.RS +.PP +.VS TIP500 +If in a private definition context (see the \fBprivate\fR definition command, +below), this slot manipulates the list of private variable bindings for this +class. In a private variable binding, the name of the variable within the +instance object is different to the name given in the definition; the name +used in the definition is the name that you use to access the variable within +the methods of this class, and the name of the variable in the instance +namespace has a unique prefix that makes accidental use from other classes +extremely unlikely. +.VE TIP500 +.RE .VE .SS "CONFIGURING OBJECTS" .PP @@ -244,6 +282,13 @@ additional arguments, \fIarg\fR etc., added before those arguments specified by the caller of the method. Forwarded methods should be deleted using the \fBmethod\fR subcommand. The method will be exported if \fIname\fR starts with a lower-case letter, and non-exported otherwise. +.RS +.PP +.VS TIP500 +If in a private definition context (see the \fBprivate\fR definition command, +below), this command creates private forwarded methods. +.VE TIP500 +.RE .TP \fBmethod\fI name argList bodyScript\fR . @@ -254,6 +299,13 @@ method will be \fIbodyScript\fR. When the body of the method is evaluated, the current namespace of the method will be a namespace that is unique to the object. The method will be exported if \fIname\fR starts with a lower-case letter, and non-exported otherwise. +.RS +.PP +.VS TIP500 +If in a private definition context (see the \fBprivate\fR definition command, +below), this command creates private procedure-like methods. +.VE TIP500 +.RE .TP \fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? .VS @@ -266,6 +318,16 @@ that is to be mixed in. By default, this slot works by replacement. .VE .TP +\fBprivate \fIcmd arg...\fR +.TP +\fBprivate \fIscript\fR +. +.VS TIP500 +This evaluates the \fIscript\fR (or the list of command and arguments given by +\fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the +current object will be private definitions. +.VE TIP500 +.TP \fBrenamemethod\fI fromName toName\fR . This renames the method called \fIfromName\fR in an object to \fItoName\fR. @@ -294,10 +356,37 @@ This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named variables to be automatically made available in the methods declared by the object being defined. Each variable name must not have any namespace separators and must not look like an array access. All variables will be -actually present in the object on which the method is executed. Note that the +actually present in the namespace of the object on which the method is +executed. Note that the variable lists declared by the classes and mixins of which the object is an instance are completely disjoint; the list of variable names is just for methods declared by this object. By default, this slot works by appending. +.RS +.PP +.VS TIP500 +If in a private definition context (see the \fBprivate\fR definition command, +below), this slot manipulates the list of private variable bindings for this +object. In a private variable binding, the name of the variable within the +instance object is different to the name given in the definition; the name +used in the definition is the name that you use to access the variable within +the methods of this instance object, and the name of the variable in the +instance namespace has a unique prefix that makes accidental use from +superclass methods extremely unlikely. +.VE TIP500 +.RE +.SH "PRIVATE METHODS" +.VS TIP500 +When a class or instance has a private method, that private method can only be +invoked from within methods of that class or instance. Other callers of the +object's methods \fIcannot\fR invoke private methods, it is as if the private +methods do not exist. However, a private method of a class \fIcan\fR be +invoked from the class's methods when those methods are being used on another +instance object; this means that a class can use them to coordinate behaviour +between several instances of itself without interfering with how other +classes (especially either subclasses or superclasses) interact. Private +methods precede all mixed in classes in the method call order (as reported by +\fBself call\fR). +.VE TIP500 .SH "SLOTTED DEFINITIONS" Some of the configurable definitions of a class or object are \fIslotted definitions\fR. This means that the configuration is implemented by a slot diff --git a/doc/info.n b/doc/info.n index c3a62c9..9fb89fa 100644 --- a/doc/info.n +++ b/doc/info.n @@ -561,6 +561,18 @@ If \fIclassName\fR is unspecified, this subcommand returns class of the boolean value indicating whether the \fIobject\fR is of that class. .VE 8.6 .TP +\fBinfo object creationid\fI object\fR +.VS TIP500 +Returns the unique creation identifier for the \fIobject\fR object. This +creation identifier is unique to the object (within a Tcl interpreter) and +cannot be controlled at object creation time or altered afterwards. +.RS +.PP +\fIImplementation note:\fR the creation identifier is used to generate unique +identifiers associated with the object, especially for private variables. +.RE +.VE TIP500 +.TP \fBinfo object definition\fI object method\fR .VS 8.6 This subcommand returns a description of the definition of the method named diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index becf7ff..40562e3 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -1180,13 +1180,13 @@ TclOOGetCallContext( * handle class mixins right. */ - donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, - methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); if (oPtr == contextObj) { donePrivate |= AddInstancePrivateToCallContext(oPtr, methodNameObj, &cb, flags); } donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, methodNameObj, &cb, NULL, flags, NULL); /* -- cgit v0.12 From 5cef8b0f8e5bcecd44d03df35952b0df592e6528 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 7 May 2018 12:43:40 +0000 Subject: Make the 'varname' method know about private variables. --- generic/tclOOBasic.c | 53 ++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/oo.test | 34 +++++++++++++++++++++++++++++++++ 2 files changed, 87 insertions(+) diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index dc49356..7af25c0 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -685,6 +685,7 @@ TclOO_Object_VarName( { Var *varPtr, *aryVar; Tcl_Obj *varNamePtr, *argPtr; + CallFrame *framePtr = ((Interp *) interp)->varFramePtr; const char *arg; if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { @@ -710,6 +711,58 @@ TclOO_Object_VarName( Tcl_Namespace *namespacePtr = Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)); + /* + * Private method handling. [TIP 500] + * + * If we're in a context that can see some private methods of an + * object, we may need to precede a variable name with its prefix. + * This is a little tricky as we need to check through the inheritance + * hierarchy when the method was declared by a class to see if the + * current object is an instance of that class. + */ + + if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + CallContext *callerContext = framePtr->clientData; + Method *mPtr = callerContext->callPtr->chain[ + callerContext->index].mPtr; + PrivateVariableMapping *pvPtr; + int i; + + if (mPtr->declaringObjectPtr == oPtr) { + FOREACH_STRUCT(pvPtr, oPtr->privateVariables) { + if (!strcmp(Tcl_GetString(pvPtr->variableObj), + Tcl_GetString(argPtr))) { + argPtr = pvPtr->fullNameObj; + break; + } + } + } else if (mPtr->declaringClassPtr && + mPtr->declaringClassPtr->privateVariables.num) { + Class *clsPtr = mPtr->declaringClassPtr; + int isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls); + Class *mixinCls; + + if (!isInstance) { + FOREACH(mixinCls, oPtr->mixins) { + if (TclOOIsReachable(clsPtr, mixinCls)) { + isInstance = 1; + break; + } + } + } + if (isInstance) { + FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) { + if (!strcmp(Tcl_GetString(pvPtr->variableObj), + Tcl_GetString(argPtr))) { + argPtr = pvPtr->fullNameObj; + break; + } + } + } + } + } + varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1); Tcl_AppendToObj(varNamePtr, "::", 2); Tcl_AppendObjToObj(varNamePtr, argPtr); diff --git a/tests/oo.test b/tests/oo.test index 6ebeb99..b97503d 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4298,6 +4298,40 @@ test oo-38.2 {TIP 500: private variables introspection} -setup { } -cleanup { parent destroy } -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}} +test oo-38.3 {TIP 500: private variables and obj·varname} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + private { + variable x + } + method getx {} { + set x 1 + my varname x + } + method readx {} { + return $x + } + } + oo::class create clsB { + superclass clsA + variable x + method gety {} { + set x 1 + my varname x + } + method ready {} { + return $x + } + } + clsB create obj + set [obj getx] 2 + set [obj gety] 3 + list [obj readx] [obj ready] +} -cleanup { + parent destroy +} -result {2 3} test oo-39.1 {TIP 500: private methods internal call; class private} -setup { oo::class create parent -- cgit v0.12 From 08f43a1ff49699c5bff357c9e7d56d2a06613179 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 7 May 2018 15:42:08 +0000 Subject: More efficient way of getting array element names; why search when direct lookup is possible? --- generic/tclOOBasic.c | 18 ++++-------------- 1 file changed, 4 insertions(+), 14 deletions(-) diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 7af25c0..6306416 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -783,26 +783,16 @@ TclOO_Object_VarName( varNamePtr = Tcl_NewObj(); if (aryVar != NULL) { - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr); /* * WARNING! This code pokes inside the implementation of hash tables! */ - hPtr = Tcl_FirstHashEntry((Tcl_HashTable *) aryVar->value.tablePtr, - &search); - while (hPtr != NULL) { - if (varPtr == Tcl_GetHashValue(hPtr)) { - Tcl_AppendToObj(varNamePtr, "(", -1); - Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr); - Tcl_AppendToObj(varNamePtr, ")", -1); - break; - } - hPtr = Tcl_NextHashEntry(&search); - } + Tcl_AppendToObj(varNamePtr, "(", -1); + Tcl_AppendObjToObj(varNamePtr, ((VarInHash *) + varPtr)->entry.key.objPtr); + Tcl_AppendToObj(varNamePtr, ")", -1); } else { Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr); } -- cgit v0.12 From 9333525d11e12a66c55b6fff2721bf601abb5763 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 13 May 2018 16:10:44 +0000 Subject: Make [info vars] aware of private variable resolution. --- generic/tclVar.c | 33 +++++++++++++++++++++++++++++---- tests/oo.test | 40 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 69 insertions(+), 4 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index d5e0fa1..7a4d4e9 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -6323,25 +6323,50 @@ AppendLocals( } if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) { - CallContext *contextPtr = iPtr->varFramePtr->clientData; - Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; + Method *mPtr = (Method *) + Tcl_ObjectContextMethod(iPtr->varFramePtr->clientData); + PrivateVariableMapping *privatePtr; if (mPtr->declaringObjectPtr) { - FOREACH(objNamePtr, mPtr->declaringObjectPtr->variables) { + Object *oPtr = mPtr->declaringObjectPtr; + + FOREACH(objNamePtr, oPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } } + FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { + Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, + &added); + if (added && (!pattern || + Tcl_StringMatch(TclGetString(privatePtr->variableObj), + pattern))) { + Tcl_ListObjAppendElement(interp, listPtr, + privatePtr->variableObj); + } + } } else { - FOREACH(objNamePtr, mPtr->declaringClassPtr->variables) { + Class *clsPtr = mPtr->declaringClassPtr; + + FOREACH(objNamePtr, clsPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } } + FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { + Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, + &added); + if (added && (!pattern || + Tcl_StringMatch(TclGetString(privatePtr->variableObj), + pattern))) { + Tcl_ListObjAppendElement(interp, listPtr, + privatePtr->variableObj); + } + } } } Tcl_DeleteHashTable(&addedTable); diff --git a/tests/oo.test b/tests/oo.test index b97503d..f0c08b4 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4332,6 +4332,46 @@ test oo-38.3 {TIP 500: private variables and obj·varname} -setup { } -cleanup { parent destroy } -result {2 3} +test oo-38.4 {TIP 500: private variables introspection} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + private { + variable x1 x2 + } + variable y1 y2 + constructor {} { + variable z boo + set x1 a + set y1 c + } + method list {} { + variable z + set ok 1 + list [info locals] [lsort [info vars]] [info exist x2] + } + } + cls create obj + oo::objdefine obj { + private variable a1 a2 + variable b1 b2 + method init {} { + # Because we don't have a constructor to do this setup for us + set a1 p + set b1 r + } + method list {} { + variable z + set yes 1 + list {*}[next] [info locals] [lsort [info vars]] [info exist a2] + } + } + obj init + obj list +} -cleanup { + parent destroy +} -result {ok {ok x1 x2 y1 y2 z} 0 yes {a1 a2 b1 b2 yes z} 0} test oo-39.1 {TIP 500: private methods internal call; class private} -setup { oo::class create parent -- cgit v0.12 From 5eef06ea24f7486a2dcca559a64b3ec08f0c6710 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 13 May 2018 19:20:52 +0000 Subject: Correct results from unknown method handler. --- generic/tclOOBasic.c | 26 +++++- generic/tclOOCall.c | 227 +++++++++++++++++++++++++++++++++------------------ generic/tclOOInfo.c | 3 +- generic/tclOOInt.h | 3 +- tests/oo.test | 139 +++++++++++++++++++++++++++++++ 5 files changed, 315 insertions(+), 83 deletions(-) diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 6306416..763f0ad 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -500,9 +500,12 @@ TclOO_Object_Unknown( Tcl_Obj *const *objv) /* The actual arguments. */ { CallContext *contextPtr = (CallContext *) context; + Object *callerObj = NULL; + Class *callerCls = NULL; Object *oPtr = contextPtr->oPtr; const char **methodNames; int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context); + CallFrame *framePtr = ((Interp *) interp)->varFramePtr; Tcl_Obj *errorMsg; /* @@ -517,10 +520,31 @@ TclOO_Object_Unknown( } /* + * Determine if the calling context should know about extra private + * methods, and if so, which. + */ + + if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { + CallContext *callerContext = framePtr->clientData; + Method *mPtr = callerContext->callPtr->chain[ + callerContext->index].mPtr; + + if (mPtr->declaringObjectPtr) { + if (oPtr == mPtr->declaringObjectPtr) { + callerObj = mPtr->declaringObjectPtr; + } + } else { + if (TclOOIsReachable(mPtr->declaringClassPtr, oPtr->selfCls)) { + callerCls = mPtr->declaringClassPtr; + } + } + } + + /* * Get the list of methods that we want to know about. */ - numMethodNames = TclOOGetSortedMethodList(oPtr, + numMethodNames = TclOOGetSortedMethodList(oPtr, callerObj, callerCls, contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames); /* diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 40562e3..494a627 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -87,6 +87,8 @@ static inline int IsStillValid(CallChain *callPtr, Object *oPtr, int flags, int reuseMask); static Tcl_NRPostProc ResetFilterFlags; static Tcl_NRPostProc SetFilterFlags; +static int SortMethodNames(Tcl_HashTable *namesPtr, int flags, + const char ***stringsPtr); static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr); /* @@ -376,6 +378,14 @@ FinalizeMethodRefs( int TclOOGetSortedMethodList( Object *oPtr, /* The object to get the method names for. */ + Object *contextObj, /* From what context object we are inquiring. + * NULL when the context shouldn't see + * object-level private methods. Note that + * flags can override this. */ + Class *contextCls, /* From what context class we are inquiring. + * NULL when the context shouldn't see + * class-level private methods. Note that + * flags can override this. */ int flags, /* Whether we just want the public method * names. */ const char ***stringsPtr) /* Where to write a pointer to the array of @@ -388,12 +398,10 @@ TclOOGetSortedMethodList( * at. Is set-like in nature and keyed by * pointer to class. */ FOREACH_HASH_DECLS; - int i; + int i, numStrings; Class *mixinPtr; Tcl_Obj *namePtr; Method *mPtr; - int isWantedIn; - void *isWanted; Tcl_InitObjHashTable(&names); Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); @@ -415,10 +423,14 @@ TclOOGetSortedMethodList( if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) { continue; } + if (mPtr->flags & TRUE_PRIVATE_METHOD) { + continue; + } hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); if (isNew) { - isWantedIn = ((!(flags & PUBLIC_METHOD) + int isWantedIn = ((!(flags & PUBLIC_METHOD) || mPtr->flags & PUBLIC_METHOD) ? IN_LIST : 0); + isWantedIn |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); } @@ -431,18 +443,21 @@ TclOOGetSortedMethodList( if (flags & PRIVATE_METHOD) { FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) { - if (mPtr->flags & PRIVATE_METHOD) { + if ((mPtr->flags & PRIVATE_METHOD) + && !(mPtr->flags & TRUE_PRIVATE_METHOD)) { int isNew; hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); if (isNew) { - isWantedIn = IN_LIST; + int isWantedIn = IN_LIST; + if (mPtr->typePtr == NULL) { isWantedIn |= NO_IMPLEMENTATION; } Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); } else if (mPtr->typePtr != NULL) { - isWantedIn = PTR2INT(Tcl_GetHashValue(hPtr)); + int isWantedIn = PTR2INT(Tcl_GetHashValue(hPtr)); + if (isWantedIn & NO_IMPLEMENTATION) { isWantedIn &= ~NO_IMPLEMENTATION; Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); @@ -453,6 +468,32 @@ TclOOGetSortedMethodList( } /* + * Process method names due to private methods on the context's object or + * class. Which must be correct if either are not NULL. + */ + + if (contextObj && contextObj->methodsPtr) { + FOREACH_HASH(namePtr, mPtr, contextObj->methodsPtr) { + if (mPtr->flags & TRUE_PRIVATE_METHOD) { + int isNew; + + hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); + Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST)); + } + } + } + if (contextCls) { + FOREACH_HASH(namePtr, mPtr, &contextCls->classMethods) { + if (mPtr->flags & TRUE_PRIVATE_METHOD) { + int isNew; + + hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); + Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST)); + } + } + } + + /* * Process (normal) method names from the class hierarchy and the mixin * hierarchy. */ @@ -463,50 +504,15 @@ TclOOGetSortedMethodList( &examinedClasses); } - Tcl_DeleteHashTable(&examinedClasses); - /* - * See how many (visible) method names there are. If none, we do not (and - * should not) try to sort the list of them. + * Tidy up, sort the names and resolve finally whether we really want + * them (processing export layering). */ - i = 0; - if (names.numEntries != 0) { - const char **strings; - - /* - * We need to build the list of methods to sort. We will be using - * qsort() for this, because it is very unlikely that the list will be - * heavily sorted when it is long enough to matter. - */ - - strings = ckalloc(sizeof(char *) * names.numEntries); - FOREACH_HASH(namePtr, isWanted, &names) { - if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) { - if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { - continue; - } - strings[i++] = TclGetString(namePtr); - } - } - - /* - * Note that 'i' may well be less than names.numEntries when we are - * dealing with public method names. - */ - - if (i > 0) { - if (i > 1) { - qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr); - } - *stringsPtr = strings; - } else { - ckfree(strings); - } - } - + Tcl_DeleteHashTable(&examinedClasses); + numStrings = SortMethodNames(&names, flags, stringsPtr); Tcl_DeleteHashTable(&names); - return i; + return numStrings; } int @@ -523,10 +529,7 @@ TclOOGetSortedClassMethodList( /* Used to track what classes have been looked * at. Is set-like in nature and keyed by * pointer to class. */ - FOREACH_HASH_DECLS; - int i; - Tcl_Obj *namePtr; - void *isWanted; + int numStrings; Tcl_InitObjHashTable(&names); Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); @@ -539,50 +542,111 @@ TclOOGetSortedClassMethodList( Tcl_DeleteHashTable(&examinedClasses); /* - * See how many (visible) method names there are. If none, we do not (and - * should not) try to sort the list of them. + * Process private method names if we should. [TIP 500] */ - i = 0; - if (names.numEntries != 0) { - const char **strings; + if (flags & TRUE_PRIVATE_METHOD) { + FOREACH_HASH_DECLS; + Method *mPtr; + Tcl_Obj *namePtr; - /* - * We need to build the list of methods to sort. We will be using - * qsort() for this, because it is very unlikely that the list will be - * heavily sorted when it is long enough to matter. - */ + FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { + if (mPtr->flags & TRUE_PRIVATE_METHOD) { + int isNew; - strings = ckalloc(sizeof(char *) * names.numEntries); - FOREACH_HASH(namePtr, isWanted, &names) { - if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) { - if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { - continue; - } - strings[i++] = TclGetString(namePtr); + hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); + Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST)); } } + flags &= ~TRUE_PRIVATE_METHOD; + } - /* - * Note that 'i' may well be less than names.numEntries when we are - * dealing with public method names. - */ + /* + * Tidy up, sort the names and resolve finally whether we really want + * them (processing export layering). + */ + + numStrings = SortMethodNames(&names, flags, stringsPtr); + Tcl_DeleteHashTable(&names); + return numStrings; +} + +/* + * ---------------------------------------------------------------------- + * + * SortMethodNames -- + * + * Shared helper for TclOOGetSortedMethodList etc. that knows the method + * sorting rules. + * + * Returns: + * The length of the sorted list. + * + * ---------------------------------------------------------------------- + */ - if (i > 0) { - if (i > 1) { - qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr); +static int +SortMethodNames( + Tcl_HashTable *namesPtr, /* The table of names; unsorted, but contains + * whether the names are wanted and under what + * circumstances. */ + int flags, /* Whether we are looking for unexported + * methods. Full private methods are handled + * on insertion to the table. */ + const char ***stringsPtr) /* Where to store the sorted list of strings + * that we produce. ckalloced() */ +{ + const char **strings; + FOREACH_HASH_DECLS; + Tcl_Obj *namePtr; + void *isWanted; + int i = 0; + + /* + * See how many (visible) method names there are. If none, we do not (and + * should not) try to sort the list of them. + */ + + if (namesPtr->numEntries == 0) { + *stringsPtr = NULL; + return 0; + } + + /* + * We need to build the list of methods to sort. We will be using qsort() + * for this, because it is very unlikely that the list will be heavily + * sorted when it is long enough to matter. + */ + + strings = ckalloc(sizeof(char *) * namesPtr->numEntries); + FOREACH_HASH(namePtr, isWanted, namesPtr) { + if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) { + if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { + continue; } - *stringsPtr = strings; - } else { - ckfree(strings); + strings[i++] = TclGetString(namePtr); } } - Tcl_DeleteHashTable(&names); + /* + * Note that 'i' may well be less than names.numEntries when we are + * dealing with public method names. We don't sort unless there's at least + * two method names. + */ + + if (i > 0) { + if (i > 1) { + qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr); + } + *stringsPtr = strings; + } else { + ckfree(strings); + *stringsPtr = NULL; + } return i; } -/* Comparator for GetSortedMethodList */ +/* Comparator for SortMethodNames */ static int CmpStr( const void *ptr1, @@ -665,6 +729,9 @@ AddClassMethodNames( } FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { + if (mPtr->flags & TRUE_PRIVATE_METHOD) { + continue; + } hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); if (isNew) { int isWanted = (!(flags & PUBLIC_METHOD) diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 30cf8af..db490fb 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -596,7 +596,8 @@ InfoObjectMethodsCmd( resultObj = Tcl_NewObj(); if (recurse) { const char **names; - int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names); + int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag, + &names); for (i=0 ; i, destroy, equal, eval, unknown, variable, varname or x} +test oo-39.9 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + } + oo::class create cls2 { + superclass cls + method equal {other} { + expr {[my y] == [$other x]} + } + } + cls2 create a 1 + cls2 create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "y": must be , destroy, equal, eval, unknown, variable or varname} +test oo-39.10 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + } + oo::class create cls2 { + superclass cls + method equal {other} { + expr {[my x] == [$other x]} + } + } + cls2 create a 1 + cls2 create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "x": must be , destroy, equal, eval, unknown, variable or varname} cleanupTests return -- cgit v0.12 From bd706be303307bc4bdeacf15c1af1a43f1585d6b Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 14 May 2018 20:55:40 +0000 Subject: Make sure that [self call] reports useful info. --- generic/tclOOCall.c | 306 +++++++++++++++++++++++++++----------------------- generic/tclOOInt.h | 4 + generic/tclOOMethod.c | 6 + tests/oo.test | 27 +++++ 4 files changed, 201 insertions(+), 142 deletions(-) diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 494a627..5fd0c2a 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -44,6 +44,21 @@ struct ChainBuilder { #define MIXIN_CONSISTENT(flags) \ (((flags) & OBJECT_MIXIN) || \ !((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN)) +/* + * Note that the flag bit PRIVATE_METHOD has a confusing name. + */ +#define IS_PUBLIC(mPtr) \ + (((mPtr)->flags & PUBLIC_METHOD) != 0) +#define IS_UNEXPORTED(mPtr) \ + (((mPtr)->flags & PRIVATE_METHOD) != 0) +#define IS_PRIVATE(mPtr) \ + (((mPtr)->flags & TRUE_PRIVATE_METHOD) != 0) +#define WANT_PUBLIC(flags) \ + (((flags) & PUBLIC_METHOD) != 0) +#define WANT_UNEXPORTED(flags) \ + (((flags) & PRIVATE_METHOD) != 0) +#define WANT_PRIVATE(flags) \ + (((flags) & TRUE_PRIVATE_METHOD) != 0) /* * Function declarations for things defined in this file. @@ -62,6 +77,10 @@ static inline void AddMethodToCallChain(Method *const mPtr, static inline int AddInstancePrivateToCallContext(Object *const oPtr, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, int flags); +static inline void AddStandardMethodName(int flags, Tcl_Obj *namePtr, + Method *mPtr, Tcl_HashTable *namesPtr); +static inline void AddPrivateMethodNames(Tcl_HashTable *methodsTablePtr, + Tcl_HashTable *namesPtr); static inline int AddSimpleChainToCallContext(Object *const oPtr, Class *const contextCls, Tcl_Obj *const methodNameObj, @@ -74,7 +93,7 @@ static int AddPrivatesFromClassChainToCallContext(Class *classPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags, Class *const filterDecl); -static void AddSimpleClassChainToCallContext(Class *classPtr, +static int AddSimpleClassChainToCallContext(Class *classPtr, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags, @@ -418,22 +437,13 @@ TclOOGetSortedMethodList( if (oPtr->methodsPtr) { FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { - int isNew; - - if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) { + if (IS_PRIVATE(mPtr)) { continue; } - if (mPtr->flags & TRUE_PRIVATE_METHOD) { + if (IS_UNEXPORTED(mPtr) && !WANT_UNEXPORTED(flags)) { continue; } - hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); - if (isNew) { - int isWantedIn = ((!(flags & PUBLIC_METHOD) - || mPtr->flags & PUBLIC_METHOD) ? IN_LIST : 0); - - isWantedIn |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); - Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); - } + AddStandardMethodName(flags, namePtr, mPtr, &names); } } @@ -441,28 +451,10 @@ TclOOGetSortedMethodList( * Process method names due to private methods on the object's class. */ - if (flags & PRIVATE_METHOD) { + if (WANT_UNEXPORTED(flags)) { FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) { - if ((mPtr->flags & PRIVATE_METHOD) - && !(mPtr->flags & TRUE_PRIVATE_METHOD)) { - int isNew; - - hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); - if (isNew) { - int isWantedIn = IN_LIST; - - if (mPtr->typePtr == NULL) { - isWantedIn |= NO_IMPLEMENTATION; - } - Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); - } else if (mPtr->typePtr != NULL) { - int isWantedIn = PTR2INT(Tcl_GetHashValue(hPtr)); - - if (isWantedIn & NO_IMPLEMENTATION) { - isWantedIn &= ~NO_IMPLEMENTATION; - Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); - } - } + if (IS_UNEXPORTED(mPtr)) { + AddStandardMethodName(flags, namePtr, mPtr, &names); } } } @@ -473,24 +465,10 @@ TclOOGetSortedMethodList( */ if (contextObj && contextObj->methodsPtr) { - FOREACH_HASH(namePtr, mPtr, contextObj->methodsPtr) { - if (mPtr->flags & TRUE_PRIVATE_METHOD) { - int isNew; - - hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); - Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST)); - } - } + AddPrivateMethodNames(contextObj->methodsPtr, &names); } if (contextCls) { - FOREACH_HASH(namePtr, mPtr, &contextCls->classMethods) { - if (mPtr->flags & TRUE_PRIVATE_METHOD) { - int isNew; - - hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); - Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST)); - } - } + AddPrivateMethodNames(&contextCls->classMethods, &names); } /* @@ -500,7 +478,7 @@ TclOOGetSortedMethodList( AddClassMethodNames(oPtr->selfCls, flags, &names, &examinedClasses); FOREACH(mixinPtr, oPtr->mixins) { - AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, &names, + AddClassMethodNames(mixinPtr, flags | TRAVERSED_MIXIN, &names, &examinedClasses); } @@ -545,19 +523,8 @@ TclOOGetSortedClassMethodList( * Process private method names if we should. [TIP 500] */ - if (flags & TRUE_PRIVATE_METHOD) { - FOREACH_HASH_DECLS; - Method *mPtr; - Tcl_Obj *namePtr; - - FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { - if (mPtr->flags & TRUE_PRIVATE_METHOD) { - int isNew; - - hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); - Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST)); - } - } + if (WANT_PRIVATE(flags)) { + AddPrivateMethodNames(&clsPtr->classMethods, &names); flags &= ~TRUE_PRIVATE_METHOD; } @@ -620,7 +587,7 @@ SortMethodNames( strings = ckalloc(sizeof(char *) * namesPtr->numEntries); FOREACH_HASH(namePtr, isWanted, namesPtr) { - if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) { + if (!WANT_PUBLIC(flags) || (PTR2INT(isWanted) & IN_LIST)) { if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { continue; } @@ -655,7 +622,7 @@ CmpStr( const char **strPtr1 = (const char **) ptr1; const char **strPtr2 = (const char **) ptr2; - return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1)+1); + return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1) + 1); } /* @@ -688,6 +655,8 @@ AddClassMethodNames( * pointers to the classes, and the values are * immaterial. */ { + int i; + /* * If we've already started looking at this class, stop working on it now * to prevent repeated work. @@ -718,7 +687,6 @@ AddClassMethodNames( if (clsPtr->mixins.num != 0) { Class *mixinPtr; - int i; FOREACH(mixinPtr, clsPtr->mixins) { if (mixinPtr != clsPtr) { @@ -729,23 +697,7 @@ AddClassMethodNames( } FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { - if (mPtr->flags & TRUE_PRIVATE_METHOD) { - continue; - } - hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); - if (isNew) { - int isWanted = (!(flags & PUBLIC_METHOD) - || (mPtr->flags & PUBLIC_METHOD)) ? IN_LIST : 0; - - isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); - Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); - } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION) - && mPtr->typePtr != NULL) { - int isWanted = PTR2INT(Tcl_GetHashValue(hPtr)); - - isWanted &= ~NO_IMPLEMENTATION; - Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); - } + AddStandardMethodName(flags, namePtr, mPtr, namesPtr); } if (clsPtr->superclasses.num != 1) { @@ -755,7 +707,6 @@ AddClassMethodNames( } if (clsPtr->superclasses.num != 0) { Class *superPtr; - int i; FOREACH(superPtr, clsPtr->superclasses) { AddClassMethodNames(superPtr, flags, namesPtr, @@ -767,6 +718,66 @@ AddClassMethodNames( /* * ---------------------------------------------------------------------- * + * AddPrivateMethodNames, AddStandardMethodName -- + * + * Factored-out helpers for the sorted name list production functions. + * + * ---------------------------------------------------------------------- + */ + +static inline void +AddPrivateMethodNames( + Tcl_HashTable *methodsTablePtr, + Tcl_HashTable *namesPtr) +{ + FOREACH_HASH_DECLS; + Method *mPtr; + Tcl_Obj *namePtr; + + FOREACH_HASH(namePtr, mPtr, methodsTablePtr) { + if (IS_PRIVATE(mPtr)) { + int isNew; + + hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); + Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST)); + } + } +} + +static inline void +AddStandardMethodName( + int flags, + Tcl_Obj *namePtr, + Method *mPtr, + Tcl_HashTable *namesPtr) +{ + if (!IS_PRIVATE(mPtr)) { + int isNew; + Tcl_HashEntry *hPtr = + Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); + + if (isNew) { + int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr)) + ? IN_LIST : 0; + + isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); + Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); + } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION) + && mPtr->typePtr != NULL) { + int isWanted = PTR2INT(Tcl_GetHashValue(hPtr)); + + isWanted &= ~NO_IMPLEMENTATION; + Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); + } + } +} + +#undef IN_LIST +#undef NO_IMPLEMENTATION + +/* + * ---------------------------------------------------------------------- + * * AddInstancePrivateToCallContext -- * * Add private methods from the instance. Called when the calling Tcl @@ -794,7 +805,7 @@ AddInstancePrivateToCallContext( hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName); if (hPtr != NULL) { mPtr = Tcl_GetHashValue(hPtr); - if (mPtr->flags & TRUE_PRIVATE_METHOD) { + if (IS_PRIVATE(mPtr)) { AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags); donePrivate = 1; } @@ -835,7 +846,7 @@ AddSimpleChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i, foundPrivate = 0; + int i, foundPrivate = 0, blockedUnexported = 0; Tcl_HashEntry *hPtr; Method *mPtr; @@ -844,10 +855,10 @@ AddSimpleChainToCallContext( if (hPtr != NULL) { mPtr = Tcl_GetHashValue(hPtr); - if (!(mPtr->flags & TRUE_PRIVATE_METHOD)) { - if (flags & PUBLIC_METHOD) { - if (!(mPtr->flags & PUBLIC_METHOD)) { - return 0; + if (!IS_PRIVATE(mPtr)) { + if (WANT_PUBLIC(flags)) { + if (!IS_PUBLIC(mPtr)) { + blockedUnexported = 1; } else { flags |= DEFINITE_PUBLIC; } @@ -866,14 +877,15 @@ AddSimpleChainToCallContext( mixinPtr, contextCls, methodNameObj, cbPtr, doneFilters, flags|TRAVERSED_MIXIN, filterDecl); } - AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, - doneFilters, flags|TRAVERSED_MIXIN, filterDecl); + foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr, + methodNameObj, cbPtr, doneFilters, + flags | TRAVERSED_MIXIN, filterDecl); } - if (oPtr->methodsPtr) { + if (oPtr->methodsPtr && !blockedUnexported) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj); if (hPtr != NULL) { mPtr = Tcl_GetHashValue(hPtr); - if (!(mPtr->flags & TRUE_PRIVATE_METHOD)) { + if (!IS_PRIVATE(mPtr)) { AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags); } @@ -885,8 +897,10 @@ AddSimpleChainToCallContext( contextCls, methodNameObj, cbPtr, doneFilters, flags, filterDecl); } - AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr, - doneFilters, flags, filterDecl); + if (!blockedUnexported) { + foundPrivate |= AddSimpleClassChainToCallContext(oPtr->selfCls, + methodNameObj, cbPtr, doneFilters, flags, filterDecl); + } return foundPrivate; } @@ -950,8 +964,8 @@ AddMethodToCallChain( * should be sufficient for [incr Tcl] support though. */ - if (!(callPtr->flags & PRIVATE_METHOD) - && (mPtr->flags & PRIVATE_METHOD) + if (!WANT_UNEXPORTED(callPtr->flags) + && IS_UNEXPORTED(mPtr) && (mPtr->declaringClassPtr != NULL) && (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) { return; @@ -992,7 +1006,7 @@ AddMethodToCallChain( if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) { callPtr->chain = - ckalloc(sizeof(struct MInvoke) * (callPtr->numChain+1)); + ckalloc(sizeof(struct MInvoke) * (callPtr->numChain + 1)); memcpy(callPtr->chain, callPtr->staticChain, sizeof(struct MInvoke) * callPtr->numChain); } else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) { @@ -1144,7 +1158,7 @@ TclOOGetCallContext( * the object, and in the class). */ - const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); + const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD); if (cacheInThisObj->typePtr == &methodNameType) { callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1; @@ -1250,6 +1264,7 @@ TclOOGetCallContext( if (oPtr == contextObj) { donePrivate |= AddInstancePrivateToCallContext(oPtr, methodNameObj, &cb, flags); + donePrivate |= (contextObj->flags & HAS_PRIVATE_METHODS); } donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); @@ -1389,8 +1404,7 @@ TclOOGetStereotypeCallChain( hPtr = Tcl_FindHashEntry(clsPtr->classChainCache, (char *) methodNameObj); if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) { - const int reuseMask = - ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); + const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD); callPtr = Tcl_GetHashValue(hPtr); if (IsStillValid(callPtr, &obj, flags, reuseMask)) { @@ -1585,7 +1599,7 @@ AddPrivatesFromClassChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i, foundPrivate = 0; + int i; Class *superPtr; /* @@ -1598,9 +1612,11 @@ AddPrivatesFromClassChainToCallContext( tailRecurse: FOREACH(superPtr, classPtr->mixins) { - foundPrivate |= AddPrivatesFromClassChainToCallContext(superPtr, - contextCls, methodName, cbPtr, doneFilters, - flags|TRAVERSED_MIXIN, filterDecl); + if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls, + methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN, + filterDecl)) { + return 1; + } } if (classPtr == contextCls) { @@ -1610,10 +1626,10 @@ AddPrivatesFromClassChainToCallContext( if (hPtr != NULL) { register Method *mPtr = Tcl_GetHashValue(hPtr); - if (mPtr->flags & TRUE_PRIVATE_METHOD) { + if (IS_PRIVATE(mPtr)) { AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags); - foundPrivate = 1; + return 1; } } } @@ -1624,12 +1640,13 @@ AddPrivatesFromClassChainToCallContext( goto tailRecurse; default: FOREACH(superPtr, classPtr->superclasses) { - foundPrivate |= AddPrivatesFromClassChainToCallContext(superPtr, - contextCls, methodName, cbPtr, doneFilters, flags, - filterDecl); + if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls, + methodName, cbPtr, doneFilters, flags, filterDecl)) { + return 1; + } } case 0: - return foundPrivate; + return 0; } } @@ -1643,7 +1660,7 @@ AddPrivatesFromClassChainToCallContext( * ---------------------------------------------------------------------- */ -static void +static int AddSimpleClassChainToCallContext( Class *classPtr, /* Class to add the call chain entries for. */ Tcl_Obj *const methodNameObj, @@ -1659,7 +1676,7 @@ AddSimpleClassChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i; + int i, privateDanger = 0; Class *superPtr; /* @@ -1672,8 +1689,9 @@ AddSimpleClassChainToCallContext( tailRecurse: FOREACH(superPtr, classPtr->mixins) { - AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, - doneFilters, flags|TRAVERSED_MIXIN, filterDecl); + privateDanger |= AddSimpleClassChainToCallContext(superPtr, + methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN, + filterDecl); } if (flags & CONSTRUCTOR) { @@ -1687,21 +1705,23 @@ AddSimpleClassChainToCallContext( Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, (char *) methodNameObj); + if (classPtr->flags & HAS_PRIVATE_METHODS) { + privateDanger |= 1; + } if (hPtr != NULL) { register Method *mPtr = Tcl_GetHashValue(hPtr); - if (!(flags & KNOWN_STATE)) { - if (flags & PUBLIC_METHOD) { - if (mPtr->flags & PUBLIC_METHOD) { + if (!IS_PRIVATE(mPtr)) { + if (!(flags & KNOWN_STATE)) { + if (flags & PUBLIC_METHOD) { + if (!IS_PUBLIC(mPtr)) { + return privateDanger; + } flags |= DEFINITE_PUBLIC; } else { - return; + flags |= DEFINITE_PROTECTED; } - } else { - flags |= DEFINITE_PROTECTED; } - } - if (!(mPtr->flags & TRUE_PRIVATE_METHOD)) { AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags); } @@ -1714,11 +1734,11 @@ AddSimpleClassChainToCallContext( goto tailRecurse; default: FOREACH(superPtr, classPtr->superclasses) { - AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, - doneFilters, flags, filterDecl); + privateDanger |= AddSimpleClassChainToCallContext(superPtr, + methodNameObj, cbPtr, doneFilters, flags, filterDecl); } case 0: - return; + return privateDanger; } } @@ -1738,7 +1758,7 @@ TclOORenderCallChain( Tcl_Interp *interp, CallChain *callPtr) { - Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral; + Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral; Tcl_Obj *resultObj, *descObjs[4], **objv; Foundation *fPtr = TclOOGetFoundation(interp); int i; @@ -1747,12 +1767,14 @@ TclOORenderCallChain( * Allocate the literals (potentially) used in our description. */ - filterLiteral = Tcl_NewStringObj("filter", -1); + TclNewLiteralStringObj(filterLiteral, "filter"); Tcl_IncrRefCount(filterLiteral); - methodLiteral = Tcl_NewStringObj("method", -1); + TclNewLiteralStringObj(methodLiteral, "method"); Tcl_IncrRefCount(methodLiteral); - objectLiteral = Tcl_NewStringObj("object", -1); + TclNewLiteralStringObj(objectLiteral, "object"); Tcl_IncrRefCount(objectLiteral); + TclNewLiteralStringObj(privateLiteral, "private"); + Tcl_IncrRefCount(privateLiteral); /* * Do the actual construction of the descriptions. They consist of a list @@ -1770,16 +1792,15 @@ TclOORenderCallChain( for (i=0 ; inumChain ; i++) { struct MInvoke *miPtr = &callPtr->chain[i]; - descObjs[0] = miPtr->isFilter - ? filterLiteral - : callPtr->flags & OO_UNKNOWN_METHOD - ? fPtr->unknownMethodNameObj - : methodLiteral; - descObjs[1] = callPtr->flags & CONSTRUCTOR - ? fPtr->constructorName - : callPtr->flags & DESTRUCTOR - ? fPtr->destructorName - : miPtr->mPtr->namePtr; + descObjs[0] = + miPtr->isFilter ? filterLiteral : + callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj : + IS_PRIVATE(miPtr->mPtr) ? privateLiteral : + methodLiteral; + descObjs[1] = + callPtr->flags & CONSTRUCTOR ? fPtr->constructorName : + callPtr->flags & DESTRUCTOR ? fPtr->destructorName : + miPtr->mPtr->namePtr; descObjs[2] = miPtr->mPtr->declaringClassPtr ? Tcl_GetObjectName(interp, (Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr) @@ -1797,6 +1818,7 @@ TclOORenderCallChain( Tcl_DecrRefCount(filterLiteral); Tcl_DecrRefCount(methodLiteral); Tcl_DecrRefCount(objectLiteral); + Tcl_DecrRefCount(privateLiteral); /* * Finish building the description and return it. diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 43e2709..e81bbf9 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -236,6 +236,10 @@ typedef struct Object { * other spots). */ #define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the * unknown method handler at that point. */ +#define HAS_PRIVATE_METHODS 0x20000 + /* Object/class has (or had) private methods, + * and so shouldn't be cached so + * aggressively. */ /* * And the definition of a class. Note that every class also has an associated diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 82204f1..9bc9daa 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -188,6 +188,9 @@ Tcl_NewInstanceMethod( if (flags) { mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD); + if (flags & TRUE_PRIVATE_METHOD) { + oPtr->flags |= HAS_PRIVATE_METHODS; + } } oPtr->epoch++; return (Tcl_Method) mPtr; @@ -253,6 +256,9 @@ Tcl_NewMethod( if (flags) { mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD); + if (flags & TRUE_PRIVATE_METHOD) { + clsPtr->flags |= HAS_PRIVATE_METHODS; + } } return (Tcl_Method) mPtr; diff --git a/tests/oo.test b/tests/oo.test index 66400ff..9aedaaf 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4664,6 +4664,33 @@ test oo-39.10 {TIP 500: private methods internal call; error reporting} -setup { } -returnCodes error -cleanup { parent destroy } -result {unknown method "x": must be , destroy, equal, eval, unknown, variable or varname} +test oo-39.11 {TIP 500: private methods; call chain caching and reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + method chain {} { + return [self call] + } + } + oo::class create cls2 { + superclass cls + private method chain {} { + next + } + method chain2 {} { + my chain + } + method chain3 {} { + [self] chain + } + } + cls create a + cls2 create b + list [a chain] [b chain] [b chain2] [b chain3] +} -cleanup { + parent destroy +} -result {{{{method chain ::cls method}} 0} {{{method chain ::cls method}} 0} {{{private chain ::cls2 method} {method chain ::cls method}} 1} {{{private chain ::cls2 method} {method chain ::cls method}} 1}} cleanupTests return -- cgit v0.12 From e6fdfbe93b022e8ac8dc26c7de9706b7b45d422f Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 15 May 2018 13:04:10 +0000 Subject: Make [info object methods] and [info class methods] work right. --- generic/tclOOCall.c | 9 ++++++++- generic/tclOOInfo.c | 10 +++++++--- generic/tclOOInt.h | 1 + tests/oo.test | 36 ++++++++++++++++++++++++++++++++++++ 4 files changed, 52 insertions(+), 4 deletions(-) diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 5fd0c2a..bc84da0 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -44,18 +44,25 @@ struct ChainBuilder { #define MIXIN_CONSISTENT(flags) \ (((flags) & OBJECT_MIXIN) || \ !((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN)) + /* - * Note that the flag bit PRIVATE_METHOD has a confusing name. + * Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for + * Itcl's special type of private. */ + #define IS_PUBLIC(mPtr) \ (((mPtr)->flags & PUBLIC_METHOD) != 0) #define IS_UNEXPORTED(mPtr) \ + (((mPtr)->flags & SCOPE_FLAGS) == 0) +#define IS_ITCLPRIVATE(mPtr) \ (((mPtr)->flags & PRIVATE_METHOD) != 0) #define IS_PRIVATE(mPtr) \ (((mPtr)->flags & TRUE_PRIVATE_METHOD) != 0) #define WANT_PUBLIC(flags) \ (((flags) & PUBLIC_METHOD) != 0) #define WANT_UNEXPORTED(flags) \ + (((flags) & (PRIVATE_METHOD | TRUE_PRIVATE_METHOD)) == 0) +#define WANT_ITCLPRIVATE(flags) \ (((flags) & PRIVATE_METHOD) != 0) #define WANT_PRIVATE(flags) \ (((flags) & TRUE_PRIVATE_METHOD) != 0) diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index db490fb..fe433e4 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -533,7 +533,8 @@ InfoObjectMethodsCmd( "private", "public", "unexported" }; enum Scopes { - SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED + SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED, + SCOPE_LOCALPRIVATE }; if (objc < 2) { @@ -587,6 +588,9 @@ InfoObjectMethodsCmd( case SCOPE_PUBLIC: flag = PUBLIC_METHOD; break; + case SCOPE_LOCALPRIVATE: + flag = PRIVATE_METHOD; + break; case SCOPE_UNEXPORTED: flag = 0; break; @@ -608,7 +612,7 @@ InfoObjectMethodsCmd( } } else if (oPtr->methodsPtr) { FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { - if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { + if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) { Tcl_ListObjAppendElement(NULL, resultObj, namePtr); } } @@ -1314,7 +1318,7 @@ InfoClassMethodsCmd( FOREACH_HASH_DECLS; FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { - if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { + if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) { Tcl_ListObjAppendElement(NULL, resultObj, namePtr); } } diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index e81bbf9..a43ab76 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -407,6 +407,7 @@ typedef struct CallContext { /* This is a private method only accessible * from other methods defined on this class * or instance. [TIP #500] */ +#define SCOPE_FLAGS (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD) /* * Structure containing definition information about basic class methods. diff --git a/tests/oo.test b/tests/oo.test index 9aedaaf..9563b4f 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4691,6 +4691,42 @@ test oo-39.11 {TIP 500: private methods; call chain caching and reporting} -setu } -cleanup { parent destroy } -result {{{{method chain ::cls method}} 0} {{{method chain ::cls method}} 0} {{{private chain ::cls2 method} {method chain ::cls method}} 1} {{{private chain ::cls2 method} {method chain ::cls method}} 1}} +test oo-39.12 {TIP 500: private methods; introspection} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + method chain {} { + return [self call] + } + private method abc {} {} + } + oo::class create cls2 { + superclass cls + method chain2 {} { + my chain + } + method chain3 {} { + [self] chain + } + private method def {} {} + unexport chain3 + } + cls create a + cls2 create b + oo::objdefine b { + private method ghi {} {} + method ABC {} {} + method foo {} {} + } + set scopes {public unexported private} + list a: [lmap s $scopes {info object methods a -scope $s}] \ + b: [lmap s $scopes {info object methods b -scope $s}] \ + cls: [lmap s $scopes {info class methods cls -scope $s}] \ + cls2: [lmap s $scopes {info class methods cls2 -scope $s}] \ +} -cleanup { + parent destroy +} -result {a: {{} {} {}} b: {foo ABC ghi} cls: {chain {} abc} cls2: {chain2 chain3 def}} cleanupTests return -- cgit v0.12 From ba42e43e970a3a2f5299df4f36fb283c7cc9526b Mon Sep 17 00:00:00 2001 From: fvogel Date: Fri, 18 May 2018 06:18:56 +0000 Subject: Add test filesystem-1.30.1 checking file normalize ~$::tcl_platform(user). This test should currently fail when the computer is connected to a Windows domain controller, due to [9e6b569963]: file normalize ~user fails on Windows --- tests/fileSystem.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/fileSystem.test b/tests/fileSystem.test index b805780..edc1df2 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -264,6 +264,9 @@ removeDirectory dir.dir test filesystem-1.30 {normalisation of nonexistent user} -body { file normalize ~noonewiththisname } -returnCodes error -result {user "noonewiththisname" doesn't exist} +test filesystem-1.30.1 {normalisation of existing user} -body { + catch {file normalize ~$::tcl_platform(user)} +} -result {0} test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} { testsetplatform unix file normalize /foo/../bar -- cgit v0.12 From 423f761169b37ab7bd60fa145f1b2a63c4075db0 Mon Sep 17 00:00:00 2001 From: fvogel Date: Fri, 18 May 2018 19:54:56 +0000 Subject: Fix [9e6b569963]: file normalize ~user fails on Windows --- win/tclWinFile.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 9afe0a9..beab147 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1444,6 +1444,7 @@ TclpGetUserHome( char *domain; WCHAR *wName, *wHomeDir, *wDomain, **wDomainPtr = &wDomain; WCHAR buf[MAX_PATH]; + LPCWSTR wServername = NULL; Tcl_DStringInit(bufferPtr); wDomain = NULL; @@ -1458,7 +1459,8 @@ TclpGetUserHome( if (badDomain == 0) { Tcl_DStringInit(&ds); wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); - if (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) uiPtrPtr) == 0) { + NetGetDCName(NULL, wDomain, (LPBYTE *) &wServername); + if (NetUserGetInfo(wServername, wName, 1, (LPBYTE *) uiPtrPtr) == 0) { wHomeDir = uiPtr->usri1_home_dir; if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir), -- cgit v0.12 From dffe6bc7f17cc047da64213a097fe2f9b3a58865 Mon Sep 17 00:00:00 2001 From: fvogel Date: Sat, 19 May 2018 07:10:43 +0000 Subject: Add test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} --- tests/fileSystem.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/fileSystem.test b/tests/fileSystem.test index edc1df2..f778112 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -267,6 +267,9 @@ test filesystem-1.30 {normalisation of nonexistent user} -body { test filesystem-1.30.1 {normalisation of existing user} -body { catch {file normalize ~$::tcl_platform(user)} } -result {0} +test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body { + file normalize ~nonexistentuser@nonexistentdomain +} -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist} test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} { testsetplatform unix file normalize /foo/../bar -- cgit v0.12 From d431841a06870d53eb32d3ae2e11339e58094aad Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 19 May 2018 08:38:42 +0000 Subject: Corrections for a number of small things to align with TIP --- generic/tclOO.decls | 4 +-- generic/tclOO.h | 9 +++++ generic/tclOODecls.h | 8 ++--- generic/tclOODefineCmds.c | 13 ++++--- tests/oo.test | 88 ++++++++++++++++++++++++++++++++++++++++++++++- 5 files changed, 111 insertions(+), 11 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 265ba88..5bce926 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -58,12 +58,12 @@ declare 10 { } declare 11 { Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, - Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData) } declare 12 { Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData) } declare 13 { diff --git a/generic/tclOO.h b/generic/tclOO.h index d051e79..9c1dd1e 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -99,6 +99,15 @@ typedef struct { */ #define TCL_OO_METHOD_VERSION_CURRENT 1 + +/* + * Visibility constants for the flags parameter to Tcl_NewMethod and + * Tcl_NewInstanceMethod. + */ + +#define TCL_OO_METHOD_PUBLIC 1 +#define TCL_OO_METHOD_UNEXPORTED 0 +#define TCL_OO_METHOD_PRIVATE 0x20 /* * The type of some object (or class) metadata. This describes how to delete diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 9fd62ec..fd0f687 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -59,11 +59,11 @@ TCLAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ TCLAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, - int isPublic, const Tcl_MethodType *typePtr, + int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int isPublic, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ @@ -136,8 +136,8 @@ typedef struct TclOOStubs { int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */ int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 9 */ Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */ - Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */ - Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ + Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */ + Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 13 */ int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */ int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */ diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 403ed1a..7281d7a 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1187,7 +1187,7 @@ TclOODefineSelfObjCmd( { Foundation *fPtr = TclOOGetFoundation(interp); Object *oPtr; - int result; + int result, private; oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { @@ -1199,6 +1199,8 @@ TclOODefineSelfObjCmd( return TCL_OK; } + private = IsPrivateDefine(interp); + /* * Make the oo::objdefine namespace the current namespace and evaluate the * command(s). @@ -1207,6 +1209,9 @@ TclOODefineSelfObjCmd( if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){ return TCL_ERROR; } + if (private) { + ((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME; + } AddRef(oPtr); if (objc == 2) { @@ -1298,9 +1303,9 @@ TclOODefinePrivateObjCmd( if (oPtr == NULL) { return TCL_ERROR; } - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "definitionCommand ..."); - return TCL_ERROR; + if (objc == 1) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp))); + return TCL_OK; } /* diff --git a/tests/oo.test b/tests/oo.test index 9563b4f..24f23ae 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4298,7 +4298,7 @@ test oo-38.2 {TIP 500: private variables introspection} -setup { } -cleanup { parent destroy } -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}} -test oo-38.3 {TIP 500: private variables and obj·varname} -setup { +test oo-38.3 {TIP 500: private variables and oo::object·varname} -setup { oo::class create parent } -body { oo::class create clsA { @@ -4372,6 +4372,65 @@ test oo-38.4 {TIP 500: private variables introspection} -setup { } -cleanup { parent destroy } -result {ok {ok x1 x2 y1 y2 z} 0 yes {a1 a2 b1 b2 yes z} 0} +test oo-38.5 {TIP 500: private variables and oo::object·variable} -setup { + oo::class create parent +} -body { + oo::class create cls1 { + superclass parent + private variable x + method abc val { + my variable x + set x $val + } + method def val { + my variable y + set y $val + } + method get1 {} { + my variable x y + return [list $x $y] + } + } + oo::class create cls2 { + superclass cls1 + private variable x + method x-exists {} { + return [info exists x],[uplevel 1 {info exists x}] + } + method ghi x { + # Additional instrumentation to show that we're not using the + # resolved variable until we ask for it; the argument nixed that + # happening by default. + set val $x + set before [my x-exists] + unset x + set x $val + set mid [my x-exists] + unset x + set mid2 [my x-exists] + my variable x + set x $val + set after [my x-exists] + return "$before;$mid;$mid2;$after" + } + method jkl val { + my variable y + set y $val + } + method get2 {} { + my variable x y + return [list $x $y] + } + } + cls2 create a + a abc 123 + a def 234 + set tmp [a ghi 345] + a jkl 456 + list $tmp [a get1] [a get2] +} -cleanup { + parent destroy +} -result {{0,1;0,1;0,0;1,1} {123 456} {345 456}} test oo-39.1 {TIP 500: private methods internal call; class private} -setup { oo::class create parent @@ -4727,6 +4786,33 @@ test oo-39.12 {TIP 500: private methods; introspection} -setup { } -cleanup { parent destroy } -result {a: {{} {} {}} b: {foo ABC ghi} cls: {chain {} abc} cls2: {chain2 chain3 def}} + +test oo-40.1 {TIP 500: private and self} -setup { + oo::class create cls +} -body { + oo::define cls { + self { + private { + variable a + } + variable b + } + private { + self { + variable c + } + variable d + } + variable e + } + list \ + [lsort [info class variables cls]] \ + [lsort [info class variables cls -private]] \ + [lsort [info object variables cls]] \ + [lsort [info object variables cls -private]] +} -cleanup { + cls destroy +} -result {e d b {a c}} cleanupTests return -- cgit v0.12 From 791f1c2741cd972e66bbaf65821f64e76d9c6f89 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 19 May 2018 11:18:51 +0000 Subject: Minor updates to C API to handle private methods. --- doc/Method.3 | 44 +++++++++++++++++++++++++++++++------------- generic/tclOO.decls | 3 +++ generic/tclOODecls.h | 5 +++++ generic/tclOOMethod.c | 7 +++++++ generic/tclOOStubInit.c | 1 + 5 files changed, 47 insertions(+), 13 deletions(-) diff --git a/doc/Method.3 b/doc/Method.3 index 225da00..9e636a1 100644 --- a/doc/Method.3 +++ b/doc/Method.3 @@ -9,18 +9,18 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextInvokeNext, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts +Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsPrivate, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextInvokeNext, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Method -\fBTcl_NewMethod\fR(\fIinterp, class, nameObj, isPublic, - methodTypePtr, clientData\fR) +\fBTcl_NewMethod\fR(\fIinterp, class, nameObj, flags, methodTypePtr, + clientData\fR) .sp Tcl_Method -\fBTcl_NewInstanceMethod\fR(\fIinterp, object, nameObj, isPublic, - methodTypePtr, clientData\fR) +\fBTcl_NewInstanceMethod\fR(\fIinterp, object, nameObj, flags, methodTypePtr, + clientData\fR) .sp \fBTcl_ClassSetConstructor\fR(\fIinterp, class, method\fR) .sp @@ -35,8 +35,13 @@ Tcl_Object Tcl_Obj * \fBTcl_MethodName\fR(\fImethod\fR) .sp +.VS TIP500 int \fBTcl_MethodIsPublic\fR(\fImethod\fR) +.VE TIP500 +.sp +int +\fBTcl_MethodIsPrivate\fR(\fImethod\fR) .sp int \fBTcl_MethodIsType\fR(\fImethod, methodTypePtr, clientDataPtr\fR) @@ -66,10 +71,15 @@ The class to create the method in. .AP Tcl_Obj *nameObj in The name of the method to create. Should not be NULL unless creating constructors or destructors. -.AP int isPublic in -A flag saying what the visibility of the method is. The only supported public -values of this flag are 0 for a non-exported method, and 1 for an exported -method. +.AP int flags in +A flag saying (currently) what the visibility of the method is. The supported +public values of this flag are \fBTCL_OO_METHOD_PUBLIC\fR (which is fixed at 1 +for backward compatibility) for an exported method, +\fBTCL_OO_METHOD_UNEXPORTED\fR (which is fixed at 0 for backward +compatibility) for a non-exported method, +.VS TIP500 +and \fBTCL_OO_METHOD_PRIVATE\fR for a private method. +.VE TIP500 .AP Tcl_MethodType *methodTypePtr in A description of the type of the method to create, or the type of method to compare against. @@ -105,8 +115,12 @@ Given a method, the entity that declared it can be found using attached to (or NULL if the method is not attached to any class) and \fBTcl_MethodDeclarerObject\fR which returns the object that the method is attached to (or NULL if the method is not attached to an object). The name of -the method can be retrieved with \fBTcl_MethodName\fR and whether the method -is exported is retrieved with \fBTcl_MethodIsPublic\fR. The type of the method +the method can be retrieved with \fBTcl_MethodName\fR, whether the method +is exported is retrieved with \fBTcl_MethodIsPublic\fR, +.VS TIP500 +and whether the method is private is retrieved with \fBTcl_MethodIsPrivate\fR. +.VE TIP500 +The type of the method can also be introspected upon to a limited degree; the function \fBTcl_MethodIsType\fR returns whether a method is of a particular type, assigning the per-method \fIclientData\fR to the variable pointed to by @@ -117,8 +131,12 @@ Methods are created by \fBTcl_NewMethod\fR and \fBTcl_NewInstanceMethod\fR, which create a method attached to a class or an object respectively. In both cases, the \fInameObj\fR argument gives the name of the method to create, the -\fIisPublic\fR argument states whether the method should be exported -initially, the \fImethodTypePtr\fR argument describes the implementation of +\fIflags\fR argument states whether the method should be exported +initially +.VS TIP500 +or be marked as a private method, +.VE TIP500 +the \fImethodTypePtr\fR argument describes the implementation of the method (see the \fBMETHOD TYPES\fR section below) and the \fIclientData\fR argument gives some implementation-specific data that is passed on to the implementation of the method when it is called. diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 5bce926..f1bb320 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -126,6 +126,9 @@ declare 27 { declare 28 { Tcl_Obj *Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object) } +declare 29 { + int Tcl_MethodIsPrivate(Tcl_Method method) +} ###################################################################### # Private API, exposed to support advanced OO systems that plug in on top of diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index fd0f687..928d07e 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -116,6 +116,8 @@ TCLAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, /* 28 */ TCLAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); +/* 29 */ +TCLAPI int Tcl_MethodIsPrivate(Tcl_Method method); typedef struct { const struct TclOOIntStubs *tclOOIntStubs; @@ -154,6 +156,7 @@ typedef struct TclOOStubs { void (*tcl_ClassSetConstructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 26 */ void (*tcl_ClassSetDestructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */ + int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */ } TclOOStubs; extern const TclOOStubs *tclOOStubsPtr; @@ -226,6 +229,8 @@ extern const TclOOStubs *tclOOStubsPtr; (tclOOStubsPtr->tcl_ClassSetDestructor) /* 27 */ #define Tcl_GetObjectName \ (tclOOStubsPtr->tcl_GetObjectName) /* 28 */ +#define Tcl_MethodIsPrivate \ + (tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */ #endif /* defined(USE_TCLOO_STUBS) */ diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 9bc9daa..ad14a1a 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1699,6 +1699,13 @@ Tcl_MethodIsPublic( { return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0; } + +int +Tcl_MethodIsPrivate( + Tcl_Method method) +{ + return (((Method *)method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0; +} /* * Extended method construction for itcl-ng. diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c index 900ab22..5e235f4 100644 --- a/generic/tclOOStubInit.c +++ b/generic/tclOOStubInit.c @@ -73,6 +73,7 @@ const TclOOStubs tclOOStubs = { Tcl_ClassSetConstructor, /* 26 */ Tcl_ClassSetDestructor, /* 27 */ Tcl_GetObjectName, /* 28 */ + Tcl_MethodIsPrivate, /* 29 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 0cab7d260b6e86a7ba0c877e2d83ec6b8df0edf1 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 22 May 2018 08:26:55 +0000 Subject: More docs --- doc/info.n | 209 ++++++++++++++++++++++++++++++++++--------------------------- 1 file changed, 115 insertions(+), 94 deletions(-) diff --git a/doc/info.n b/doc/info.n index 9fb89fa..869169d 100644 --- a/doc/info.n +++ b/doc/info.n @@ -35,10 +35,9 @@ Returns the body of procedure \fIprocname\fR. \fIProcname\fR must be the name of a Tcl command procedure. .TP \fBinfo class\fI subcommand class\fR ?\fIarg ...\fR -.VS 8.6 +. Returns information about the class, \fIclass\fR. The \fIsubcommand\fRs are described in \fBCLASS INTROSPECTION\fR below. -.VE 8.6 .TP \fBinfo cmdcount\fR . @@ -78,11 +77,10 @@ command is not complete, the script can delay evaluating it until additional lines have been typed to complete the command. .TP \fBinfo coroutine\fR -.VS 8.6 +. Returns the name of the currently executing \fBcoroutine\fR, or the empty string if either no coroutine is currently executing, or the current coroutine has been deleted (but has not yet returned or yielded since deletion). -.VE 8.6 .TP \fBinfo default \fIprocname arg varname\fR . @@ -93,7 +91,7 @@ Otherwise it returns \fB1\fR and places the default value of \fIarg\fR into variable \fIvarname\fR. .TP \fBinfo errorstack \fR?\fIinterp\fR? -.VS 8.6 +. Returns, in a form that is programmatically easy to parse, the function names and arguments at each level from the call stack of the last error in the given \fIinterp\fR, or in the current one if not specified. @@ -118,7 +116,6 @@ options dictionary returned by 3-argument \fBcatch\fR; \fBinfo errorstack\fR is a convenient way of retrieving it for uncaught errors at top-level in an interactive \fBtclsh\fR. .RE -.VE 8.6 .TP \fBinfo exists \fIvarName\fR . @@ -329,10 +326,9 @@ was invoked. If Tcl was unable to identify the file, then an empty string is returned. .TP \fBinfo object\fI subcommand object\fR ?\fIarg ...\fR -.VS 8.6 +. Returns information about the object, \fIobject\fR. The \fIsubcommand\fRs are described in \fBOBJECT INTROSPECTION\fR below. -.VE 8.6 .TP \fBinfo patchlevel\fR . @@ -399,13 +395,11 @@ Note that a currently-visible variable may not yet if it has not been set (e.g. a variable declared but not set by \fBvariable\fR). .SS "CLASS INTROSPECTION" -.VS 8.6 .PP The following \fIsubcommand\fR values are supported by \fBinfo class\fR: -.VE 8.6 .TP \fBinfo class call\fI class method\fR -.VS +. Returns a description of the method implementations that are used to provide a stereotypical instance of \fIclass\fR's implementation of \fImethod\fR (stereotypical instances being objects instantiated by a class without having @@ -425,115 +419,134 @@ implementation (see \fBinfo class methodtype\fR). Note that there is no inspection of whether the method implementations actually use \fBnext\fR to transfer control along the call chain. .RE -.VE 8.6 .TP \fBinfo class constructor\fI class\fR -.VS 8.6 +. This subcommand returns a description of the definition of the constructor of class \fIclass\fR. The definition is described as a two element list; the first element is the list of arguments to the constructor in a form suitable for passing to another call to \fBproc\fR or a method definition, and the second element is the body of the constructor. If no constructor is present, this returns the empty list. -.VE 8.6 .TP \fBinfo class definition\fI class method\fR -.VS 8.6 +. This subcommand returns a description of the definition of the method named \fImethod\fR of class \fIclass\fR. The definition is described as a two element list; the first element is the list of arguments to the method in a form suitable for passing to another call to \fBproc\fR or a method definition, and the second element is the body of the method. -.VE 8.6 .TP \fBinfo class destructor\fI class\fR -.VS 8.6 +. This subcommand returns the body of the destructor of class \fIclass\fR. If no destructor is present, this returns the empty string. -.VE 8.6 .TP \fBinfo class filters\fI class\fR -.VS 8.6 +. This subcommand returns the list of filter methods set on the class. -.VE 8.6 .TP \fBinfo class forward\fI class method\fR -.VS 8.6 +. This subcommand returns the argument list for the method forwarding called \fImethod\fR that is set on the class called \fIclass\fR. -.VE 8.6 .TP \fBinfo class instances\fI class\fR ?\fIpattern\fR? -.VS 8.6 +. This subcommand returns a list of instances of class \fIclass\fR. If the optional \fIpattern\fR argument is present, it constrains the list of returned instances to those that match it according to the rules of \fBstring match\fR. -.VE 8.6 .TP \fBinfo class methods\fI class\fR ?\fIoptions...\fR? -.VS 8.6 +. This subcommand returns a list of all public (i.e. exported) methods of the class called \fIclass\fR. Any of the following \fIoption\fRs may be specified, controlling exactly which method names are returned: .RS -.VE 8.6 .TP \fB\-all\fR -.VS 8.6 -If the \fB\-all\fR flag is given, the list of methods will include those +. +If the \fB\-all\fR flag is given, +.VS TIP500 +and the \fB\-scope\fR flag is not given, +.VE TIP500 +the list of methods will include those methods defined not just by the class, but also by the class's superclasses and mixins. -.VE 8.6 .TP \fB\-private\fR -.VS 8.6 -If the \fB\-private\fR flag is given, the list of methods will also include -the private (i.e. non-exported) methods of the class (and superclasses and +. +If the \fB\-private\fR flag is given, +.VS TIP500 +and the \fB\-scope\fR flag is not given, +.VE TIP500 +the list of methods will also include +the non-exported methods of the class (and superclasses and mixins, if \fB\-all\fR is also given). +.VS TIP500 +Note that this naming is an unfortunate clash with true private methods; this +option name is retained for backward compatibility. +.VE TIP500 +.TP +\fB\-scope\fI scope\fR +.VS TIP500 +Returns a list of all methods on \fIclass\fR that have the given visibility +\fIscope\fR. When this option is supplied, both the \fB\-all\fR and +\fB\-private\fR options are ignored. The valid values for \fIscope\fR are: +.RS +.IP \fBpublic\fR 3 +Only methods with \fIpublic\fR scope (i.e., callable from anywhere by any instance +of this class) are to be returned. +.IP \fBunexported\fR 3 +Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) are to +be returned. +.IP \fBprivate\fR 3 +Only methods with \fIprivate\fR scope (i.e., only callable from within this class's +methods) are to be returned. +.RE +.VE TIP500 .RE -.VE 8.6 .TP \fBinfo class methodtype\fI class method\fR -.VS 8.6 +. This subcommand returns a description of the type of implementation used for the method named \fImethod\fR of class \fIclass\fR. When the result is \fBmethod\fR, further information can be discovered with \fBinfo class definition\fR, and when the result is \fBforward\fR, further information can be discovered with \fBinfo class forward\fR. -.VE 8.6 .TP \fBinfo class mixins\fI class\fR -.VS 8.6 +. This subcommand returns a list of all classes that have been mixed into the class named \fIclass\fR. -.VE 8.6 .TP \fBinfo class subclasses\fI class\fR ?\fIpattern\fR? -.VS 8.6 +. This subcommand returns a list of direct subclasses of class \fIclass\fR. If the optional \fIpattern\fR argument is present, it constrains the list of returned classes to those that match it according to the rules of \fBstring match\fR. -.VE 8.6 .TP \fBinfo class superclasses\fI class\fR -.VS 8.6 +. This subcommand returns a list of direct superclasses of class \fIclass\fR in inheritance precedence order. -.VE 8.6 .TP -\fBinfo class variables\fI class\fR -.VS 8.6 +\fBinfo class variables\fI class\fR ?\fB\-private\fR? +. This subcommand returns a list of all variables that have been declared for the class named \fIclass\fR (i.e. that are automatically present in the class's methods, constructor and destructor). +.VS TIP500 +If the \fB\-private\fR option is specified, this lists the private variables +declared instead. +.VE TIP500 .SS "OBJECT INTROSPECTION" .PP The following \fIsubcommand\fR values are supported by \fBinfo object\fR: -.VE 8.6 .TP \fBinfo object call\fI object method\fR -.VS 8.6 +. Returns a description of the method implementations that are used to provide \fIobject\fR's implementation of \fImethod\fR. This consists of a list of lists of four elements, where each sublist consists of a word that describes @@ -552,14 +565,12 @@ implementation (see \fBinfo object methodtype\fR). Note that there is no inspection of whether the method implementations actually use \fBnext\fR to transfer control along the call chain. .RE -.VE 8.6 .TP \fBinfo object class\fI object\fR ?\fIclassName\fR? -.VS 8.6 +. If \fIclassName\fR is unspecified, this subcommand returns class of the \fIobject\fR object. If \fIclassName\fR is present, this subcommand returns a boolean value indicating whether the \fIobject\fR is of that class. -.VE 8.6 .TP \fBinfo object creationid\fI object\fR .VS TIP500 @@ -574,116 +585,134 @@ identifiers associated with the object, especially for private variables. .VE TIP500 .TP \fBinfo object definition\fI object method\fR -.VS 8.6 +. This subcommand returns a description of the definition of the method named \fImethod\fR of object \fIobject\fR. The definition is described as a two element list; the first element is the list of arguments to the method in a form suitable for passing to another call to \fBproc\fR or a method definition, and the second element is the body of the method. -.VE 8.6 .TP \fBinfo object filters\fI object\fR -.VS 8.6 +. This subcommand returns the list of filter methods set on the object. -.VE 8.6 .TP \fBinfo object forward\fI object method\fR -.VS 8.6 +. This subcommand returns the argument list for the method forwarding called \fImethod\fR that is set on the object called \fIobject\fR. -.VE 8.6 .TP \fBinfo object isa\fI category object\fR ?\fIarg\fR? -.VS 8.6 +. This subcommand tests whether an object belongs to a particular category, returning a boolean value that indicates whether the \fIobject\fR argument meets the criteria for the category. The supported categories are: -.VE 8.6 .RS .TP \fBinfo object isa class\fI object\fR -.VS 8.6 +. This returns whether \fIobject\fR is a class (i.e. an instance of \fBoo::class\fR or one of its subclasses). -.VE 8.6 .TP \fBinfo object isa metaclass\fI object\fR -.VS 8.6 +. This returns whether \fIobject\fR is a class that can manufacture classes (i.e. is \fBoo::class\fR or a subclass of it). -.VE 8.6 .TP \fBinfo object isa mixin\fI object class\fR -.VS 8.6 +. This returns whether \fIclass\fR is directly mixed into \fIobject\fR. -.VE 8.6 .TP \fBinfo object isa object\fI object\fR -.VS 8.6 +. This returns whether \fIobject\fR really is an object. -.VE 8.6 .TP \fBinfo object isa typeof\fI object class\fR -.VS 8.6 +. This returns whether \fIclass\fR is the type of \fIobject\fR (i.e. whether \fIobject\fR is an instance of \fIclass\fR or one of its subclasses, whether direct or indirect). .RE -.VE 8.6 .TP \fBinfo object methods\fI object\fR ?\fIoption...\fR? -.VS 8.6 +. This subcommand returns a list of all public (i.e. exported) methods of the object called \fIobject\fR. Any of the following \fIoption\fRs may be specified, controlling exactly which method names are returned: .RS -.VE 8.6 .TP \fB\-all\fR -.VS 8.6 -If the \fB\-all\fR flag is given, the list of methods will include those +. +If the \fB\-all\fR flag is given, +.VS TIP500 +and the \fB\-scope\fR flag is not given, +.VE TIP500 +the list of methods will include those methods defined not just by the object, but also by the object's class and mixins, plus the superclasses of those classes. -.VE 8.6 .TP \fB\-private\fR -.VS 8.6 -If the \fB\-private\fR flag is given, the list of methods will also include -the private (i.e. non-exported) methods of the object (and classes, if +. +If the \fB\-private\fR flag is given, +.VS TIP500 +and the \fB\-scope\fR flag is not given, +.VE TIP500 +the list of methods will also include +the non-exported methods of the object (and classes, if \fB\-all\fR is also given). +.VS TIP500 +Note that this naming is an unfortunate clash with true private methods; this +option name is retained for backward compatibility. +.VE TIP500 +.TP +\fB\-scope\fI scope\fR +.VS TIP500 +Returns a list of all methods on \fIobject\fR that have the given visibility +\fIscope\fR. When this option is supplied, both the \fB\-all\fR and +\fB\-private\fR options are ignored. The valid values for \fIscope\fR are: +.RS +.IP \fBpublic\fR 3 +Only methods with \fIpublic\fR scope (i.e., callable from anywhere) are to be +returned. +.IP \fBunexported\fR 3 +Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) are to +be returned. +.IP \fBprivate\fR 3 +Only methods with \fIprivate\fR scope (i.e., only callable from within this object's +instance methods) are to be returned. +.RE +.VE TIP500 .RE -.VE 8.6 .TP \fBinfo object methodtype\fI object method\fR -.VS 8.6 +. This subcommand returns a description of the type of implementation used for the method named \fImethod\fR of object \fIobject\fR. When the result is \fBmethod\fR, further information can be discovered with \fBinfo object definition\fR, and when the result is \fBforward\fR, further information can be discovered with \fBinfo object forward\fR. -.VE 8.6 .TP \fBinfo object mixins\fI object\fR -.VS 8.6 +. This subcommand returns a list of all classes that have been mixed into the object named \fIobject\fR. -.VE 8.6 .TP \fBinfo object namespace\fI object\fR -.VS 8.6 +. This subcommand returns the name of the internal namespace of the object named \fIobject\fR. -.VE 8.6 .TP -\fBinfo object variables\fI object\fR -.VS 8.6 +\fBinfo object variables\fI object\fRR ?\fB\-private\fR? +. This subcommand returns a list of all variables that have been declared for the object named \fIobject\fR (i.e. that are automatically present in the object's methods). -.VE 8.6 +.VS TIP500 +If the \fB\-private\fR option is specified, this lists the private variables +declared instead. +.VE TIP500 .TP \fBinfo object vars\fI object\fR ?\fIpattern\fR? -.VS 8.6 +. This subcommand returns a list of all variables in the private namespace of the object named \fIobject\fR. If the optional \fIpattern\fR argument is given, it is a filter (in the syntax of a \fBstring match\fR glob pattern) @@ -692,7 +721,6 @@ from the list returned by \fBinfo object variables\fR; that can include variables that are currently unset, whereas this can include variables that are not automatically included by any of \fIobject\fR's methods (or those of its class, superclasses or mixins). -.VE 8.6 .SH EXAMPLES .PP This command prints out a procedure suitable for saving in a Tcl @@ -715,7 +743,6 @@ proc printProc {procName} { } .CE .SS "EXAMPLES WITH OBJECTS" -.VS 8.6 .PP Every object necessarily knows what its class is; this information is trivially extractable through introspection: @@ -772,18 +799,12 @@ proc getDef {obj method} { return [\fBinfo class definition\fR $cls $method] } .CE -.VE 8.6 .SH "SEE ALSO" -.VS 8.6 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 -object, -.VE 8.6 -procedure, variable +object, procedure, variable '\" Local Variables: '\" mode: nroff '\" fill-column: 78 -- cgit v0.12 From 36a1a69178cf1667f7ddd31ee00274f9e7709139 Mon Sep 17 00:00:00 2001 From: fvogel Date: Wed, 23 May 2018 21:08:01 +0000 Subject: Add support for ~domain\user style user names, with new test test filesystem-1.30.3. Warning: does not yet work. --- tests/fileSystem.test | 3 +++ win/tclWinFile.c | 18 +++++++++++++++--- 2 files changed, 18 insertions(+), 3 deletions(-) diff --git a/tests/fileSystem.test b/tests/fileSystem.test index f778112..277fcd3 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -270,6 +270,9 @@ test filesystem-1.30.1 {normalisation of existing user} -body { test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body { file normalize ~nonexistentuser@nonexistentdomain } -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist} +test filesystem-1.30.3 {normalisation of nonexistent user specified as domain\user} -body { + file normalize ~nonexistentdomain\\nonexistentuser +} -returnCodes error -result {user "nonexistentdomain\nonexistentuser" doesn't exist} test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} { testsetplatform unix file normalize /foo/../bar diff --git a/win/tclWinFile.c b/win/tclWinFile.c index beab147..b8fb046 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1441,11 +1441,13 @@ TclpGetUserHome( Tcl_DString ds; int nameLen = -1; int badDomain = 0; - char *domain; + char *domain, *user; + const char *nameStart; WCHAR *wName, *wHomeDir, *wDomain, **wDomainPtr = &wDomain; WCHAR buf[MAX_PATH]; LPCWSTR wServername = NULL; + nameStart = name; Tcl_DStringInit(bufferPtr); wDomain = NULL; domain = strchr(name, '@'); @@ -1455,10 +1457,20 @@ TclpGetUserHome( badDomain = NetGetDCName(NULL, wName, (LPBYTE *) wDomainPtr); Tcl_DStringFree(&ds); nameLen = domain - name; + } else { + user = strchr(name, '\\'); + if (user != NULL) { + Tcl_DStringInit(&ds); + wName = Tcl_UtfToUniCharDString(name, user - name, &ds); + badDomain = NetGetDCName(NULL, wName, (LPBYTE *) wDomainPtr); + Tcl_DStringFree(&ds); + nameStart = user + 1; + nameLen = name + strlen(name) - 1 - user; + } } if (badDomain == 0) { Tcl_DStringInit(&ds); - wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); + wName = Tcl_UtfToUniCharDString(nameStart, nameLen, &ds); NetGetDCName(NULL, wDomain, (LPBYTE *) &wServername); if (NetUserGetInfo(wServername, wName, 1, (LPBYTE *) uiPtrPtr) == 0) { wHomeDir = uiPtr->usri1_home_dir; @@ -1477,7 +1489,7 @@ TclpGetUserHome( } Tcl_UniCharToUtfDString(buf, size-1, bufferPtr); Tcl_DStringAppend(bufferPtr, "/", -1); - Tcl_DStringAppend(bufferPtr, name, -1); + Tcl_DStringAppend(bufferPtr, nameStart, nameLen); } result = Tcl_DStringValue(bufferPtr); NetApiBufferFree((void *) uiPtr); -- cgit v0.12 From ecec1703aade688299289c4d74bae88a04e04d22 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 24 May 2018 20:12:43 +0000 Subject: win: TclpGetUserHome should return normalized path (also in case we find domain and NetUserGetInfo returns path), PoC: file normalize ~$::tcl_platform(user)@$::env(USERDOMAIN) --- win/tclWinFile.c | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 8fc0b8e..1acc225 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1450,7 +1450,7 @@ TclpGetUserHome( Tcl_DString ds; int nameLen, badDomain; char *domain; - WCHAR *wName, *wHomeDir, *wDomain, **wDomainPtr = &wDomain; + WCHAR *wName, *wHomeDir, *wDomain; WCHAR buf[MAX_PATH]; badDomain = 0; @@ -1461,7 +1461,7 @@ TclpGetUserHome( Tcl_DStringInit(&ds); wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds); badDomain = (netGetDCNameProc)(NULL, wName, - (LPBYTE *) wDomainPtr); + (LPBYTE *) &wDomain); Tcl_DStringFree(&ds); nameLen = domain - name; } @@ -1470,25 +1470,26 @@ TclpGetUserHome( wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); if ((netUserGetInfoProc)(wDomain, wName, 1, (LPBYTE *) uiPtrPtr) == 0) { + DWORD i, size = MAX_PATH; wHomeDir = uiPtr->usri1_home_dir; if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { - Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir), - bufferPtr); + size = lstrlenW(wHomeDir); + Tcl_UniCharToUtfDString(wHomeDir, size, bufferPtr); } else { /* * User exists but has no home dir. Return * "{GetProfilesDirectory}/". */ - DWORD i, size = MAX_PATH; getProfilesDirectoryProc(buf, &size); - for (i = 0; i < size; ++i){ - if (buf[i] == '\\') buf[i] = '/'; - } Tcl_UniCharToUtfDString(buf, size-1, bufferPtr); - Tcl_DStringAppend(bufferPtr, "/", -1); - Tcl_DStringAppend(bufferPtr, name, -1); + Tcl_DStringAppend(bufferPtr, "/", 1); + Tcl_DStringAppend(bufferPtr, name, nameLen); } result = Tcl_DStringValue(bufferPtr); + /* be sure we returns normalized path */ + for (i = 0; i < size; ++i){ + if (result[i] == '\\') result[i] = '/'; + } (*netApiBufferFreeProc)((void *) uiPtr); } Tcl_DStringFree(&ds); -- cgit v0.12 From a410c0d8d504868b1dbdcaf70a521859e32327fd Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 24 May 2018 20:20:26 +0000 Subject: fixed typo in winFCmd-12.6.2: unneeded extra-bracket removed --- tests/winFCmd.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 1b2b042..f1f2afa 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -913,7 +913,7 @@ test winFCmd-12.6.2 {ConvertFileNameFormat: absolute path with drive (in temp fo } -constraints {win} -body { createfile $::env(TEMP)/td1 {} string equal [string tolower [file attributes $::env(TEMP)/td1 -longname]] \ - [string tolower [file normalize $::env(TEMP)]/td1]] + [string tolower [file normalize $::env(TEMP)]/td1] } -cleanup { file delete -force -- $::env(TEMP)/td1 } -result 1 -- cgit v0.12 From 1c13d543f4934c33e441ef5c77a592b9822a8823 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 24 May 2018 20:49:12 +0000 Subject: [9e6b569963] win: if user specified without domain (and local user was not found), try to resolve user-home using current domain, so following code's are similar: file normalize ~$::tcl_platform(user)@$::env(USERDOMAIN) file normalize ~$::tcl_platform(user) --- win/tclWinFile.c | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 1acc225..a3fad1d 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1446,30 +1446,41 @@ TclpGetUserHome( GetProcAddress(userenvInst, "GetProfilesDirectoryW"); if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL) && (netApiBufferFreeProc != NULL) && (getProfilesDirectoryProc != NULL)) { - USER_INFO_1 *uiPtr, **uiPtrPtr = &uiPtr; + USER_INFO_1 *uiPtr; Tcl_DString ds; - int nameLen, badDomain; + int nameLen, rc; char *domain; WCHAR *wName, *wHomeDir, *wDomain; WCHAR buf[MAX_PATH]; - badDomain = 0; + rc = 0; nameLen = -1; wDomain = NULL; domain = strchr(name, '@'); if (domain != NULL) { Tcl_DStringInit(&ds); wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds); - badDomain = (netGetDCNameProc)(NULL, wName, - (LPBYTE *) &wDomain); + rc = (netGetDCNameProc)(NULL, wName, (LPBYTE *) &wDomain); Tcl_DStringFree(&ds); nameLen = domain - name; } - if (badDomain == 0) { + if (rc == 0) { Tcl_DStringInit(&ds); wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); - if ((netUserGetInfoProc)(wDomain, wName, 1, - (LPBYTE *) uiPtrPtr) == 0) { + while ((netUserGetInfoProc)(wDomain, wName, 1, + (LPBYTE *) &uiPtr) != 0) { + /* + * user does not exists - if domain was not specified, + * try again using current domain. + */ + rc = 1; + if (domain != NULL) break; + /* get current domain */ + rc = (netGetDCNameProc)(NULL, NULL, (LPBYTE *) &wDomain); + if (rc != 0) break; + domain = INT2PTR(-1); /* repeat once */ + } + if (rc == 0) { DWORD i, size = MAX_PATH; wHomeDir = uiPtr->usri1_home_dir; if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { -- cgit v0.12 From 6d943ef7b5327ee4ccdf46fecd74ecbb5f75ca73 Mon Sep 17 00:00:00 2001 From: fvogel Date: Thu, 24 May 2018 20:51:45 +0000 Subject: Remove test filesystem-1.30.3, this is unstestable --- tests/fileSystem.test | 3 --- 1 file changed, 3 deletions(-) diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 277fcd3..f778112 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -270,9 +270,6 @@ test filesystem-1.30.1 {normalisation of existing user} -body { test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body { file normalize ~nonexistentuser@nonexistentdomain } -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist} -test filesystem-1.30.3 {normalisation of nonexistent user specified as domain\user} -body { - file normalize ~nonexistentdomain\\nonexistentuser -} -returnCodes error -result {user "nonexistentdomain\nonexistentuser" doesn't exist} test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} { testsetplatform unix file normalize /foo/../bar -- cgit v0.12 From a0290b85c51fde9541564338e5b7908153f0cc96 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 25 May 2018 15:04:27 +0000 Subject: optimized winapi-stubs loading (8.5th only); if user name specified without domain and equals the current user - try safest and fastest way to get current user-home path (without usage of netapi) --- win/tclWinFile.c | 187 ++++++++++++++++++++++++++++++++----------------------- win/tclWinInit.c | 34 ++++++---- win/tclWinInt.h | 2 + 3 files changed, 134 insertions(+), 89 deletions(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index a3fad1d..3819960 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1422,95 +1422,126 @@ TclpGetUserHome( * name of user's home directory. */ { char *result; - HINSTANCE netapiInst; - HINSTANCE userenvInst; + + static NETAPIBUFFERFREEPROC *netApiBufferFreeProc; + static NETGETDCNAMEPROC *netGetDCNameProc; + static NETUSERGETINFOPROC *netUserGetInfoProc; + static GETPROFILESDIRECTORYPROC *getProfilesDirectoryProc; + static int apistubs = 0; result = NULL; Tcl_DStringInit(bufferPtr); - netapiInst = LoadLibraryA("netapi32.dll"); - userenvInst = LoadLibraryA("userenv.dll"); - if (netapiInst != NULL && userenvInst != NULL) { - NETAPIBUFFERFREEPROC *netApiBufferFreeProc; - NETGETDCNAMEPROC *netGetDCNameProc; - NETUSERGETINFOPROC *netUserGetInfoProc; - GETPROFILESDIRECTORYPROC *getProfilesDirectoryProc; - - netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) - GetProcAddress(netapiInst, "NetApiBufferFree"); - netGetDCNameProc = (NETGETDCNAMEPROC *) - GetProcAddress(netapiInst, "NetGetDCName"); - netUserGetInfoProc = (NETUSERGETINFOPROC *) - GetProcAddress(netapiInst, "NetUserGetInfo"); - getProfilesDirectoryProc = (GETPROFILESDIRECTORYPROC *) - GetProcAddress(userenvInst, "GetProfilesDirectoryW"); - if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL) - && (netApiBufferFreeProc != NULL) && (getProfilesDirectoryProc != NULL)) { - USER_INFO_1 *uiPtr; - Tcl_DString ds; - int nameLen, rc; - char *domain; - WCHAR *wName, *wHomeDir, *wDomain; - WCHAR buf[MAX_PATH]; - - rc = 0; - nameLen = -1; - wDomain = NULL; - domain = strchr(name, '@'); - if (domain != NULL) { - Tcl_DStringInit(&ds); - wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds); - rc = (netGetDCNameProc)(NULL, wName, (LPBYTE *) &wDomain); - Tcl_DStringFree(&ds); - nameLen = domain - name; + if (!apistubs) { + HINSTANCE handle; + TCL_DECLARE_MUTEX(initializeMutex) + Tcl_MutexLock(&initializeMutex); + + handle = LoadLibraryA("netapi32.dll"); + if (handle) { + netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) + GetProcAddress(handle, "NetApiBufferFree"); + netGetDCNameProc = (NETGETDCNAMEPROC *) + GetProcAddress(handle, "NetGetDCName"); + netUserGetInfoProc = (NETUSERGETINFOPROC *) + GetProcAddress(handle, "NetUserGetInfo"); + Tcl_CreateExitHandler(TclpUnloadFile, handle); + } + handle = LoadLibraryA("userenv.dll"); + if (handle) { + getProfilesDirectoryProc = (GETPROFILESDIRECTORYPROC *) + GetProcAddress(handle, "GetProfilesDirectoryW"); + Tcl_CreateExitHandler(TclpUnloadFile, handle); + } + + apistubs = -1; + if ( (netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL) + && (netApiBufferFreeProc != NULL) && (getProfilesDirectoryProc != NULL) + ) { + apistubs = 1; + } + Tcl_MutexUnlock(&initializeMutex); + } + + if (apistubs == 1) { + USER_INFO_1 *uiPtr; + Tcl_DString ds; + int nameLen, rc; + char *domain; + WCHAR *wName, *wHomeDir, *wDomain; + WCHAR buf[MAX_PATH]; + + rc = 0; + nameLen = -1; + wDomain = NULL; + domain = strchr(name, '@'); + if (domain == NULL) { + const char *ptr; + + /* no domain - firstly check it's the current user */ + if ( (ptr = TclpGetUserName(&ds)) != NULL + && strcasecmp(name, ptr) == 0 + ) { + /* try safest and fastest way to get current user home */ + ptr = TclGetEnv("HOME", &ds); + if (ptr != NULL) { + Tcl_JoinPath(1, &ptr, bufferPtr); + rc = 1; + result = Tcl_DStringValue(bufferPtr); + } + } + Tcl_DStringFree(&ds); + } else { + Tcl_DStringInit(&ds); + wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds); + rc = (netGetDCNameProc)(NULL, wName, (LPBYTE *) &wDomain); + Tcl_DStringFree(&ds); + nameLen = domain - name; + } + if (rc == 0) { + Tcl_DStringInit(&ds); + wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); + while ((netUserGetInfoProc)(wDomain, wName, 1, + (LPBYTE *) &uiPtr) != 0) { + /* + * user does not exists - if domain was not specified, + * try again using current domain. + */ + rc = 1; + if (domain != NULL) break; + /* get current domain */ + rc = (netGetDCNameProc)(NULL, NULL, (LPBYTE *) &wDomain); + if (rc != 0) break; + domain = INT2PTR(-1); /* repeat once */ } if (rc == 0) { - Tcl_DStringInit(&ds); - wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); - while ((netUserGetInfoProc)(wDomain, wName, 1, - (LPBYTE *) &uiPtr) != 0) { - /* - * user does not exists - if domain was not specified, - * try again using current domain. + DWORD i, size = MAX_PATH; + wHomeDir = uiPtr->usri1_home_dir; + if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { + size = lstrlenW(wHomeDir); + Tcl_UniCharToUtfDString(wHomeDir, size, bufferPtr); + } else { + /* + * User exists but has no home dir. Return + * "{GetProfilesDirectory}/". */ - rc = 1; - if (domain != NULL) break; - /* get current domain */ - rc = (netGetDCNameProc)(NULL, NULL, (LPBYTE *) &wDomain); - if (rc != 0) break; - domain = INT2PTR(-1); /* repeat once */ + getProfilesDirectoryProc(buf, &size); + Tcl_UniCharToUtfDString(buf, size-1, bufferPtr); + Tcl_DStringAppend(bufferPtr, "/", 1); + Tcl_DStringAppend(bufferPtr, name, nameLen); } - if (rc == 0) { - DWORD i, size = MAX_PATH; - wHomeDir = uiPtr->usri1_home_dir; - if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { - size = lstrlenW(wHomeDir); - Tcl_UniCharToUtfDString(wHomeDir, size, bufferPtr); - } else { - /* - * User exists but has no home dir. Return - * "{GetProfilesDirectory}/". - */ - getProfilesDirectoryProc(buf, &size); - Tcl_UniCharToUtfDString(buf, size-1, bufferPtr); - Tcl_DStringAppend(bufferPtr, "/", 1); - Tcl_DStringAppend(bufferPtr, name, nameLen); - } - result = Tcl_DStringValue(bufferPtr); - /* be sure we returns normalized path */ - for (i = 0; i < size; ++i){ - if (result[i] == '\\') result[i] = '/'; - } - (*netApiBufferFreeProc)((void *) uiPtr); + result = Tcl_DStringValue(bufferPtr); + /* be sure we returns normalized path */ + for (i = 0; i < size; ++i){ + if (result[i] == '\\') result[i] = '/'; } - Tcl_DStringFree(&ds); - } - if (wDomain != NULL) { - (*netApiBufferFreeProc)((void *) wDomain); + (*netApiBufferFreeProc)((void *) uiPtr); } + Tcl_DStringFree(&ds); + } + if (wDomain != NULL) { + (*netApiBufferFreeProc)((void *) wDomain); } - FreeLibrary(userenvInst); - FreeLibrary(netapiInst); } if (result == NULL) { /* diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 1ba7a31..7fa2b7a 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -532,6 +532,27 @@ Tcl_GetEncodingNameFromEnvironment( return Tcl_DStringValue(bufPtr); } +const char * +TclpGetUserName( + Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with + * the name of user. */ +{ + Tcl_DStringInit(bufferPtr); + + if (TclGetEnv("USERNAME", bufferPtr) == NULL) { + WCHAR szUserName[UNLEN+1]; + DWORD cchUserNameLen = UNLEN; + + if (!tclWinProcs->getUserName((LPTSTR)szUserName, &cchUserNameLen)) { + return NULL; + } + cchUserNameLen--; + if (tclWinProcs->useWide) cchUserNameLen *= sizeof(WCHAR); + Tcl_WinTCharToUtf((LPTSTR)szUserName, cchUserNameLen, bufferPtr); + } + return Tcl_DStringValue(bufferPtr); +} + /* *--------------------------------------------------------------------------- * @@ -562,8 +583,6 @@ TclpSetVariables( static OSVERSIONINFOW osInfo; static int osInfoInitialized = 0; Tcl_DString ds; - WCHAR szUserName[UNLEN+1]; - DWORD cchUserNameLen = UNLEN; Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL, TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY); @@ -641,15 +660,8 @@ TclpSetVariables( * Note: cchUserNameLen is number of characters including nul terminator. */ - Tcl_DStringInit(&ds); - if (TclGetEnv("USERNAME", &ds) == NULL) { - if (tclWinProcs->getUserName((LPTSTR)szUserName, &cchUserNameLen) != 0) { - int cbUserNameLen = cchUserNameLen - 1; - if (tclWinProcs->useWide) cbUserNameLen *= sizeof(WCHAR); - Tcl_WinTCharToUtf((LPTSTR)szUserName, cbUserNameLen, &ds); - } - } - Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds), + ptr = TclpGetUserName(&ds); + Tcl_SetVar2(interp, "tcl_platform", "user", ptr ? ptr : "", TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); } diff --git a/win/tclWinInt.h b/win/tclWinInt.h index ccf48bb..af6619f 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -201,6 +201,8 @@ MODULE_SCOPE void * TclpGetAllocCache(void); MODULE_SCOPE void TclpSetAllocCache(void *); #endif /* TCL_THREADS */ +MODULE_SCOPE const char*TclpGetUserName(Tcl_DString *bufferPtr); + /* Needed by tclWinFile.c and tclWinFCmd.c */ #ifndef FILE_ATTRIBUTE_REPARSE_POINT #define FILE_ATTRIBUTE_REPARSE_POINT 0x00000400 -- cgit v0.12 From f4651a56605698bf681e88594e7a97d8acd50fac Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 25 May 2018 15:48:50 +0000 Subject: avoid dual init of stubs (possible race condition, 8.5th only) --- win/tclWinFile.c | 39 ++++++++++++++++++++------------------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 3819960..2395ae1 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1436,29 +1436,30 @@ TclpGetUserHome( HINSTANCE handle; TCL_DECLARE_MUTEX(initializeMutex) Tcl_MutexLock(&initializeMutex); - - handle = LoadLibraryA("netapi32.dll"); - if (handle) { - netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) + if (!apistubs) { + handle = LoadLibraryA("netapi32.dll"); + if (handle) { + netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) GetProcAddress(handle, "NetApiBufferFree"); - netGetDCNameProc = (NETGETDCNAMEPROC *) + netGetDCNameProc = (NETGETDCNAMEPROC *) GetProcAddress(handle, "NetGetDCName"); - netUserGetInfoProc = (NETUSERGETINFOPROC *) + netUserGetInfoProc = (NETUSERGETINFOPROC *) GetProcAddress(handle, "NetUserGetInfo"); - Tcl_CreateExitHandler(TclpUnloadFile, handle); - } - handle = LoadLibraryA("userenv.dll"); - if (handle) { - getProfilesDirectoryProc = (GETPROFILESDIRECTORYPROC *) + Tcl_CreateExitHandler(TclpUnloadFile, handle); + } + handle = LoadLibraryA("userenv.dll"); + if (handle) { + getProfilesDirectoryProc = (GETPROFILESDIRECTORYPROC *) GetProcAddress(handle, "GetProfilesDirectoryW"); - Tcl_CreateExitHandler(TclpUnloadFile, handle); - } - - apistubs = -1; - if ( (netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL) - && (netApiBufferFreeProc != NULL) && (getProfilesDirectoryProc != NULL) - ) { - apistubs = 1; + Tcl_CreateExitHandler(TclpUnloadFile, handle); + } + + apistubs = -1; + if ( (netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL) + && (netApiBufferFreeProc != NULL) && (getProfilesDirectoryProc != NULL) + ) { + apistubs = 1; + } } Tcl_MutexUnlock(&initializeMutex); } -- cgit v0.12 From 5e7a1545a61ab4e66c1796ad19343e15cd2cc2ba Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 25 May 2018 15:51:23 +0000 Subject: minor indentation fix (no functional changes) --- win/tclWinFile.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 2395ae1..0bed39e 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1440,17 +1440,17 @@ TclpGetUserHome( handle = LoadLibraryA("netapi32.dll"); if (handle) { netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) - GetProcAddress(handle, "NetApiBufferFree"); + GetProcAddress(handle, "NetApiBufferFree"); netGetDCNameProc = (NETGETDCNAMEPROC *) - GetProcAddress(handle, "NetGetDCName"); + GetProcAddress(handle, "NetGetDCName"); netUserGetInfoProc = (NETUSERGETINFOPROC *) - GetProcAddress(handle, "NetUserGetInfo"); + GetProcAddress(handle, "NetUserGetInfo"); Tcl_CreateExitHandler(TclpUnloadFile, handle); } handle = LoadLibraryA("userenv.dll"); if (handle) { getProfilesDirectoryProc = (GETPROFILESDIRECTORYPROC *) - GetProcAddress(handle, "GetProfilesDirectoryW"); + GetProcAddress(handle, "GetProfilesDirectoryW"); Tcl_CreateExitHandler(TclpUnloadFile, handle); } -- cgit v0.12 From 35f5b82868924ed2ff75452f99083fe04d3a33ef Mon Sep 17 00:00:00 2001 From: fbonnet Date: Sat, 26 May 2018 11:13:34 +0000 Subject: Fixed test process-7.3 --- tests/process.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/process.test b/tests/process.test index 07c6e6f..b88c50a 100644 --- a/tests/process.test +++ b/tests/process.test @@ -271,7 +271,7 @@ test process-7.2 {abnormal exit} -body { tcl::process purge tcl::process autopurge 1 } -test process-7.3 {child killed} -body { +test process-7.3 {child killed} -constraints {win} -body { tcl::process autopurge 0 set pid [exec [interpreter] $path(exit) -1 &] lindex [tcl::process status -wait $pid] 1 -- cgit v0.12 From 813979693c1e419effe81ceaa6fea3211ad6e0fa Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 27 May 2018 12:04:39 +0000 Subject: Add sensible behaviour with export and unexport of private methods. --- generic/tclOODefineCmds.c | 12 +++++++++--- tests/oo.test | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 41 insertions(+), 3 deletions(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 7281d7a..19cd42b 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -125,6 +125,11 @@ static const struct DeclaredSlot slots[] = { {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; +/* + * How to build the in-namespace name of a private variable. This is a pattern + * used with Tcl_ObjPrintf(). + */ + #define PRIVATE_VARIABLE_PATTERN "%d : %s" /* @@ -1687,8 +1692,9 @@ TclOODefineExportObjCmd( } else { mPtr = Tcl_GetHashValue(hPtr); } - if (isNew || !(mPtr->flags & PUBLIC_METHOD)) { + if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { mPtr->flags |= PUBLIC_METHOD; + mPtr->flags &= ~TRUE_PRIVATE_METHOD; changed = 1; } } @@ -2028,8 +2034,8 @@ TclOODefineUnexportObjCmd( } else { mPtr = Tcl_GetHashValue(hPtr); } - if (isNew || mPtr->flags & PUBLIC_METHOD) { - mPtr->flags &= ~PUBLIC_METHOD; + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); changed = 1; } } diff --git a/tests/oo.test b/tests/oo.test index 24f23ae..9a22438 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4813,6 +4813,38 @@ test oo-40.1 {TIP 500: private and self} -setup { } -cleanup { cls destroy } -result {e d b {a c}} +test oo-40.2 {TIP 500: private and export} -setup { + oo::class create cls +} -body { + oo::define cls { + private method foo {} {} + } + set result [lmap s {public unexported private} { + info class methods cls -scope $s}] + oo::define cls { + export foo + } + lappend result {*}[lmap s {public unexported private} { + info class methods cls -scope $s}] +} -cleanup { + cls destroy +} -result {{} {} foo foo {} {}} +test oo-40.3 {TIP 500: private and unexport} -setup { + oo::class create cls +} -body { + oo::define cls { + private method foo {} {} + } + set result [lmap s {public unexported private} { + info class methods cls -scope $s}] + oo::define cls { + unexport foo + } + lappend result {*}[lmap s {public unexported private} { + info class methods cls -scope $s}] +} -cleanup { + cls destroy +} -result {{} {} foo {} foo {}} cleanupTests return -- cgit v0.12 From bb5d24622ffab4d7e6aaf6dba2086cdc870f8470 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 27 May 2018 14:17:08 +0000 Subject: don't bother to use constraint "threaded", because that's the way we want to build anyway --- tests/async.test | 7 +++---- tests/unixNotfy.test | 9 ++------- 2 files changed, 5 insertions(+), 11 deletions(-) diff --git a/tests/async.test b/tests/async.test index cb67cc2..6de814b 100644 --- a/tests/async.test +++ b/tests/async.test @@ -20,7 +20,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch [list package require -exact Tcltest [info patchlevel]] testConstraint testasync [llength [info commands testasync]] -testConstraint threaded [::tcl::pkgconfig get threaded] proc async1 {result code} { global aresult acode @@ -149,7 +148,7 @@ test async-3.1 {deleting handlers} testasync { } {3 del2 {0 0 0 del1 del2}} test async-4.1 {async interrupting bytecode sequence} -constraints { - testasync threaded + testasync } -setup { set hm [testasync create async3] proc nothing {} { @@ -171,7 +170,7 @@ test async-4.1 {async interrupting bytecode sequence} -constraints { testasync delete $hm } test async-4.2 {async interrupting straight bytecode sequence} -constraints { - testasync threaded + testasync } -setup { set hm [testasync create async3] } -body { @@ -188,7 +187,7 @@ test async-4.2 {async interrupting straight bytecode sequence} -constraints { testasync delete $hm } test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { - testasync threaded + testasync } -setup { set hm [testasync create async3] } -body { diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 18b967f..0bd8c69 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -18,16 +18,11 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # When run in a Tk shell, these tests hang. testConstraint noTk [expr {0 != [catch {package present Tk}]}] testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] -# Darwin always uses a threaded notifier -testConstraint unthreaded [expr { - ![::tcl::pkgconfig get threaded] - && $tcl_platform(os) ne "Darwin" -}] # The next two tests will hang if threads are enabled because the notifier # will not necessarily wait for ever in this case, so it does not generate # an error. -test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body { +test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints nonPortable -body { catch {vwait x} set f [open [makeFile "" foo] w] fileevent $f writable {set x 1} @@ -38,7 +33,7 @@ test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} - catch { close $f } catch { removeFile foo } } -test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body { +test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints nonPortable -body { catch {vwait x} set f1 [open [makeFile "" foo] w] set f2 [open [makeFile "" foo2] w] -- cgit v0.12 From 6a4d06759ed9c9ac3c94860c9d7b17c076f28b7e Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 28 May 2018 13:13:39 +0000 Subject: win: searching for FQDN in user-name should be utf-8 safe (user-name could contain non-ascii utf-8 chars) --- win/tclWinFile.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 0bed39e..3655321 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1468,14 +1468,14 @@ TclpGetUserHome( USER_INFO_1 *uiPtr; Tcl_DString ds; int nameLen, rc; - char *domain; + const char *domain; WCHAR *wName, *wHomeDir, *wDomain; WCHAR buf[MAX_PATH]; rc = 0; nameLen = -1; wDomain = NULL; - domain = strchr(name, '@'); + domain = Tcl_UtfFindFirst(name, '@'); if (domain == NULL) { const char *ptr; -- cgit v0.12 From 267cdaec036394312cd843ed142d998f7bbee4f3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 May 2018 07:23:05 +0000 Subject: One TCL_NORETURN -> TCL_NORETURN1 minor mistake. Make it build when Tcl_SetPanicProc is a macro (normally it isn't) --- generic/tclPanic.c | 3 ++- generic/tclStubInit.c | 1 + win/tclWinFile.c | 1 + 3 files changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclPanic.c b/generic/tclPanic.c index b50271b..85b7388 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -24,7 +24,7 @@ */ #if defined(__CYGWIN__) || (defined(_WIN32) && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8)) -static TCL_NORETURN Tcl_PanicProc *panicProc = tclWinDebugPanic; +static TCL_NORETURN1 Tcl_PanicProc *panicProc = tclWinDebugPanic; #else static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; #endif @@ -45,6 +45,7 @@ static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; *---------------------------------------------------------------------- */ +#undef Tcl_SetPanicProc void Tcl_SetPanicProc( TCL_NORETURN1 Tcl_PanicProc *proc) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 5057b05..7ce0758 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -40,6 +40,7 @@ #undef Tcl_CreateHashEntry #undef Tcl_Panic #undef Tcl_FindExecutable +#undef Tcl_SetPanicProc #undef TclpGetPid #undef TclSockMinimumBuffers #undef Tcl_SetIntObj diff --git a/win/tclWinFile.c b/win/tclWinFile.c index bd4f13b..a70717e 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -867,6 +867,7 @@ TclpFindExecutable( */ if (argv0 == NULL) { +# undef Tcl_SetPanicProc Tcl_SetPanicProc(tclWinDebugPanic); } -- cgit v0.12 From 63b0fef31a850917cdee0f9d059c51516e4b8593 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 30 May 2018 07:15:13 +0000 Subject: No longer pass "--enable-threads" to battery-included sub-packages, since it's the default, even when Tcl is built without threads, now. This opens the way (in the future) to remove this option from the sub-packages --- unix/Makefile.in | 2 +- win/Makefile.in | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 51c06e5..e1d7d65 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1759,7 +1759,7 @@ configure-packages: $$i/configure --with-tcl=../.. \ --with-tclinclude=$(GENERIC_DIR) \ $(PKG_CFG_ARGS) --libdir=$(PACKAGE_DIR) \ - --enable-shared --enable-threads; ) || exit $$?; \ + --enable-shared; ) || exit $$?; \ fi; \ fi; \ fi; \ diff --git a/win/Makefile.in b/win/Makefile.in index d155b8d..bf9ab8c 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -774,7 +774,7 @@ packages: if [ ! -f $(PKG_DIR)/$$pkg/Makefile ]; then \ ( cd $(PKG_DIR)/$$pkg; \ echo "Configuring package '$$i' wd = `$(CYGPATH) $$(pwd -P)`"; \ - $$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR_NATIVE) $(PKG_CFG_ARGS) --enable-shared --enable-threads; ) \ + $$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR_NATIVE) $(PKG_CFG_ARGS) --enable-shared; ) \ fi ; \ echo "Building package '$$pkg'"; \ ( cd $(PKG_DIR)/$$pkg; $(MAKE); ) \ -- cgit v0.12 From 6ab540f5ff1eca1d921e511eed5caaa192f4e547 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 30 May 2018 09:38:48 +0000 Subject: Tweaking the documentation --- doc/define.n | 70 +++++++++++++++++++++++++++++------------------------------- doc/info.n | 29 +++++++++++++++++++++---- doc/my.n | 39 +++++++++++++++++++++++++++------ doc/next.n | 5 +++++ doc/self.n | 7 +++++- 5 files changed, 103 insertions(+), 47 deletions(-) diff --git a/doc/define.n b/doc/define.n index d68e463..b489e5f 100644 --- a/doc/define.n +++ b/doc/define.n @@ -82,17 +82,14 @@ by a superclass; subclass exports override superclass visibility, and may in turn be overridden by instances. .TP \fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? -.VS +. This slot (see \fBSLOTTED DEFINITIONS\fR below) -.VE sets or updates the list of method names that are used to guard whether method call to instances of the class may be called and what the method's results are. Each \fImethodName\fR names a single filtering method (which may be exposed or not exposed); it is not an error for a non-existent method to be named since they may be defined by subclasses. -.VS By default, this slot works by appending. -.VE .TP \fBforward\fI name cmdName \fR?\fIarg ...\fR? . @@ -133,15 +130,12 @@ below), this command creates private procedure-like methods. .RE .TP \fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? -.VS +. This slot (see \fBSLOTTED DEFINITIONS\fR below) -.VE sets or updates the list of additional classes that are to be mixed into all the instances of the class being defined. Each \fIclassName\fR argument names a single class that is to be mixed in. -.VS By default, this slot works by replacement. -.VE .TP \fBprivate \fIcmd arg...\fR .TP @@ -151,6 +145,15 @@ By default, this slot works by replacement. This evaluates the \fIscript\fR (or the list of command and arguments given by \fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the current class will be private definitions. +.RS +.PP +The following class definition commands are affected by \fBprivate\fR: +\fBforward\fR, \fBmethod\fR, \fBself\fR, and \fBvariable\fR. Nesting +\fBprivate\fR inside \fBprivate\fR has no cumulative effect; the innermost +definition context is just a private definition context. All other definition +commands have no difference in behavior when used in a private definition +context. +.RE .VE TIP500 .TP \fBrenamemethod\fI fromName toName\fR @@ -183,21 +186,23 @@ operates identically to If no arguments at all are used, this gives the name of the class currently being configured. .VE TIP470 +.VS TIP500 +If in a private definition context (see the \fBprivate\fR definition command, +below), the definitions on the class object will also be made in a private +definition context. +.VE TIP500 .RE .TP \fBsuperclass\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? -.VS +. This slot (see \fBSLOTTED DEFINITIONS\fR below) -.VE allows the alteration of the superclasses of the class being defined. Each \fIclassName\fR argument names one class that is to be a superclass of the defined class. Note that objects must not be changed from being classes to being non-classes or vice-versa, that an empty parent class is equivalent to \fBoo::object\fR, and that the parent classes of \fBoo::object\fR and \fBoo::class\fR may not be modified. -.VS By default, this slot works by replacement. -.VE .TP \fBunexport\fI name \fR?\fIname ...\fR? . @@ -209,7 +214,7 @@ actually defined by a superclass; subclass unexports override superclass visibility, and may be overridden by instance unexports. .TP \fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR? -.VS +. This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named variables to be automatically made available in the methods, constructor and destructor declared by the class @@ -234,7 +239,6 @@ namespace has a unique prefix that makes accidental use from other classes extremely unlikely. .VE TIP500 .RE -.VE .SS "CONFIGURING OBJECTS" .PP The following commands are supported in the \fIdefScript\fR for @@ -261,18 +265,15 @@ being defined. Note that the methods themselves may be actually defined by a class or superclass; object exports override class visibility. .TP \fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? -.VS +. This slot (see \fBSLOTTED DEFINITIONS\fR below) -.VE sets or updates the list of method names that are used to guard whether a method call to the object may be called and what the method's results are. Each \fImethodName\fR names a single filtering method (which may be exposed or not exposed); it is not an error for a non-existent method to be named. Note that the actual list of filters also depends on the filters set upon any classes that the object is an instance of. -.VS By default, this slot works by appending. -.VE .TP \fBforward\fI name cmdName \fR?\fIarg ...\fR? . @@ -308,24 +309,28 @@ below), this command creates private procedure-like methods. .RE .TP \fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? -.VS +. This slot (see \fBSLOTTED DEFINITIONS\fR below) -.VE sets or updates a per-object list of additional classes that are to be mixed into the object. Each argument, \fIclassName\fR, names a single class that is to be mixed in. -.VS By default, this slot works by replacement. -.VE .TP \fBprivate \fIcmd arg...\fR .TP \fBprivate \fIscript\fR -. .VS TIP500 This evaluates the \fIscript\fR (or the list of command and arguments given by \fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the current object will be private definitions. +.RS +.PP +The following class definition commands are affected by \fBprivate\fR: +\fBforward\fR, \fBmethod\fR, and \fBvariable\fR. Nesting \fBprivate\fR inside +\fBprivate\fR has no cumulative effect; the innermost definition context is +just a private definition context. All other definition commands have no +difference in behavior when used in a private definition context. +.RE .VE TIP500 .TP \fBrenamemethod\fI fromName toName\fR @@ -337,7 +342,6 @@ that the object is an instance of. Does not change the export status of the method; if it was exported before, it will be afterwards. .TP \fBself \fR -. .VS TIP470 This gives the name of the object currently being configured. .VE TIP470 @@ -351,7 +355,7 @@ object being defined. Note that the methods themselves may be actually defined by a class; instance unexports override class visibility. .TP \fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR? -.VS +. This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named variables to be automatically made available in the methods declared by the object being defined. Each variable name must not have any namespace @@ -394,20 +398,17 @@ object, that is an instance of the class \fBoo::Slot\fR, which manages a list of values (class names, variable names, etc.) that comprises the contents of the slot. The class defines three operations (as methods) that may be done on the slot: -.VE .TP \fIslot\fR \fB\-append\fR ?\fImember ...\fR? -.VS +. This appends the given \fImember\fR elements to the slot definition. -.VE .TP \fIslot\fR \fB\-clear\fR -.VS +. This sets the slot definition to the empty list. -.VE .TP \fIslot\fR \fB\-set\fR ?\fImember ...\fR? -.VS +. This replaces the slot definition with the given \fImember\fR elements. .PP A consequence of this is that any use of a slot's default operation where the @@ -420,17 +421,15 @@ which is forwarded to the default operation of the slot (thus, for the class slot, this is forwarded to .QW "\fBmy \-append\fR" ), and these methods which provide the implementation interface: -.VE .TP \fIslot\fR \fBGet\fR -.VS +. Returns a list that is the current contents of the slot. This method must always be called from a stack frame created by a call to \fBoo::define\fR or \fBoo::objdefine\fR. -.VE .TP \fIslot\fR \fBSet \fIelementList\fR -.VS +. Sets the contents of the slot to the list \fIelementList\fR and returns the empty string. This method must always be called from a stack frame created by a call to \fBoo::define\fR or \fBoo::objdefine\fR. @@ -441,7 +440,6 @@ an unknown method handler to tie all these pieces together, and they hide their \fBdestroy\fR method so that it is not invoked inadvertently. It is \fIrecommended\fR that any user changes to the slot mechanism be restricted to defining new operations whose names start with a hyphen. -.VE .SH EXAMPLES This example demonstrates how to use both forms of the \fBoo::define\fR and \fBoo::objdefine\fR commands (they work in the same way), as well as diff --git a/doc/info.n b/doc/info.n index 869169d..02470af 100644 --- a/doc/info.n +++ b/doc/info.n @@ -406,7 +406,11 @@ stereotypical instance of \fIclass\fR's implementation of \fImethod\fR any object-specific definitions added). This consists of a list of lists of four elements, where each sublist consists of a word that describes the general type of method implementation (being one of \fBmethod\fR for an -ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a +ordinary method, \fBfilter\fR for an applied filter, +.VS TIP500 +\fBprivate\fR for a private method, +.VE TIP500 +and \fBunknown\fR for a method that is invoked as part of unknown method handling), a word giving the name of the particular method invoked (which is always the same as \fImethod\fR for the \fBmethod\fR type, and @@ -417,7 +421,11 @@ implementation (see \fBinfo class methodtype\fR). .RS .PP Note that there is no inspection of whether the method implementations -actually use \fBnext\fR to transfer control along the call chain. +actually use \fBnext\fR to transfer control along the call chain, +.VS TIP500 +and the call chains that this command files do not actually contain private +methods. +.VE TIP500 .RE .TP \fBinfo class constructor\fI class\fR @@ -551,7 +559,11 @@ Returns a description of the method implementations that are used to provide \fIobject\fR's implementation of \fImethod\fR. This consists of a list of lists of four elements, where each sublist consists of a word that describes the general type of method implementation (being one of \fBmethod\fR for an -ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a +ordinary method, \fBfilter\fR for an applied filter, +.VS TIP500 +\fBprivate\fR for a private method, +.VE TIP500 +and \fBunknown\fR for a method that is invoked as part of unknown method handling), a word giving the name of the particular method invoked (which is always the same as \fImethod\fR for the \fBmethod\fR type, and @@ -563,7 +575,11 @@ implementation (see \fBinfo object methodtype\fR). .RS .PP Note that there is no inspection of whether the method implementations -actually use \fBnext\fR to transfer control along the call chain. +actually use \fBnext\fR to transfer control along the call chain, +.VS TIP500 +and the call chains that this command files do not actually contain private +methods. +.VE TIP500 .RE .TP \fBinfo object class\fI object\fR ?\fIclassName\fR? @@ -763,8 +779,10 @@ method and get how it is defined. This procedure illustrates how: proc getDef {obj method} { foreach inf [\fBinfo object call\fR $obj $method] { lassign $inf calltype name locus methodtype + # Assume no forwards or filters, and hence no $calltype # or $methodtype checks... + if {$locus eq "object"} { return [\fBinfo object definition\fR $obj $name] } else { @@ -787,7 +805,9 @@ proc getDef {obj method} { # Assume no forwards return [\fBinfo object definition\fR $obj $method] } + set cls [\fBinfo object class\fR $obj] + while {$method ni [\fBinfo class methods\fR $cls]} { # Assume the simple case set cls [lindex [\fBinfo class superclass\fR $cls] 0] @@ -795,6 +815,7 @@ proc getDef {obj method} { error "no definition for $method" } } + # Assume no forwards return [\fBinfo class definition\fR $cls $method] } diff --git a/doc/my.n b/doc/my.n index 2a9769b..26d861a 100644 --- a/doc/my.n +++ b/doc/my.n @@ -19,13 +19,18 @@ package require TclOO .BE .SH DESCRIPTION .PP -The \fBmy\fR command is used to allow methods of objects to invoke any method +The \fBmy\fR command is used to allow methods of objects to invoke methods of the object (or its class). In particular, the set of valid values for \fImethodName\fR is the set of all methods supported by an object and its -superclasses, including those that are not exported. The object upon which the -method is invoked is always the one that is the current context of the method -(i.e. the object that is returned by \fBself object\fR) from which the -\fBmy\fR command is invoked. +superclasses, including those that are not exported +.VS TIP500 +and private methods of the object or class when used within another method +defined by that object or class. +.VE TIP500 +The object upon which the method is invoked is the one that owns the namespace +that the \fBmy\fR command is contained in initially (\fBNB:\fR the link +remains if the command is renamed), which is the currently invoked object by +default. .PP Each object has its own \fBmy\fR command, contained in its instance namespace. .SH EXAMPLES @@ -40,16 +45,38 @@ oo::class create c { puts [incr counter] } } + c create o o count \fI\(-> prints "1"\fR o count \fI\(-> prints "2"\fR o count \fI\(-> prints "3"\fR .CE +.PP +This example shows how you can use \fBmy\fR to make callbacks to private +methods from outside the object (from a \fBtrace\fR), using +\fBnamespace code\fR to enter the correct context: +.PP +.CS +oo::class create HasCallback { + method makeCallback {} { + return [namespace code { + \fBmy\fR Callback + }] + } + + method Callback {args} { + puts "callback: $args" + } +} + +set o [HasCallback new] +trace add variable xyz write [$o makeCallback] +set xyz "called" \fI\(-> prints "callback: xyz {} write"\fR +.CE .SH "SEE ALSO" next(n), oo::object(n), self(n) .SH KEYWORDS method, method visibility, object, private method, public method - .\" Local variables: .\" mode: nroff .\" fill-column: 78 diff --git a/doc/next.n b/doc/next.n index db846be..8ebaed2 100644 --- a/doc/next.n +++ b/doc/next.n @@ -112,6 +112,7 @@ oo::class create theSuperclass { puts "in the superclass, args = $args" } } + oo::class create theSubclass { superclass theSuperclass method example {args} { @@ -121,6 +122,7 @@ oo::class create theSubclass { puts "after chaining from subclass" } } + theSubclass create obj oo::objdefine obj method example args { puts "per-object method, args = $args" @@ -167,6 +169,7 @@ oo::class create cache { \fI# Compute value, insert into cache, and return it\fR return [set ValueCache($key) [\fBnext\fR {*}$args]] } + method flushCache {} { my variable ValueCache unset ValueCache @@ -178,10 +181,12 @@ oo::class create cache { oo::object create demo oo::objdefine demo { mixin cache + method compute {a b c} { after 3000 \fI;# Simulate deep thought\fR return [expr {$a + $b * $c}] } + method compute2 {a b c} { after 3000 \fI;# Simulate deep thought\fR return [expr {$a * $b + $c}] diff --git a/doc/self.n b/doc/self.n index 0ad5428..855d067 100644 --- a/doc/self.n +++ b/doc/self.n @@ -32,7 +32,12 @@ implement the current call chain. The first element is the same as would be reported by \fBinfo object\fR \fBcall\fR for the current method (except that this also reports useful values from within constructors and destructors, whose names are reported as \fB\fR and \fB\fR -respectively), and the second element is an index into the first element's +respectively, +.VS TIP500 +and for private methods, which are described as being \fBprivate\fR instead of +being a \fBmethod\fR), +.VE TIP500 +and the second element is an index into the first element's list that indicates which actual implementation is currently executing (the first implementation to execute is always at index 0). .TP -- cgit v0.12 From 5e3ca11761b27133a62ee5cd5e340956c640ca8d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 May 2018 07:17:23 +0000 Subject: Neither use --disable-threads on MacOS builds, and don't mention it any more in the README --- macosx/GNUmakefile | 2 +- macosx/Tcl-Common.xcconfig | 2 +- unix/README | 2 -- 3 files changed, 2 insertions(+), 4 deletions(-) diff --git a/macosx/GNUmakefile b/macosx/GNUmakefile index 1d26a7a..43f8419 100644 --- a/macosx/GNUmakefile +++ b/macosx/GNUmakefile @@ -132,7 +132,7 @@ ${objdir}/Makefile: ${UNIX_DIR}/Makefile.in ${UNIX_DIR}/configure \ mkdir -p "${OBJ_DIR}" && cd "${OBJ_DIR}" && \ if [ ${UNIX_DIR}/configure -nt config.status ]; then ${UNIX_DIR}/configure -C \ --prefix="${PREFIX}" --bindir="${BINDIR}" --libdir="${LIBDIR}" \ - --mandir="${MANDIR}" --enable-threads --enable-framework --enable-dtrace \ + --mandir="${MANDIR}" --enable-framework --enable-dtrace \ ${CONFIGURE_ARGS} ${EXTRA_CONFIGURE_ARGS}; else ./config.status; fi build-${PROJECT}: ${objdir}/Makefile diff --git a/macosx/Tcl-Common.xcconfig b/macosx/Tcl-Common.xcconfig index 77402b7..0670479 100644 --- a/macosx/Tcl-Common.xcconfig +++ b/macosx/Tcl-Common.xcconfig @@ -30,7 +30,7 @@ MANDIR = $(PREFIX)/man PER_ARCH_CFLAGS_ppc = -mcpu=G3 -mtune=G4 $(PER_ARCH_CFLAGS_ppc) PER_ARCH_CFLAGS_ppc64 = -mcpu=G5 -mpowerpc64 $(PER_ARCH_CFLAGS_ppc64) PREFIX = /usr/local -TCL_CONFIGURE_ARGS = --enable-threads --enable-dtrace +TCL_CONFIGURE_ARGS = --enable-dtrace TCL_LIBRARY = $(LIBDIR)/tcl$(VERSION) TCL_PACKAGE_PATH = "$(LIBDIR)" TCL_DEFS = HAVE_TCL_CONFIG_H diff --git a/unix/README b/unix/README index d8f1090..381cbdd 100644 --- a/unix/README +++ b/unix/README @@ -45,8 +45,6 @@ How To Compile And Install Tcl: refer to the autoconf documentation (not included here). Tcl's "configure" supports the following special switches in addition to the standard ones: - --enable-threads If this switch is set, Tcl will compile itself - with multithreading support. --disable-load If this switch is specified then Tcl will configure itself not to allow dynamic loading, even if your system appears to support it. -- cgit v0.12