diff options
| -rw-r--r-- | generic/tclOODefineCmds.c | 220 | ||||
| -rw-r--r-- | generic/tclOOScript.h | 22 | ||||
| -rw-r--r-- | tools/tclOOScript.tcl | 32 | ||||
| -rw-r--r-- | win/Makefile.in | 2 |
4 files changed, 151 insertions, 125 deletions
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index be33f40..3fe4799 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1231,6 +1231,119 @@ MagicDefinitionInvoke( /* * ---------------------------------------------------------------------- * + * ExportMethod, UnexportMethod, ExportInstanceMethod, UnexportInstanceMethod -- + * + * Exporting and unexporting are done by setting or removing the + * PUBLIC_METHOD flag on the method record. If there is no such method in + * this class or object (i.e. the method comes from something inherited + * from or that we're an instance of) then we put in a blank record just + * to hold that flag (or its absence); such records are skipped over by + * the call chain engine *except* for their flags member. + * + * Caller has the responsibility to update any epochs if necessary. + * + * ---------------------------------------------------------------------- + */ + +// Make a blank method record or look up the existing one. +static inline Method * +GetOrCreateMethod( + Tcl_HashTable *tablePtr, + Tcl_Obj *namePtr, + int *isNew) +{ + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tablePtr, namePtr, + isNew); + if (*isNew) { + Method *mPtr = (Method *) Tcl_Alloc(sizeof(Method)); + memset(mPtr, 0, sizeof(Method)); + mPtr->refCount = 1; + mPtr->namePtr = namePtr; + Tcl_IncrRefCount(namePtr); + Tcl_SetHashValue(hPtr, mPtr); + return mPtr; + } else { + return (Method *) Tcl_GetHashValue(hPtr); + } +} + +static int +ExportMethod( + Class *clsPtr, + Tcl_Obj *namePtr) +{ + int isNew; + Method *mPtr = GetOrCreateMethod(&clsPtr->classMethods, namePtr, &isNew); + if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { + mPtr->flags |= PUBLIC_METHOD; + mPtr->flags &= ~TRUE_PRIVATE_METHOD; + isNew = 1; + } + return isNew; +} + +static int +UnexportMethod( + Class *clsPtr, + Tcl_Obj *namePtr) +{ + int isNew; + Method *mPtr = GetOrCreateMethod(&clsPtr->classMethods, namePtr, &isNew); + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); + isNew = 1; + } + return isNew; +} + +// Make the table of methods in the instance if it doesn't already exist. +static inline void +InitMethodTable( + Object *oPtr) +{ + if (!oPtr->methodsPtr) { + oPtr->methodsPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); + Tcl_InitObjHashTable(oPtr->methodsPtr); + oPtr->flags &= ~USE_CLASS_CACHE; + } +} + +static int +ExportInstanceMethod( + Object *oPtr, + Tcl_Obj *namePtr) +{ + InitMethodTable(oPtr); + + int isNew; + Method *mPtr = GetOrCreateMethod(oPtr->methodsPtr, namePtr, &isNew); + if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { + mPtr->flags |= PUBLIC_METHOD; + mPtr->flags &= ~TRUE_PRIVATE_METHOD; + isNew = 1; + } + return isNew; +} + +static int +UnexportInstanceMethod( + Object *oPtr, + Tcl_Obj *namePtr) +{ + InitMethodTable(oPtr); + + int isNew; + Method *mPtr = GetOrCreateMethod(oPtr->methodsPtr, namePtr, &isNew); + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); + isNew = 1; + } + return isNew; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineObjCmd -- * * Implementation of the "oo::define" command. Works by effectively doing @@ -1939,22 +2052,18 @@ TclOODefineExportObjCmd( Tcl_Obj *const *objv) { int isInstanceExport = (clientData != NULL); - Object *oPtr; - Method *mPtr; - Tcl_HashEntry *hPtr; - Class *clsPtr; - int i, isNew, changed = 0; + int i, changed = 0; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); return TCL_ERROR; } - oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } - clsPtr = oPtr->classPtr; + Class *clsPtr = oPtr->classPtr; if (!isInstanceExport && !clsPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", TCL_AUTO_LENGTH)); @@ -1973,33 +2082,9 @@ TclOODefineExportObjCmd( */ if (isInstanceExport) { - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *) - Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i], - &isNew); - } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i], - &isNew); - } - - if (isNew) { - mPtr = (Method *) Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); + changed |= ExportInstanceMethod(oPtr, objv[i]); } else { - mPtr = (Method *) Tcl_GetHashValue(hPtr); - } - if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { - mPtr->flags |= PUBLIC_METHOD; - mPtr->flags &= ~TRUE_PRIVATE_METHOD; - changed = 1; + changed |= ExportMethod(clsPtr, objv[i]); } } @@ -2356,75 +2441,6 @@ TclOODefineRenameMethodObjCmd( } /* - * Unexporting is done by removing the PUBLIC_METHOD flag from the method - * record. If there is no such method in this object or class (i.e. the method - * comes from something inherited from or that we're an instance of) then we - * put in a blank record without that flag; such records are skipped over by - * the call chain engine *except* for their flags member. - * - * Caller has the responsibility to update any epochs if necessary. - */ - -static int -UnexportMethod( - Class *clsPtr, - Tcl_Obj *namePtr) -{ - int isNew; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, namePtr, - &isNew); - Method *mPtr; - if (isNew) { - mPtr = (Method *) Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = namePtr; - Tcl_IncrRefCount(namePtr); - Tcl_SetHashValue(hPtr, mPtr); - } else { - mPtr = (Method *) Tcl_GetHashValue(hPtr); - } - if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { - mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); - isNew = 1; - } - return isNew; -} - -static int -UnexportInstanceMethod( - Object *oPtr, - Tcl_Obj *namePtr) -{ - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *) - Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - - int isNew; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, namePtr, - &isNew); - Method *mPtr; - if (isNew) { - mPtr = (Method *) Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = namePtr; - Tcl_IncrRefCount(namePtr); - Tcl_SetHashValue(hPtr, mPtr); - } else { - mPtr = (Method *) Tcl_GetHashValue(hPtr); - } - if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { - mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); - isNew = 1; - } - return isNew; -} - -/* * ---------------------------------------------------------------------- * * TclOODefineUnexportObjCmd -- diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 4c5f1a2..390b034 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -72,24 +72,24 @@ static const char *tclOOSetupScript = "\t}\n" "\tclass create singleton\n" "\tdefine singleton superclass -set class\n" -"\tdefine singleton variable -set object\n" "\tdefine singleton unexport create createWithNamespace\n" "\tdefine singleton method new args {\n" +"\t\tvariable object\n" "\t\tif {![info exists object] || ![info object isa object $object]} {\n" "\t\t\tset object [next {*}$args]\n" -"\t\t\t::oo::objdefine $object {\n" -"\t\t\t\tmethod destroy {} {\n" -"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" -"\t\t\t\t\t\t\"may not destroy a singleton object\"\n" -"\t\t\t\t}\n" -"\t\t\t\tmethod <cloned> -unexport {originObject} {\n" -"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" -"\t\t\t\t\t\t\"may not clone a singleton object\"\n" -"\t\t\t\t}\n" -"\t\t\t}\n" +"\t\t\t::oo::objdefine $object mixin -prepend ::oo::SingletonInstance\n" "\t\t}\n" "\t\treturn $object\n" "\t}\n" +"\tclass create SingletonInstance\n" +"\tdefine SingletonInstance method destroy {} {\n" +"\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\"may not destroy a singleton object\"\n" +"\t}\n" +"\tdefine SingletonInstance method <cloned> -unexport {originObject} {\n" +"\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\"may not clone a singleton object\"\n" +"\t}\n" "\tclass create abstract\n" "\tdefine abstract superclass -set class\n" "\tdefine abstract unexport create createWithNamespace new\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 6b17483..b17d7d0 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -92,27 +92,37 @@ class create singleton define singleton superclass -set class - define singleton variable -set object define singleton unexport create createWithNamespace define singleton method new args { + variable object if {![info exists object] || ![info object isa object $object]} { set object [next {*}$args] - ::oo::objdefine $object { - method destroy {} { - return -code error -errorcode {TCL OO SINGLETON} \ - "may not destroy a singleton object" - } - method <cloned> -unexport {originObject} { - return -code error -errorcode {TCL OO SINGLETON} \ - "may not clone a singleton object" - } - } + ::oo::objdefine $object mixin -prepend ::oo::SingletonInstance } return $object } # ---------------------------------------------------------------------- # + # oo::SingletonInstance -- + # + # A mixin used to make an object so it won't be destroyed or cloned (or + # at least not easily). + # + # ---------------------------------------------------------------------- + + class create SingletonInstance + define SingletonInstance method destroy {} { + return -code error -errorcode {TCL OO SINGLETON} \ + "may not destroy a singleton object" + } + define SingletonInstance method <cloned> -unexport {originObject} { + return -code error -errorcode {TCL OO SINGLETON} \ + "may not clone a singleton object" + } + + # ---------------------------------------------------------------------- + # # oo::abstract -- # # A metaclass that is used to make classes that can't be directly diff --git a/win/Makefile.in b/win/Makefile.in index e039f64..bcb35c1 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -767,7 +767,7 @@ tclWinPanic.${OBJEXT}: tclWinPanic.c .rc.$(RES): $(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@ - +tclOO.${OBJEXT}: tclOO.c tclOOScript.h #-------------------------------------------------------------------------- # Minizip implementation |