Posted to tcl by apw at Mon Jul 23 10:09:50 GMT 2007view pretty
ndex: tclOOInt.h
===================================================================
RCS file: /cvsroot/tcl/oocore/generic/tclOOInt.h,v
retrieving revision 1.8
diff -b -u -r1.8 tclOOInt.h
--- tclOOInt.h 25 Jun 2007 14:20:20 -0000 1.8
+++ tclOOInt.h 23 Jul 2007 09:55:36 -0000
@@ -131,6 +131,12 @@
Tcl_Obj *cachedNameObj; /* Cache of the name of the object. */
Tcl_HashTable publicContextCache; /* Place to keep unused contexts. */
Tcl_HashTable privateContextCache; /* Place to keep unused contexts. */
+#ifdef ARNULF_FOR_ITCL_CODE
+ Tcl_Resolve *resolvePtr;
+ /* Points to a struct for resolving commands
+ * and variables
+ */
+#endif
} Object;
#define OBJECT_DELETED 1 /* Flag to say that an object has been
@@ -378,7 +384,7 @@
CallContext *contextPtr);
MODULE_SCOPE CallContext *TclOOGetCallContext(Foundation *fPtr, Object *oPtr,
Tcl_Obj *methodNameObj, int flags,
- Tcl_HashTable *cachePtr);
+ Tcl_HashTable *cachePtr, Class *clsPtr);
MODULE_SCOPE int TclOOInvokeContext(Tcl_Interp *interp,
CallContext *contextPtr, int objc,
Tcl_Obj *const *objv);
Index: tclOO.c
===================================================================
RCS file: /cvsroot/tcl/oocore/generic/tclOO.c,v
retrieving revision 1.20
diff -b -u -r1.20 tclOO.c
--- tclOO.c 16 Jun 2007 14:53:08 -0000 1.20
+++ tclOO.c 23 Jul 2007 09:55:50 -0000
@@ -397,6 +397,9 @@
oPtr->flags = 0;
oPtr->creationEpoch = creationEpoch;
oPtr->metadataPtr = NULL;
+#ifdef ARNULF_FOR_ITCL_CODE
+ oPtr->resolvePtr = NULL;
+#endif
/*
* Initialize the traces.
@@ -479,7 +482,7 @@
if (!Tcl_InterpDeleted(interp)) {
CallContext *contextPtr =
TclOOGetCallContext(TclOOGetFoundation(interp), oPtr, NULL,
- DESTRUCTOR, NULL);
+ DESTRUCTOR, NULL, NULL);
if (contextPtr != NULL) {
int result;
@@ -717,6 +720,11 @@
ckfree((char *) oPtr->metadataPtr);
oPtr->metadataPtr = NULL;
}
+#ifdef ARNULF_FOR_ITCL_CODE
+ if (oPtr->resolvePtr != NULL) {
+ ckfree((char *) oPtr->resolvePtr);
+ }
+#endif
if (clsPtr != NULL && !(oPtr->flags & ROOT_OBJECT)) {
Class *superPtr, *mixinPtr;
@@ -1162,7 +1170,7 @@
if (objc >= 0) {
contextPtr = TclOOGetCallContext(TclOOGetFoundation(interp), oPtr,
- NULL, CONSTRUCTOR, NULL);
+ NULL, CONSTRUCTOR, NULL, NULL);
if (contextPtr != NULL) {
int result;
Tcl_InterpState state;
@@ -1675,6 +1683,7 @@
int objc,
Tcl_Obj *const *objv)
{
+
return ObjectCmd(clientData, interp, objc, objv, PUBLIC_METHOD,
&((Object *)clientData)->publicContextCache);
}
@@ -1690,6 +1699,7 @@
&((Object *)clientData)->privateContextCache);
}
+void InitClassHierarchy(Foundation *fPtr, Class *classPtr);
static int
ObjectCmd(
Object *oPtr, /* The object being invoked. */
@@ -1701,6 +1711,13 @@
Tcl_HashTable *cachePtr) /* What call chain cache to use. */
{
CallContext *contextPtr;
+ Class *clsPtr;
+ Class *superPtr;
+ Tcl_Obj *objName;
+ char *sp;
+ char *cp;
+ Tcl_Obj *className;
+ int i;
int result;
if (objc < 2) {
@@ -1708,8 +1725,34 @@
return TCL_ERROR;
}
+ clsPtr = NULL;
+ objName = NULL;
+ className = NULL;
+ if (objv[1] != NULL) {
+ sp = Tcl_GetString(objv[1]);
+ cp = strstr(sp, "::");
+ if (cp != NULL) {
+ objName = Tcl_NewStringObj(cp+2, -1);
+ InitClassHierarchy(TclOOGetFoundation(interp), oPtr->selfCls);
+ className = Tcl_NewStringObj(sp, cp-sp);
+ Tcl_IncrRefCount(className);
+ sp = Tcl_GetString(className);
+ if (strcmp(oPtr->selfCls->thisPtr->namespacePtr->name, sp) != 0) {
+ FOREACH(superPtr, oPtr->selfCls->superclasses) {
+ if (strcmp(superPtr->thisPtr->namespacePtr->name, sp) == 0) {
+ clsPtr = superPtr;
+ break;
+ }
+
+ }
+ } else {
+ clsPtr = oPtr->selfCls;
+ }
+ Tcl_DecrRefCount(className);
+ }
+ }
contextPtr = TclOOGetCallContext(TclOOGetFoundation(interp), oPtr,
- objv[1], flags | (oPtr->flags & FILTER_HANDLING), cachePtr);
+ objName == NULL ? objv[1] : objName, flags | (oPtr->flags & FILTER_HANDLING), cachePtr, clsPtr);
if (contextPtr == NULL) {
Tcl_AppendResult(interp, "impossible to invoke method \"",
TclGetString(objv[1]),
Index: tclOOMethod.c
===================================================================
RCS file: /cvsroot/tcl/oocore/generic/tclOOMethod.c,v
retrieving revision 1.4
diff -b -u -r1.4 tclOOMethod.c
--- tclOOMethod.c 25 Jun 2007 14:20:21 -0000 1.4
+++ tclOOMethod.c 23 Jul 2007 09:55:57 -0000
@@ -583,6 +583,9 @@
if (pmPtr->flags & USE_DECLARER_NS) {
register Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
+#ifdef ARNULF_FOR_ITCL_CODE
+ flags |= FRAME_HAS_RESOLVER;
+#endif
if (mPtr->declaringClassPtr != NULL) {
nsPtr = mPtr->declaringClassPtr->thisPtr->namespacePtr;
} else {
@@ -615,6 +618,40 @@
framePtr->objv = objv; /* ref counts for args are incremented below */
framePtr->procPtr = pmPtr->procPtr;
+#ifdef ARNULF_FOR_ITCL_CODE
+ if (flags & FRAME_HAS_RESOLVER) {
+ Tcl_DString buffer;
+ Tcl_Resolve *resolvePtr;
+ Tcl_Namespace *varNsPtr;
+
+ if (flags & FRAME_IS_CONSTRUCTOR) {
+ Tcl_DStringInit(&buffer);
+ Tcl_DStringAppend(&buffer, "::itcl::variables::", -1);
+ Tcl_DStringAppend(&buffer,
+ Tcl_GetCommandName(interp, oPtr->command), -1);
+ varNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer),
+ NULL, 0);
+//fprintf(stderr, "CONVNS3!%s!%p\n", Tcl_DStringValue(&buffer), varNsPtr);
+ if (varNsPtr != NULL) {
+ SetVarResolver((Tcl_Object)oPtr, varNsPtr);
+ }
+ Tcl_DStringFree(&buffer);
+ }
+ resolvePtr = oPtr->resolvePtr;
+ if ((resolvePtr != NULL) &&
+ (oPtr->resolvePtr->objectVarNsPtr != NULL)) {
+ Tcl_DStringInit(&buffer);
+ Tcl_DStringAppend(&buffer,
+ oPtr->resolvePtr->objectVarNsPtr->fullName, -1);
+ Tcl_DStringAppend(&buffer, nsPtr->fullName, -1);
+ oPtr->resolvePtr->varNsPtr = Tcl_FindNamespace(interp,
+ Tcl_DStringValue(&buffer), NULL, 0);
+//fprintf(stderr, "FN!%s!%p\n", Tcl_DStringValue(&buffer), oPtr->resolvePtr->varNsPtr);
+ Tcl_DStringFree(&buffer);
+ }
+ framePtr->resolvePtr = oPtr->resolvePtr;
+ }
+#endif
/*
* Finish filling out the extra frame info.
*/
@@ -1148,6 +1185,22 @@
return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0;
}
+#ifdef ARNULF_FOR_ITCL_CODE
+void
+SetVarResolver(
+ Tcl_Object oPtr,
+ Tcl_Namespace *nsPtr)
+{
+ if (oPtr != NULL) {
+ Tcl_Resolve *resolvePtr;
+ resolvePtr = (Tcl_Resolve *) ckalloc(sizeof(Tcl_Resolve));
+ resolvePtr->objectVarNsPtr = nsPtr;
+ resolvePtr->varNsPtr = NULL;
+ ((Object*)oPtr)->resolvePtr = resolvePtr;
+ }
+}
+#endif
+
/*
* Local Variables:
* mode: c
Index: tclOODefineCmds.c
===================================================================
RCS file: /cvsroot/tcl/oocore/generic/tclOODefineCmds.c,v
retrieving revision 1.1
diff -b -u -r1.1 tclOODefineCmds.c
--- tclOODefineCmds.c 18 May 2007 13:17:15 -0000 1.1
+++ tclOODefineCmds.c 23 Jul 2007 09:56:06 -0000
@@ -154,12 +154,16 @@
Object *oPtr;
Class *clsPtr;
int bodyLength;
+ int use_declarer_ns_flag = 0;
- if (objc != 3) {
+ if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "arguments body");
return TCL_ERROR;
}
+ if (objc > 3) {
+ use_declarer_ns_flag = USE_DECLARER_NS;
+ }
/*
* Extract and validate the context, which is the class that we wish to
* modify.
@@ -184,7 +188,7 @@
Method *mPtr;
- mPtr = TclOONewProcClassMethod(interp, clsPtr, PUBLIC_METHOD, NULL,
+ mPtr = TclOONewProcClassMethod(interp, clsPtr, PUBLIC_METHOD|use_declarer_ns_flag, NULL,
objv[1], objv[2]);
if (mPtr == NULL) {
return TCL_ERROR;
@@ -221,12 +225,16 @@
Object *oPtr;
Class *clsPtr;
int bodyLength;
+ int use_declarer_ns_flag = 0;
- if (objc != 2) {
+ if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "body");
return TCL_ERROR;
}
+ if (objc > 2) {
+ use_declarer_ns_flag = USE_DECLARER_NS;
+ }
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
@@ -246,7 +254,7 @@
Method *mPtr;
- mPtr = TclOONewProcClassMethod(interp, clsPtr, PUBLIC_METHOD, NULL,
+ mPtr = TclOONewProcClassMethod(interp, clsPtr, PUBLIC_METHOD|use_declarer_ns_flag, NULL,
NULL, objv[1]);
if (mPtr == NULL) {
return TCL_ERROR;
@@ -482,12 +490,16 @@
int isSelfMethod = (clientData != NULL);
Object *oPtr;
int bodyLength;
+ int use_declarer_ns_flag = 0;
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "name args body");
+ if (objc != 4 && objc != 5) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name args body ?flag?");
return TCL_ERROR;
}
+ if (objc > 4) {
+ use_declarer_ns_flag = USE_DECLARER_NS;
+ }
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
@@ -504,6 +516,7 @@
int isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
? PUBLIC_METHOD : 0;
+isPublic |= use_declarer_ns_flag;
if (isSelfMethod) {
mPtr = TclOONewProcMethod(interp, oPtr, isPublic, objv[1],
objv[2], objv[3]);
Index: tclOOCall.c
===================================================================
RCS file: /cvsroot/tcl/oocore/generic/tclOOCall.c,v
retrieving revision 1.2
diff -b -u -r1.2 tclOOCall.c
--- tclOOCall.c 15 Jun 2007 14:26:03 -0000 1.2
+++ tclOOCall.c 23 Jul 2007 09:56:11 -0000
@@ -51,13 +51,13 @@
static void AddSimpleChainToCallContext(Object *oPtr,
Tcl_Obj *methodNameObj, struct ChainBuilder *cbPtr,
Tcl_HashTable *doneFilters, int isPublic,
- Class *filterDecl);
+ Class *filterDecl, Class *clsPtr);
static void AddSimpleClassChainToCallContext(Class *classPtr,
Tcl_Obj *methodNameObj, struct ChainBuilder *cbPtr,
Tcl_HashTable *doneFilters, int isPublic,
Class *filterDecl);
static int CmpStr(const void *ptr1, const void *ptr2);
-static void InitClassHierarchy(Foundation *fPtr, Class *classPtr);
+void InitClassHierarchy(Foundation *fPtr, Class *classPtr);
static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr);
static void FreeMethodNameRep(Tcl_Obj *objPtr);
@@ -244,7 +244,7 @@
* ----------------------------------------------------------------------
*/
-static void
+void
InitClassHierarchy(
Foundation *fPtr,
Class *classPtr)
@@ -532,8 +532,9 @@
* Only the bits PUBLIC_METHOD, CONSTRUCTOR,
* PRIVATE_METHOD, DESTRUCTOR and
* FILTER_HANDLING are useful. */
- Tcl_HashTable *cachePtr) /* Where to cache the chain. Ignored for both
+ Tcl_HashTable *cachePtr, /* Where to cache the chain. Ignored for both
* constructors and destructors. */
+ Class *clsPtr) /* class if direct call with classname in front */
{
struct ChainBuilder cb;
int i, count, doFilters;
@@ -608,7 +609,7 @@
}
FOREACH(filterObj, oPtr->filters) {
AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0,
- NULL);
+ NULL, NULL);
}
AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters);
Tcl_DeleteHashTable(&doneFilters);
@@ -619,7 +620,7 @@
* Add the actual method implementations.
*/
- AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL);
+ AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL, clsPtr);
/*
* Check to see if the method has no implementation. If so, we probably
@@ -638,7 +639,7 @@
return NULL;
}
AddSimpleChainToCallContext(oPtr, fPtr->unknownMethodNameObj, &cb,
- NULL, 0, NULL);
+ NULL, 0, NULL, NULL);
cb.contextPtr->flags |= OO_UNKNOWN_METHOD;
cb.contextPtr->globalEpoch = -1;
if (count == cb.contextPtr->numCallChain) {
@@ -697,7 +698,7 @@
(void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew);
if (isNew) {
AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, doneFilters,
- 0, clsPtr);
+ 0, clsPtr, NULL);
}
}
@@ -740,9 +741,10 @@
Tcl_HashTable *doneFilters, /* Where to record what call chain entries
* have been processed. */
int flags, /* What sort of call chain are we building. */
- Class *filterDecl) /* The class that declared the filter. If
+ Class *filterDecl, /* The class that declared the filter. If
* NULL, either the filter was declared by the
* object or this isn't a filter. */
+ Class *clsPtr) /* class for direct call */
{
int i;
@@ -776,7 +778,7 @@
AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr,
doneFilters, flags, filterDecl);
}
- FOREACH(superPtr, oPtr->selfCls->classHierarchy) {
+ FOREACH(superPtr, clsPtr == NULL ? oPtr->selfCls->classHierarchy : clsPtr->classHierarchy) {
int j=i; /* HACK: save index so can nest FOREACHes. */
FOREACH(mixinPtr, superPtr->mixins) {
AddSimpleClassChainToCallContext(mixinPtr, methodNameObj,
@@ -790,8 +792,8 @@
filterDecl);
}
}
- AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr,
- doneFilters, flags, filterDecl);
+ AddSimpleClassChainToCallContext(clsPtr == NULL ? oPtr->selfCls : clsPtr,
+ methodNameObj, cbPtr, doneFilters, flags, filterDecl);
}
/*