diff options
Diffstat (limited to 'generic/tclOODefineCmds.c')
| -rw-r--r-- | generic/tclOODefineCmds.c | 384 |
1 files changed, 284 insertions, 100 deletions
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index b443be8..19cd42b 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. */ @@ -118,6 +124,35 @@ static const struct DeclaredSlot slots[] = { SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet), {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" + +/* + * ---------------------------------------------------------------------- + * + * 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; +} /* * ---------------------------------------------------------------------- @@ -419,6 +454,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 ; i<varc ; i++) { + Tcl_IncrRefCount(varv[i]); + } + FOREACH(variableObj, *vnlPtr) { + Tcl_DecrRefCount(variableObj); + } + if (i != varc) { + if (varc == 0) { + ckfree(vnlPtr->list); + } 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 ; i<varc ; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + vnlPtr->list[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 ; i<varc ; i++) { + Tcl_IncrRefCount(varv[i]); + } + FOREACH_STRUCT(privatePtr, *pvlPtr) { + Tcl_DecrRefCount(privatePtr->variableObj); + 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 ; i<varc ; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + privatePtr = &(pvlPtr->list[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. @@ -708,7 +860,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)); @@ -749,7 +902,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"); } @@ -1038,7 +1192,7 @@ TclOODefineSelfObjCmd( { Foundation *fPtr = TclOOGetFoundation(interp); Object *oPtr; - int result; + int result, private; oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { @@ -1050,6 +1204,8 @@ TclOODefineSelfObjCmd( return TCL_OK; } + private = IsPrivateDefine(interp); + /* * Make the oo::objdefine namespace the current namespace and evaluate the * command(s). @@ -1058,6 +1214,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) { @@ -1065,7 +1224,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"); } @@ -1120,6 +1279,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 == 1) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp))); + return TCL_OK; + } + + /* + * 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" @@ -1460,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; } } @@ -1521,6 +1754,9 @@ TclOODefineForwardObjCmd( } isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") ? PUBLIC_METHOD : 0; + if (IsPrivateDefine(interp)) { + isPublic = TRUE_PRIVATE_METHOD; + } /* * Create the method structure. @@ -1580,6 +1816,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. @@ -1795,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; } } @@ -2288,7 +2527,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) { @@ -2306,8 +2545,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; @@ -2323,7 +2572,7 @@ ClassVarsSet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); int varc; - Tcl_Obj **varv, *variableObj; + Tcl_Obj **varv; int i; if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { @@ -2364,49 +2613,11 @@ ClassVarsSet( } } - for (i=0 ; i<varc ; i++) { - Tcl_IncrRefCount(varv[i]); - } - FOREACH(variableObj, oPtr->classPtr->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 ; i<varc ; i++) { - Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); - if (created) { - oPtr->classPtr->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; } @@ -2585,7 +2796,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) { @@ -2597,8 +2808,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; @@ -2614,7 +2835,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, @@ -2647,49 +2868,12 @@ ObjVarsSet( return TCL_ERROR; } } - for (i=0 ; i<varc ; i++) { - Tcl_IncrRefCount(varv[i]); - } - - FOREACH(variableObj, oPtr->variables) { - 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 ; i<varc ; i++) { - Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); - if (created) { - oPtr->variables.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; } |