/* * dkfobj.c -- * * This file implements classes and objects in Tcl8.0a{1,2} which * provides 'variables' associated with a group of commands * together with command rewriting to allow the creation of * operations on those commands. It does not provide any * operations which directly change the semantics of Tcl, unless * the user tries to use any core Tcl commands that are * implemented by direct compilation. * * Copyright (c) 1997 Donal Kelvin Fellows * All rights reserved. * * Permission is hereby granted, without written agreement and without * license or royalty fees, to use, copy, modify, and distribute this * software and its documentation for any purpose, provided that the * above copyright notice and the following two paragraphs appear in * all copies of this software. * * IN NO EVENT SHALL THE AUTHOR BE LIABLE TO ANY PARTY FOR DIRECT, * INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE * AUTHOR HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * THE AUTHOR SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, BUT * NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND * FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER * IS ON AN "AS IS" BASIS, AND THE AUTHOR HAS NO OBLIGATION TO PROVIDE * MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. * * It is noted that the author would like to be informed should this * software be used in any commercial system - this is not a * requirement and can be ignored, but it would be nice (and * encourages the development of enhancements to this and other items * of software in the future). At the time of writing, the author can * be reached by electronic mail as or * and it is expected that these are likely * to be the most convenient methods of reaching the author. It is * requested that large messages (including patches and attachments) * be directed to the former address, where the turnaround time also * tends to be smaller. * * TODO: Document this file properly. The amount of code is * non-trivial, and there are a number of places where writing * down a description of the cunning bits would be helpful... * * $Log: dkfobj.c,v $ * Revision 1.2 1997/03/09 17:23:37 donal * Well, we're getting a little closer to the Tcl coding conventions. * The ones that are left are either ones I disagree with (especially * since I get better support from my editor if I do things differently) * or are ones that I haven't got around to complying with yet. * Documentation is the prime problem area here, especially when I've got * a few functions with very closely related functions which would mean * that implementing them as a group would make far more sense. There * are still a few places where the behaviour of the system could be * 'interesting' due to the use of method procedure name caching, and yet * without the caching the performance stinks (measured with previous * versions). The areas to watch out for are renaming of commands (this * doesn't have the conventionally-expected results) and implementing * methods with system commands, where there is a nastly little bug in * the Tcl system (at least in Tcl8.0a1) * */ static char rcsid[] = "$Id: dkfobj.c,v 1.2 1997/03/09 17:23:37 donal Exp $"; /* Outline of calling conventions from Tcl */ /* The class command * ----------------- * class define $name $definition ?$definition ...? * class exists $name * class info class $class * class info method $clobj $method * class info object $object * class info property $clobj $property * class list classes ?$pattern? * class list methods $clobj ?pattern? * class list objects $class ?pattern? * class list properties $clobj ?pattern? * class of $object */ /* Class definition parameters * --------------------------- * inherit $class * virtual * constructor: * object: * class: * shared: * property $name $val * method $name $proc */ /* Property access commands * ------------------------ * $clobj -> $prop * $clobj -> $prop = $val * $clobj -> $prop append ?$val ...? * $clobj -> $prop increment ?$val ...? * $clobj -> $prop lappend ?$val ...? * $clobj -> $prop exists * $clobj -> $prop trace read ?$script? * $clobj -> $prop trace write ?$script? * $clobj -> $prop unset */ #include #include #include struct CommandInfo; struct Property; struct Method; struct Object; struct Class; struct CommandInfo { Tcl_ObjCmdProc *objProc; /* The cached values which we looked * up. */ ClientData clientData; Tcl_CmdDeleteProc *delProc; /* The deleter which we replaced */ ClientData delData; Tcl_HashTable references; /* All the Tcl_Objs that reference * this command */ }; struct Property { int kind; /* What (of the following few * #defines) is this property? */ Tcl_Obj *name; /* Name of the property */ Tcl_Obj *contents; /* Contents of the property */ int tracing; /* Are we performing a trace on this * property now? */ Tcl_Obj *trace_write_script; /* Trace script for writes */ Tcl_Obj *trace_read_script; /* Trace script for reads */ Tcl_Obj *writer; /* What wrote this property last */ }; #define PROPERTY_CLASS 0 #define PROPERTY_OBJECT 1 #define PROPERTY_SHARED 2 struct Method { int kind; /* What (of the following few * #defines) is this method? */ Tcl_Obj *name; /* Name of the method */ Tcl_Obj *commandName; /* Command name (generally procedure * name) for use in rewriting engine * when executing this method. * Expected to cache info the command * for faster execution */ }; #define METHOD_CONSTRUCTOR 0 #define METHOD_CLASS 1 #define METHOD_OBJECT 2 #define METHOD_SHARED 3 struct Object { Tcl_Obj *self; /* "Name" of the object (usually * reference to it too) */ struct Class *myClass; /* Reference to the object's class */ Tcl_HashTable properties; /* The properties of the object */ Tcl_Obj *built_with_constr; /* Which constructor built the object? */ Tcl_Command token; /* The actual command that the object * is implemented as */ Tcl_HashTable references; /* All Tcl_Objs that refer to this * object */ }; struct Class { Tcl_Obj *self; /* Name of the class */ int virtual; /* Is the creation of objects from * this class illegal? */ Tcl_HashTable *classes; /* All classes */ Tcl_HashTable methods; /* The methods of the class */ Tcl_HashTable properties; /* The properties of the class */ Tcl_HashTable objects; /* The objects of the class */ Tcl_Obj *parents; /* What classes did this class inherit * from? */ Tcl_Interp *creatorInterp; /* In what interpreter was this class * created (for when deleting objects */ Tcl_Command token; /* The actual command that the class * was implemented as */ }; /* ---------------------------------------------------------------------- */ static int MakeCommandName _ANSI_ARGS_((Tcl_Interp *, Tcl_Obj *)); static int MakeObjectRef _ANSI_ARGS_((Tcl_Interp *, Tcl_Obj *)); static int MakeDerefMarker _ANSI_ARGS_((Tcl_Interp *, Tcl_Obj *)); #if (TCL_RELEASE_SERIAL == 1) static void EmptyUpdate _ANSI_ARGS_((Tcl_Interp *, Tcl_Obj *)); #define updInterp(o) interp,(o) #else static void EmptyUpdate _ANSI_ARGS_((Tcl_Obj *)); #define updInterp(o) (o) #endif static void DupCommandName _ANSI_ARGS_((Tcl_Obj *, Tcl_Obj *)); static void DupObjectRef _ANSI_ARGS_((Tcl_Obj *, Tcl_Obj *)); static void DupDerefMarker _ANSI_ARGS_((Tcl_Obj *, Tcl_Obj *)); static void FreeObjectRef _ANSI_ARGS_((Tcl_Obj *)); static void FreeCommandName _ANSI_ARGS_((Tcl_Obj *)); static void DeleteCommandAndInvalidateReferences _ANSI_ARGS_((ClientData)); static Tcl_ObjType commandNameType = { "DKF object system: command name", FreeCommandName, DupCommandName, EmptyUpdate, MakeCommandName }; static Tcl_ObjType objectType = { "DKF object system: object", FreeObjectRef, DupObjectRef, EmptyUpdate, MakeObjectRef }; static Tcl_ObjType dereferenceMarkerType = { "DKF object system: dereference marker", NULL, DupDerefMarker, EmptyUpdate, MakeDerefMarker }; static int GetObject _ANSI_ARGS_((Tcl_Interp *, Tcl_Obj *, Tcl_HashTable *, struct Object **)); static int DereferenceP _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *obj)); /* ---------------------------------------------------------------------- */ static int ClassAddDefinition _ANSI_ARGS_((Tcl_Interp *interp, struct Class *newClass, Tcl_Obj *defList, Tcl_HashTable *classes)); static int MethodCall _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *theMethod, Tcl_Obj *theOwner, int objc, Tcl_Obj **objv)); static int ClassImplCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj **objv)); static int ObjImplCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj **objv)); static int ClassCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj **objv)); static void DelPropForReal _ANSI_ARGS_((char *clientData)); static void DelClassForReal _ANSI_ARGS_((char *clientData)); static void DelObjForReal _ANSI_ARGS_((char *clientData)); static void DelClass _ANSI_ARGS_((ClientData clientData)); static void DelClassCmd _ANSI_ARGS_((ClientData clientData)); static void DelObjCmd _ANSI_ARGS_((ClientData clientData)); static int ClassWriteTrace _ANSI_ARGS_((struct Property *propDefn, Tcl_Interp *interp)); static int ClassReadTrace _ANSI_ARGS_((struct Property *propDefn, Tcl_Interp *interp)); static int ObjectWriteTrace _ANSI_ARGS_((struct Property *propDefn, Tcl_Interp *interp)); static int ObjectReadTrace _ANSI_ARGS_((struct Property *propDefn, Tcl_Interp *interp)); static struct Object * BuildObject _ANSI_ARGS_((Tcl_Interp *interp, struct Class *clsDefn, Tcl_Obj *creatorConstr)); static int WriteObjectProp _ANSI_ARGS_((Tcl_Interp *interp, struct Object *objDefn, Tcl_Obj *propName, Tcl_Obj *contents, int defaulted, Tcl_HashEntry *hent, Tcl_Obj **afterContents)); static int ReadObjectProp _ANSI_ARGS_((Tcl_Interp *interp, struct Object *objDefn, Tcl_Obj *propName, Tcl_Obj **contentsPtr, int *defaulted, Tcl_HashEntry **hentPtr)); /* ---------------------------------------------------------------------- */ #if (TCL_RELEASE_SERIAL == 1) static Tcl_HashEntry *FindHashEntry _ANSI_ARGS_((Tcl_Interp *interp, Tcl_HashTable *tablePtr, Tcl_Obj *name)); static Tcl_HashEntry *CreateHashEntry _ANSI_ARGS_((Tcl_Interp *interp, Tcl_HashTable *tablePtr, Tcl_Obj *name)); #else static Tcl_HashEntry *FindHashEntry _ANSI_ARGS_((Tcl_HashTable *tablePtr, Tcl_Obj *name)); static Tcl_HashEntry *CreateHashEntry _ANSI_ARGS_((Tcl_HashTable *tablePtr, Tcl_Obj *name)); #endif static void AppendResult _ANSI_ARGS_((Tcl_Interp *interp, ...)); /* ---------------------------------------------------------------------- */ static void #if (TCL_RELEASE_SERIAL == 1) EmptyUpdate(Tcl_Interp *interp, Tcl_Obj *obj) { #else EmptyUpdate(Tcl_Obj *obj) { #endif /* Do nothing at all! This is a place-holder function... */ } /* ---------------------------------------------------------------------- */ /* Making error messages in Tcl8 is tedious - this makes it 110% easier */ static void AppendResult(Tcl_Interp *interp, ...) { va_list ap; Tcl_Obj *msg = Tcl_NewStringObj("", 0); char *bytes; va_start(ap, interp); while (1) { switch (va_arg(ap, int)) { case 0: va_end(ap); Tcl_SetObjResult(interp, msg); return; case 1: Tcl_StringObjAppend(updInterp(msg), va_arg(ap, char *), -1); break; case 2: Tcl_StringObjAppendObj(updInterp(msg), va_arg(ap, Tcl_Obj *)); break; case 3: bytes = va_arg(ap, char *); Tcl_StringObjAppend(updInterp(msg), bytes, va_arg(ap, int)); break; } } } #define aEND 0 #define aSTR(s) 1,(s) #define aOBJ(o) 2,(o) #define aBYTES(b,l) 3,(b),(l) /* Hashing of Tcl_Objs instead of strings * * Two library routines that should have been in the Tcl library * itself. Indeed, if they were located there, then they could be * made to work correctly with embedded NULs... * * The names are modelled directly after the Tcl operations they sit * on top of. */ static Tcl_HashEntry * #if (TCL_RELEASE_SERIAL == 1) FindHashEntry(interp, tablePtr, name) Tcl_Interp *interp; #else FindHashEntry(tablePtr, name) #endif Tcl_HashTable *tablePtr; Tcl_Obj *name; { int len; return Tcl_FindHashEntry(tablePtr, Tcl_GetStringFromObj(updInterp(name), &len)); } static Tcl_HashEntry * #if (TCL_RELEASE_SERIAL == 1) CreateHashEntry(interp, tablePtr, name) Tcl_Interp *interp; #else CreateHashEntry(tablePtr, name) #endif Tcl_HashTable *tablePtr; Tcl_Obj *name; { int len; return Tcl_CreateHashEntry(tablePtr, Tcl_GetStringFromObj(updInterp(name), &len), &len); } /* * ---------------------------------------------------------------------- * * dereferenceMarkerType -- implementation * * Caches the dereference symbol. Implemented this way for speed. * * ---------------------------------------------------------------------- */ static void DupDerefMarker(Tcl_Obj *src, Tcl_Obj *dup) { dup->typePtr = &dereferenceMarkerType; } static int MakeDerefMarker(Tcl_Interp *interp, Tcl_Obj *obj) { obj->typePtr = &dereferenceMarkerType; return TCL_OK; } static int DereferenceP(Tcl_Interp *interp, Tcl_Obj *obj) { int length; char *bytes; if (obj->typePtr == &dereferenceMarkerType) return 1; bytes = Tcl_GetStringFromObj(updInterp(obj), &length); if (length==2 && bytes[0]=='-' && bytes[1]=='>') { Tcl_ConvertToType(interp, obj, &dereferenceMarkerType); return 1; } return 0; } /* * ---------------------------------------------------------------------- * * objectType -- implementation * * Caches objects for faster lookup of info about the object. * * ---------------------------------------------------------------------- */ static void DupObjectRef(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { struct Object *objDefn = (struct Object *)srcPtr->internalRep.otherValuePtr; int isNew; dupPtr->internalRep.otherValuePtr = srcPtr->internalRep.otherValuePtr; dupPtr->typePtr = &objectType; Tcl_CreateHashEntry(&objDefn->references, (char *)objDefn, &isNew); } static void FreeObjectRef(Tcl_Obj *objPtr) { struct Object *objDefn = (struct Object *)objPtr->internalRep.otherValuePtr; Tcl_HashEntry *hent = Tcl_FindHashEntry(&objDefn->references, (char *)objDefn); if (hent) Tcl_DeleteHashEntry(hent); } /* The next line is Tcl-internal, but does what I want! */ EXTERN void panic _ANSI_ARGS_(TCL_VARARGS(char *,format)); static int MakeObjectRef(Tcl_Interp *interp, Tcl_Obj *objPtr) { panic("MakeObjectRef: some general code tried to use this " "(unsupported) interface"); return TCL_ERROR; } static int GetObject(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_HashTable *classes, struct Object **oReturn) { Tcl_HashSearch hsearch; Tcl_HashEntry *hentCls, *hentObj; if (objPtr->typePtr == &objectType) { *oReturn = objPtr->internalRep.otherValuePtr; return TCL_OK; } hentCls = Tcl_FirstHashEntry(classes, &hsearch); for (;hentCls; hentCls=Tcl_NextHashEntry(&hsearch)) { struct Class *clsDefn = Tcl_GetHashValue(hentCls); hentObj = FindHashEntry(updInterp(&clsDefn->objects), objPtr); if (hentObj) { *oReturn = Tcl_GetHashValue(hentObj); if (objPtr->typePtr && objPtr->typePtr->freeIntRepProc) { objPtr->typePtr->freeIntRepProc(objPtr); } objPtr->typePtr = &objectType; objPtr->internalRep.otherValuePtr = *oReturn; return TCL_OK; } } AppendResult(interp, aSTR("unknown object \""), aOBJ(objPtr), aSTR("\""), aEND); return TCL_ERROR; } /* * ---------------------------------------------------------------------- * * commandNameType -- implementation * * Caches command lookups, correctly dealing with command * deletion. Doesn't handle command renaming correctly though. * * ---------------------------------------------------------------------- */ static void FreeCommandName(Tcl_Obj *obj) { struct CommandInfo *cn = (struct CommandInfo *) obj->internalRep.otherValuePtr; Tcl_HashEntry *hent = Tcl_FindHashEntry(&cn->references, (char *)obj); if (hent) Tcl_DeleteHashEntry(hent); } static void DupCommandName(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { struct CommandInfo *cn = (struct CommandInfo *) srcPtr->internalRep.otherValuePtr; int isNew; dupPtr->internalRep.otherValuePtr = srcPtr->internalRep.otherValuePtr; dupPtr->typePtr = &commandNameType; Tcl_CreateHashEntry(&cn->references, (char *)dupPtr, &isNew); } static int MakeCommandName(Tcl_Interp *interp, Tcl_Obj *obj) { struct CommandInfo *cn; Tcl_CmdInfo info; int len; char *name = Tcl_GetStringFromObj(updInterp(obj), &len); if (!Tcl_GetCommandInfo(interp, name, &info)) { AppendResult(interp, aSTR("invalid command name \""), aOBJ(obj), aSTR("\""), aEND); return TCL_ERROR; } /* Install our trace on command deletion */ if (info.deleteProc != DeleteCommandAndInvalidateReferences) { cn = (struct CommandInfo *)Tcl_Alloc(sizeof(struct CommandInfo)); cn->objProc = info.objProc; cn->clientData = info.objClientData; cn->delProc = info.deleteProc; cn->delData = info.deleteData; Tcl_InitHashTable(&cn->references, TCL_ONE_WORD_KEYS); info.deleteProc = DeleteCommandAndInvalidateReferences; info.deleteData = cn; Tcl_SetCommandInfo(interp, name, &info); } else { cn = info.deleteData; } if (obj->typePtr && obj->typePtr->freeIntRepProc) { obj->typePtr->freeIntRepProc(obj); } obj->internalRep.otherValuePtr = cn; Tcl_CreateHashEntry(&cn->references, (char *)obj, &len); obj->typePtr = &commandNameType; return TCL_OK; } static void DeleteCommandAndInvalidateReferences(ClientData clientData) { struct CommandInfo *cn = clientData; Tcl_HashSearch hsearch; Tcl_HashEntry *hent; cn->delProc(cn->delData); hent = Tcl_FirstHashEntry(&cn->references, &hsearch); for (;hent; hent=Tcl_NextHashEntry(&hsearch)) { Tcl_Obj *obj = Tcl_GetHashValue(hent); /* Invalidate the reference in the object */ obj->typePtr = NULL; } Tcl_DeleteHashTable(&cn->references); Tcl_Free((char *)cn); } static int MethodCall(Tcl_Interp *interp, Tcl_Obj *theMethod, Tcl_Obj *theOwner, int objc, Tcl_Obj **objv) { struct CommandInfo *cn; Tcl_Obj **vector; int retcode; if (theMethod->typePtr != &commandNameType) { if (Tcl_ConvertToType(interp, theMethod, &commandNameType)) return TCL_ERROR; } cn = (struct CommandInfo *)theMethod->internalRep.otherValuePtr; vector = (Tcl_Obj **)Tcl_Alloc((objc+2)*sizeof(Tcl_Obj *)); vector[0] = theMethod; vector[1] = theOwner; memcpy(vector+2, objv, objc*sizeof(Tcl_Obj *)); retcode = cn->objProc(cn->clientData, interp, objc+2, vector); Tcl_Free((char *)vector); return retcode; } /* ---------------------------------------------------------------------- */ /* Traces on class properties */ static int ClassWriteTrace(struct Property *propDefn, Tcl_Interp *interp) { if (!propDefn->tracing) { int code; propDefn->tracing = 1; code = Tcl_GlobalEvalObj(interp, propDefn->trace_write_script); propDefn->tracing = 0; if (code != TCL_OK) { Tcl_AddObjErrorInfo(interp, "\n (write trace on class property)", -1); return TCL_ERROR; } } return TCL_OK; } static int ClassReadTrace(struct Property *propDefn, Tcl_Interp *interp) { if (!propDefn->tracing) { int code; propDefn->tracing = 1; code = Tcl_GlobalEvalObj(interp, propDefn->trace_read_script); propDefn->tracing = 0; if (code != TCL_OK) { Tcl_AddObjErrorInfo(interp, "\n (read trace on class property)", -1); return TCL_ERROR; } } return TCL_OK; } /* Traces on object properties */ static int ObjectWriteTrace(struct Property *propDefn, Tcl_Interp *interp) { if (!propDefn->tracing) { int code; propDefn->tracing = 1; code = Tcl_GlobalEvalObj(interp, propDefn->trace_write_script); propDefn->tracing = 0; if (code != TCL_OK) { Tcl_AddObjErrorInfo(interp,"\n (write trace on object property)", -1); return TCL_ERROR; } } return TCL_OK; } static int ObjectReadTrace(struct Property *propDefn, Tcl_Interp *interp) { if (!propDefn->tracing) { int code; propDefn->tracing = 1; code = Tcl_GlobalEvalObj(interp, propDefn->trace_read_script); propDefn->tracing = 0; if (code != TCL_OK) { Tcl_AddObjErrorInfo(interp, "\n (read trace on object property)", -1); return TCL_ERROR; } } return TCL_OK; } /* ---------------------------------------------------------------------- */ /* create an object - does not call constructor(s) */ static struct Object * BuildObject(Tcl_Interp *interp, struct Class *clsDefn, Tcl_Obj *creatorConstr) { static int uniqueNumber = 0; Tcl_Obj *num; Tcl_HashEntry *hent; int isNew; struct Object *objDefn = (struct Object *)Tcl_Alloc(sizeof(struct Object)); objDefn->self = Tcl_DuplicateObj(clsDefn->self); num = Tcl_NewIntObj(uniqueNumber++); Tcl_StringObjAppendObj(updInterp(objDefn->self), num); Tcl_DecrRefCount(num); /* This is where things get interesting. The idea behind doing all * this here is to avoid a costly search which a) would return a * value we already know, and b) would actually free because we * haven't completed that stage yet! */ if (!objDefn->self->bytes && objDefn->self->typePtr) { objDefn->self->typePtr->updateStringProc(updInterp(objDefn->self)); } if (objDefn->self->typePtr && objDefn->self->typePtr->freeIntRepProc) { objDefn->self->typePtr->freeIntRepProc(objDefn->self); } objDefn->self->internalRep.otherValuePtr = objDefn; objDefn->self->typePtr = &objectType; objDefn->myClass = clsDefn; Tcl_InitHashTable(&objDefn->properties, TCL_STRING_KEYS); Tcl_InitHashTable(&objDefn->references, TCL_ONE_WORD_KEYS); Tcl_CreateHashEntry(&objDefn->references, (char *)objDefn->self, &isNew); objDefn->built_with_constr = creatorConstr; objDefn->token = Tcl_CreateObjCommand(interp, objDefn->self->bytes, objDefn->self->length, ObjImplCmd, objDefn, DelObjCmd); hent = Tcl_CreateHashEntry(&clsDefn->objects, objDefn->self->bytes, &isNew); Tcl_SetHashValue(hent, objDefn); return objDefn; } /* The implementation of a class - see documentation elsewhere */ static int ClassImplCmd(clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj **objv; { struct Class *clsDefn = clientData; if (objc<2) { /* Default body-less constructor */ struct Object *objDefn; if (clsDefn->virtual) { AppendResult(interp, aSTR("class \""), aOBJ(objv[0]), aSTR("\" is virtual"), aEND); return TCL_ERROR; } objDefn = BuildObject(interp, clsDefn, Tcl_NewObj()); Tcl_IncrRefCount(objDefn->self); Tcl_SetObjResult(interp, objDefn->self); return TCL_OK; } else if (DereferenceP(interp, objv[1])) { /* Property access */ if (objc<3) { AppendResult(interp, aSTR("wrong # args: usage \""), aOBJ(objv[0]), aSTR(" -> propName ?operation ...?\""), aEND); return TCL_ERROR; } else { Tcl_HashEntry *hent = FindHashEntry(updInterp(&clsDefn->properties), objv[2]); struct Property *propDefn; if (objc==3) { if (!hent) { unknownProperty: AppendResult(interp, aSTR("unknown property \""), aOBJ(objv[2]), aSTR("\" for class \""), aOBJ(objv[0]), aSTR("\""), aEND); return TCL_ERROR; } propDefn = Tcl_GetHashValue(hent); /* Read a property */ Tcl_Preserve(propDefn); if (ClassReadTrace(propDefn, interp) == TCL_OK) { Tcl_SetObjResult(interp, propDefn->contents); Tcl_IncrRefCount(propDefn->contents); Tcl_Release(propDefn); return TCL_OK; } else { Tcl_Release(propDefn); return TCL_ERROR; } } else { /* Do something elaborate to a property */ int len,i; long accumulator,addValue; char *subcmd = Tcl_GetStringFromObj(updInterp(objv[3]), &len); Tcl_Obj *tmp; switch (subcmd[0]) { case '=': if (!hent) goto unknownProperty; /* You cannot create new * properties in a class at * all... */ propDefn = Tcl_GetHashValue(hent); if (len!=1) goto badPropSubcmd; /* Write a property */ if (objc!=5) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" -> "), aOBJ(objv[2]), aSTR(" = value\""), aEND); return TCL_ERROR; } if (propDefn->kind == PROPERTY_OBJECT) { AppendResult(interp, aSTR("property \""), aOBJ(objv[2]), aSTR("\" is not writable in class \""), aOBJ(objv[0]), aSTR("\""), aEND); return TCL_ERROR; } tmp = propDefn->contents; Tcl_IncrRefCount(objv[4]); propDefn->contents = objv[4]; Tcl_Preserve(propDefn); if (ClassWriteTrace(propDefn, interp) != TCL_OK) { Tcl_DecrRefCount(objv[4]); propDefn->contents = tmp; Tcl_Release(propDefn); return TCL_ERROR; } Tcl_IncrRefCount(objv[0]); propDefn->writer = objv[0]; Tcl_DecrRefCount(tmp); Tcl_SetObjResult(interp, propDefn->contents); Tcl_Release(propDefn); return TCL_OK; case 'a': if (!hent) goto unknownProperty; propDefn = Tcl_GetHashValue(hent); if (strncmp("append",subcmd,len)) goto badPropSubcmd; /* Append to a property */ if (propDefn->kind == PROPERTY_OBJECT) { AppendResult(interp, aSTR("property \""), aOBJ(objv[2]), aSTR("\" is not writable in class \""), aOBJ(objv[0]), aSTR("\""), aEND); return TCL_ERROR; } Tcl_Preserve(propDefn); if (ClassReadTrace(propDefn, interp) != TCL_OK) { Tcl_Release(propDefn); return TCL_ERROR; } tmp = propDefn->contents; propDefn->contents = Tcl_DuplicateObj(tmp); for (i=4 ; icontents), objv[i]); } if (ClassWriteTrace(propDefn, interp) != TCL_OK) { Tcl_DecrRefCount(propDefn->contents); propDefn->contents = tmp; Tcl_Release(propDefn); return TCL_ERROR; } Tcl_IncrRefCount(objv[0]); propDefn->writer = objv[0]; Tcl_DecrRefCount(tmp); Tcl_IncrRefCount(propDefn->contents); Tcl_SetObjResult(interp, propDefn->contents); Tcl_Release(propDefn); return TCL_OK; case 'e': if (strncmp("exists",subcmd,len)) goto badPropSubcmd; if (objc!=4) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" -> "), aOBJ(objv[2]), aSTR(" exists\""), aEND); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(hent!=NULL)); return TCL_OK; case 'i': if (!hent) goto unknownProperty; propDefn = Tcl_GetHashValue(hent); if (strncmp("increment",subcmd,len)) goto badPropSubcmd; /* Add to a property */ if (propDefn->kind == PROPERTY_OBJECT) { AppendResult(interp, aSTR("property \""), aOBJ(objv[2]), aSTR("\" is not writable in class \""), aOBJ(objv[0]), aSTR("\""), aEND); return TCL_ERROR; } Tcl_Preserve(propDefn); if (ClassReadTrace(propDefn, interp) != TCL_OK) { Tcl_Release(propDefn); return TCL_ERROR; } accumulator = addValue = 0; if (Tcl_GetIntFromObj(interp, propDefn->contents, &accumulator) != TCL_OK) { Tcl_Release(propDefn); return TCL_ERROR; } for (i=4 ; icontents; propDefn->contents = Tcl_NewIntObj(accumulator); if (ClassWriteTrace(propDefn, interp) != TCL_OK) { Tcl_DecrRefCount(propDefn->contents); propDefn->contents = tmp; Tcl_Release(propDefn); return TCL_ERROR; } Tcl_IncrRefCount(objv[0]); propDefn->writer = objv[0]; Tcl_DecrRefCount(tmp); Tcl_IncrRefCount(propDefn->contents); Tcl_SetObjResult(interp, propDefn->contents); Tcl_Release(propDefn); return TCL_OK; case 'l': if (!hent) goto unknownProperty; propDefn = Tcl_GetHashValue(hent); if (strncmp("lappend",subcmd,len)) goto badPropSubcmd; /* Append list items to a property */ if (propDefn->kind == PROPERTY_OBJECT) { AppendResult(interp, aSTR("property \""), aOBJ(objv[2]), aSTR("\" is not writable in class \""), aOBJ(objv[0]), aSTR("\""), aEND); return TCL_ERROR; } Tcl_Preserve(propDefn); if (ClassReadTrace(propDefn, interp) != TCL_OK) { Tcl_Release(propDefn); return TCL_ERROR; } tmp = propDefn->contents; propDefn->contents = Tcl_DuplicateObj(tmp); for (i=4 ; icontents, objv[i]) != TCL_OK) { Tcl_DecrRefCount(propDefn->contents); propDefn->contents = tmp; Tcl_Release(propDefn); return TCL_ERROR; } } if (ClassWriteTrace(propDefn, interp) != TCL_OK) { Tcl_DecrRefCount(propDefn->contents); propDefn->contents = tmp; Tcl_Release(propDefn); return TCL_ERROR; } Tcl_IncrRefCount(objv[0]); propDefn->writer = objv[0]; Tcl_DecrRefCount(tmp); Tcl_IncrRefCount(propDefn->contents); Tcl_SetObjResult(interp, propDefn->contents); Tcl_Release(propDefn); return TCL_OK; case 't': if (!hent) goto unknownProperty; propDefn = Tcl_GetHashValue(hent); if (strncmp("trace",subcmd,len)) goto badPropSubcmd; /* Set/query a trace a property */ if (objc<5 || objc>6) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" -> "), aOBJ(objv[2]), aSTR(" trace read/write ?script?\""), aEND); return TCL_ERROR; } subcmd = Tcl_GetStringFromObj(updInterp(objv[4]), &len); switch (subcmd[0]) { case 'r': if (strncmp("read",subcmd,len)) goto badPropTraceSubcmd; if (objc==6) { Tcl_DecrRefCount(propDefn->trace_read_script); propDefn->trace_read_script = objv[5]; } Tcl_IncrRefCount(propDefn->trace_read_script); Tcl_SetObjResult(interp, propDefn->trace_read_script); return TCL_OK; case 'w': if (strncmp("write",subcmd,len)) goto badPropTraceSubcmd; if (objc==6) { Tcl_DecrRefCount(propDefn->trace_write_script); propDefn->trace_write_script = objv[5]; } Tcl_IncrRefCount(propDefn->trace_write_script); Tcl_SetObjResult(interp, propDefn->trace_write_script); return TCL_OK; default: badPropTraceSubcmd: AppendResult(interp, aSTR("unknown property trace subcommand \""), aOBJ(objv[4]), aSTR("\": should be read or write"), aEND); return TCL_ERROR; } case 'u': if (!hent) goto unknownProperty; if (strncmp("unset",subcmd,len)) goto badPropSubcmd; if (objc!=4) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" -> "), aOBJ(objv[2]), aSTR(" unset\""), aEND); } propDefn = Tcl_GetHashValue(hent); switch (propDefn->kind) { case PROPERTY_CLASS: Tcl_EventuallyFree(propDefn, DelPropForReal); Tcl_DeleteHashEntry(hent); return TCL_OK; case PROPERTY_SHARED: tmp = propDefn->contents; propDefn->contents = Tcl_NewObj(); Tcl_Preserve(propDefn); if (ClassWriteTrace(propDefn, interp) != TCL_OK) { Tcl_DecrRefCount(propDefn->contents); propDefn->contents = tmp; Tcl_Release(propDefn); return TCL_ERROR; } Tcl_IncrRefCount(objv[0]); propDefn->writer = objv[0]; Tcl_DecrRefCount(tmp); Tcl_Release(propDefn); return TCL_OK; case PROPERTY_OBJECT: default: AppendResult(interp, aSTR("property \""), aOBJ(objv[2]), aSTR("\" cannot be deleted from class \""), aOBJ(objv[0]), aSTR("\""), aEND); return TCL_ERROR; } default: badPropSubcmd: AppendResult(interp, aSTR("unknown property access subcommand \""), aOBJ(objv[3]), aSTR("\": should be one of =, append, "), aSTR("exists, incr, lappend, trace or unset"), aEND); return TCL_ERROR; } } } } else { /* Method call */ Tcl_HashEntry *hent = FindHashEntry(updInterp(&clsDefn->methods), objv[1]); if (!hent) { AppendResult(interp, aSTR("unknown method \""), aOBJ(objv[1]), aSTR("\" for class \""), aOBJ(objv[0]), aSTR("\""), aEND); return TCL_ERROR; } else { struct Method *mthdDefn = Tcl_GetHashValue(hent); struct Object *objDefn; int code; switch (mthdDefn->kind) { case METHOD_CONSTRUCTOR: if (clsDefn->virtual) { AppendResult(interp, aSTR("class \""), aOBJ(objv[0]), aSTR("\" is virtual"), aEND); return TCL_ERROR; } Tcl_IncrRefCount(objv[1]); objDefn = BuildObject(interp, clsDefn, objv[1]); Tcl_Preserve(objDefn); if (MethodCall(interp, mthdDefn->commandName, objDefn->self, objc-2, objv+2) != TCL_OK) { Tcl_Obj *result = Tcl_GetObjResult(interp); Tcl_Obj *vName = Tcl_NewStringObj("errorInfo", -1); Tcl_Obj *errorInfo = Tcl_ObjGetVar2(interp, vName, NULL, TCL_GLOBAL_ONLY); int len; char *msg = Tcl_GetStringFromObj(updInterp(errorInfo), &len); Tcl_DecrRefCount(vName); Tcl_IncrRefCount(result); Tcl_DeleteCommand(interp, Tcl_GetCommandName(interp, objDefn->token)); Tcl_Release(objDefn); Tcl_ResetObjResult(interp); Tcl_AddObjErrorInfo(interp, msg, len); Tcl_AddObjErrorInfo(interp, "\n (during constructor call)", -1); Tcl_DecrRefCount(errorInfo); Tcl_SetObjResult(interp, result); return TCL_ERROR; } Tcl_IncrRefCount(objDefn->self); Tcl_SetObjResult(interp, objDefn->self); Tcl_Release(objDefn); return TCL_OK; case METHOD_CLASS: case METHOD_SHARED: code = MethodCall(interp, mthdDefn->commandName, clsDefn->self, objc-2, objv+2); if (code != TCL_OK) { Tcl_AddObjErrorInfo(interp, "\n (during class method call)", -1); } return code; case METHOD_OBJECT: default: /* Shouldn't happen */ AppendResult(interp, aSTR("method \""), aOBJ(objv[1]), aSTR("\" is not legally callable for class \""), aOBJ(clsDefn->self), aSTR("\""), aEND); return TCL_ERROR; } } } } /* ---------------------------------------------------------------------- */ /* Read an object's property, passing back info to make writing the * property back efficient */ static int ReadObjectProp(interp, objDefn, propName, contentsPtr, defaulted, hentPtr) Tcl_Interp *interp; struct Object *objDefn; Tcl_Obj *propName; Tcl_Obj **contentsPtr; int *defaulted; Tcl_HashEntry **hentPtr; { Tcl_HashEntry *hent = FindHashEntry(updInterp(&objDefn->properties), propName); if (hent) { struct Property *propDefn = Tcl_GetHashValue(hent); Tcl_Preserve(propDefn); if (ObjectReadTrace(propDefn, interp) != TCL_OK) { Tcl_Release(propDefn); return TCL_ERROR; } *hentPtr = hent; Tcl_IncrRefCount(propDefn->contents); *contentsPtr = propDefn->contents; *defaulted = 0; Tcl_Release(propDefn); return TCL_OK; } hent = FindHashEntry(updInterp(&objDefn->myClass->properties), propName); if (hent) { struct Property *propDefn = Tcl_GetHashValue(hent); switch (propDefn->kind) { case PROPERTY_SHARED: case PROPERTY_OBJECT: Tcl_Preserve(propDefn); if (ClassReadTrace(propDefn, interp) != TCL_OK) { Tcl_Release(propDefn); return TCL_ERROR; } *hentPtr = hent; Tcl_IncrRefCount(propDefn->contents); *contentsPtr = propDefn->contents; *defaulted = (propDefn->kind == PROPERTY_OBJECT); Tcl_Release(propDefn); return TCL_OK; case PROPERTY_CLASS: default: AppendResult(interp, aSTR("property \""), aOBJ(propName), aSTR("\" is unreadable in object \""), aOBJ(objDefn->self), aSTR("\""), aEND); return TCL_ERROR; } } AppendResult(interp, aSTR("unknown property \""), aOBJ(propName), aSTR("\" for object \""), aOBJ(objDefn->self), aSTR("\""), aEND); return TCL_ERROR; } /* Write an object's property. Uses info from ReadObjectProp() and * returns a reference to the new property contents (which might not * be what is expected due to traces) with the reference count * incremented */ static int WriteObjectProp(interp, objDefn, propName, contents, defaulted, hent, afterContents) Tcl_Interp *interp; struct Object *objDefn; Tcl_Obj *propName; Tcl_Obj *contents; int defaulted; Tcl_HashEntry *hent; Tcl_Obj **afterContents; { if (hent) { if (defaulted) { /* We have a read-only property in the class, but we can create * a writable property in the object with the same name. Do it! */ struct Property *oldP = Tcl_GetHashValue(hent); struct Property *propDefn = (struct Property *) Tcl_Alloc(sizeof(struct Property)); hent = CreateHashEntry(updInterp(&objDefn->properties), propName); Tcl_SetHashValue(hent, propDefn); propDefn->kind = PROPERTY_OBJECT; propDefn->name = oldP->name; Tcl_IncrRefCount(propDefn->name); propDefn->contents = contents; propDefn->tracing = 0; propDefn->trace_write_script = Tcl_NewObj(); propDefn->trace_read_script = Tcl_NewObj(); propDefn->writer = objDefn->self; Tcl_IncrRefCount(objDefn->self); Tcl_IncrRefCount(contents); *afterContents = contents; /* There are no traces set, so there's nothing to call here! */ return TCL_OK; } else { /* We have a writable property - write it! */ struct Property *propDefn = Tcl_GetHashValue(hent); Tcl_Obj *tmp = propDefn->contents; propDefn->contents = contents; Tcl_Preserve(objDefn); Tcl_Preserve(propDefn); if (ObjectWriteTrace(propDefn, interp) != TCL_OK) { propDefn->contents = tmp; Tcl_Release(propDefn); Tcl_Release(objDefn); return TCL_ERROR; } Tcl_IncrRefCount(objDefn->self); propDefn->writer = objDefn->self; Tcl_DecrRefCount(tmp); *afterContents = propDefn->contents; Tcl_IncrRefCount(propDefn->contents); Tcl_Release(propDefn); Tcl_Release(objDefn); return TCL_OK; } } else { /* This is an all-new property that we are writing, but we must * check that we aren't actually writing over what should be a * class-only variable. This is where things get interesting... */ struct Property *propDefn, *classP; Tcl_Obj *tmp; hent = FindHashEntry(updInterp(&objDefn->myClass->properties), propName); if (!hent) { /* There is definitely no impediment, so roll with this */ createAProperty: propDefn = (struct Property *)Tcl_Alloc(sizeof(struct Property)); hent = CreateHashEntry(updInterp(&objDefn->properties), propName); Tcl_SetHashValue(hent, propDefn); propDefn->kind = PROPERTY_OBJECT; propDefn->name = propName; Tcl_IncrRefCount(propName); propDefn->contents = contents; propDefn->tracing = 0; propDefn->trace_write_script = Tcl_NewObj(); propDefn->trace_read_script = Tcl_NewObj(); propDefn->writer = objDefn->self; Tcl_IncrRefCount(objDefn->self); *afterContents = contents; Tcl_IncrRefCount(contents); return TCL_OK; } /* Hmm. It exists in the class. Check what to do */ classP = Tcl_GetHashValue(hent); switch (classP->kind) { case PROPERTY_SHARED: /* Ah, we need to update the class property... */ tmp = classP->contents; classP->contents = contents; Tcl_Preserve(objDefn); Tcl_Preserve(classP); if (ObjectWriteTrace(classP, interp) != TCL_OK) { classP->contents = tmp; Tcl_Release(classP); Tcl_Release(objDefn); return TCL_ERROR; } Tcl_IncrRefCount(objDefn->self); classP->writer = objDefn->self; Tcl_DecrRefCount(tmp); *afterContents = classP->contents; Tcl_IncrRefCount(classP->contents); Tcl_Release(classP); Tcl_Release(objDefn); return TCL_OK; case PROPERTY_OBJECT: /* We need to create the property in the object, but luckily * we've got the code to do this just above. */ goto createAProperty; case PROPERTY_CLASS: default: AppendResult(interp, aSTR("property \""), aOBJ(propName), aSTR("\" is unwritable in object \""), aOBJ(objDefn->self), aSTR("\""), aEND); return TCL_ERROR; } } } /* Implementation of an object - see documentation elsewhere */ static int ObjImplCmd(clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj **objv; { struct Object *objDefn = clientData; if (objc<2) { /* Default - return the class of the object */ Tcl_IncrRefCount(objDefn->myClass->self); Tcl_SetObjResult(interp, objDefn->myClass->self); return TCL_OK; } else if (DereferenceP(interp, objv[1])) { /* Property access */ if (objc<3) { AppendResult(interp, aSTR("wrong # args: usage \""), aOBJ(objv[0]), aSTR(" -> propName ?operation ...?\""), aEND); return TCL_ERROR; } else { Tcl_HashEntry *hent; int defaulted; Tcl_Obj *value; if (objc==3) { /* Read a property */ if (ReadObjectProp(interp, objDefn, objv[2], &value, &defaulted, &hent) != TCL_OK) { return TCL_ERROR; } Tcl_IncrRefCount(value); Tcl_SetObjResult(interp, value); return TCL_OK; } else { /* Do something elaborate to a property */ int len,i; long accumulator,addValue; char *subcmd = Tcl_GetStringFromObj(updInterp(objv[3]), &len); switch (subcmd[0]) { case '=': if (len!=1) goto badPropSubcmd; /* Write a property */ if (objc!=5) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" -> "), aOBJ(objv[2]), aSTR(" = value\""), aEND); return TCL_ERROR; } if (WriteObjectProp(interp, objDefn, objv[2], objv[4], 0, FindHashEntry(updInterp(&objDefn->properties), objv[4]), &value) != TCL_OK) { return TCL_ERROR; } Tcl_SetObjResult(interp, value); return TCL_OK; case 'a': if (strncmp("append",subcmd,len)) goto badPropSubcmd; /* Append strings to a property */ Tcl_Preserve(objDefn); if (ReadObjectProp(interp, objDefn, objv[2], &value, &defaulted, &hent) != TCL_OK) { Tcl_Release(objDefn); return TCL_ERROR; } value = Tcl_DuplicateObj(value); for (i=4 ; i "), aOBJ(objv[2]), aSTR(" exists\""), aEND); return TCL_ERROR; } hent = FindHashEntry(updInterp(&objDefn->properties), objv[2]); if (!hent) { hent = FindHashEntry(updInterp(&objDefn->myClass->properties), objv[2]); if (hent) { struct Property *propDefn = Tcl_GetHashValue(hent); if (propDefn->kind == PROPERTY_CLASS) hent = NULL; /* Reading this would be an error! */ } } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(hent!=NULL)); return TCL_OK; case 'i': if (strncmp("increment",subcmd,len)) goto badPropSubcmd; /* Add to a property */ Tcl_Preserve(objDefn); if (ReadObjectProp(interp, objDefn, objv[2], &value, &defaulted, &hent) != TCL_OK) { Tcl_Release(objDefn); return TCL_ERROR; } accumulator = addValue = 0; if (Tcl_GetIntFromObj(interp, value, &accumulator) != TCL_OK) { Tcl_Release(objDefn); return TCL_ERROR; } for (i=4 ; i6) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" -> "), aOBJ(objv[2]), aSTR(" trace read/write ?script?\""), aEND); return TCL_ERROR; } else { struct Property *propDefn; Tcl_Preserve(objDefn); hent = FindHashEntry(updInterp(&objDefn->properties), objv[2]); if (!hent) { hent = FindHashEntry(updInterp(&objDefn->myClass->properties), objv[2]); if (hent) { propDefn = Tcl_GetHashValue(hent); switch (propDefn->kind) { case PROPERTY_OBJECT: /* Duplicate the property into the object */ WriteObjectProp(interp, objDefn, objv[2], propDefn->contents, 1, hent, &value); /* Don't need the extra ref */ Tcl_DecrRefCount(value); hent = FindHashEntry(updInterp(&objDefn->properties), objv[2]); case PROPERTY_SHARED: break; case PROPERTY_CLASS: default: /* Reading this would be an error! */ goto unknownProperty; } } else { unknownProperty: AppendResult(interp, aSTR("unknown property \""), aOBJ(objv[2]), aSTR("\" for object \""), aOBJ(objv[0]), aSTR("\""), aEND); Tcl_Release(objDefn); return TCL_ERROR; } } propDefn = Tcl_GetHashValue(hent); subcmd = Tcl_GetStringFromObj(updInterp(objv[4]), &len); switch (subcmd[0]) { case 'r': if (strncmp("read",subcmd,len)) goto badPropTraceSubcmd; if (objc==6) { Tcl_DecrRefCount(propDefn->trace_read_script); propDefn->trace_read_script = objv[5]; } Tcl_IncrRefCount(propDefn->trace_read_script); Tcl_SetObjResult(interp, propDefn->trace_read_script); Tcl_Release(objDefn); return TCL_OK; case 'w': if (strncmp("write",subcmd,len)) goto badPropTraceSubcmd; if (objc==6) { Tcl_DecrRefCount(propDefn->trace_write_script); propDefn->trace_write_script = objv[5]; } Tcl_IncrRefCount(propDefn->trace_write_script); Tcl_SetObjResult(interp, propDefn->trace_write_script); Tcl_Release(objDefn); return TCL_OK; default: badPropTraceSubcmd: AppendResult(interp, aSTR("unknown property trace subcommand \""), aOBJ(objv[4]), aSTR("\": should be read or write"), aEND); Tcl_Release(objDefn); return TCL_ERROR; } } case 'u': if (strncmp("unset",subcmd,len)) goto badPropSubcmd; /* Delete a property */ if (objc!=4) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" -> "), aOBJ(objv[2]), aSTR(" unset\""), aEND); } else { struct Property *propDefn; hent = FindHashEntry(updInterp(&objDefn->properties), objv[2]); if (hent) { propDefn = Tcl_GetHashValue(hent); Tcl_EventuallyFree(propDefn, DelPropForReal); Tcl_DeleteHashEntry(hent); return TCL_OK; } else { hent = FindHashEntry(updInterp(&objDefn->myClass->properties), objv[2]); if (hent) { propDefn = Tcl_GetHashValue(hent); if (propDefn->kind == PROPERTY_SHARED) { /* Set to the empty string */ Tcl_Preserve(objDefn); if (WriteObjectProp(interp, objDefn, objv[2], Tcl_NewObj(), 0, hent, &value) != TCL_OK) { Tcl_Release(objDefn); return TCL_ERROR; } Tcl_DecrRefCount(value); Tcl_Release(objDefn); return TCL_OK; } } } AppendResult(interp, aSTR("unknown property \""), aOBJ(objv[2]), aSTR("\" for object \""), aOBJ(objv[0]), aSTR("\""), aEND); return TCL_ERROR; } default: badPropSubcmd: AppendResult(interp, aSTR("unknown property access subcommand \""), aOBJ(objv[3]), aSTR("\": should be one of =, append, "), aSTR("exists, incr, lappend, trace or unset"), aEND); return TCL_ERROR; } } } } else { /* Method call */ Tcl_HashEntry *hent = FindHashEntry(updInterp(&objDefn->myClass->methods), objv[1]); if (!hent) { AppendResult(interp, aSTR("unknown method \""), aOBJ(objv[1]), aSTR("\" for object \""), aOBJ(objv[0]), aSTR("\""), aEND); return TCL_ERROR; } else { struct Method *mthdDefn = Tcl_GetHashValue(hent); int code; switch (mthdDefn->kind) { case METHOD_OBJECT: case METHOD_SHARED: code = MethodCall(interp, mthdDefn->commandName, objDefn->self, objc-2, objv+2); if (code != TCL_OK) { Tcl_AddObjErrorInfo(interp, "\n (during object method call)", -1); } return code; case METHOD_CONSTRUCTOR: case METHOD_CLASS: default: /* Shouldn't happen */ AppendResult(interp, aSTR("method \""), aOBJ(objv[1]), aSTR("\" is not legally callable for object \""), aOBJ(objDefn->self), aSTR("\""), aEND); return TCL_ERROR; } } } } /* ---------------------------------------------------------------------- */ /* Parses a definition list, adding bits to the class being created */ static int ClassAddDefinition(interp, newClass, defList, classes) Tcl_Interp *interp; struct Class *newClass; Tcl_Obj *defList; Tcl_HashTable *classes; { Tcl_HashSearch hsearch; Tcl_HashEntry *hent; int i,deflen; int methkind = METHOD_SHARED; int propkind = PROPERTY_OBJECT; if (Tcl_ListObjLength(interp, defList, &deflen) != TCL_OK) { return TCL_ERROR; } for (i=0 ; i=deflen) { AppendResult(interp, aSTR("bad inherit declaration: should be \""), aOBJ(defnObj), aSTR(" className\""), aEND); return TCL_ERROR; } Tcl_ListObjIndex(interp, defList, i+1, &defnObj); hent = FindHashEntry(updInterp(classes), defnObj); if (!hent) { AppendResult(interp, aSTR("unknown class \""), aOBJ(defnObj), aSTR("\""), aEND); return TCL_ERROR; } Tcl_ListObjAppendElement(interp, newClass->parents, defnObj); clsDefn = Tcl_GetHashValue(hent); /* Duplicate all the methods */ hent = Tcl_FirstHashEntry(&clsDefn->methods, &hsearch); for (;hent; hent=Tcl_NextHashEntry(&hsearch)) { Tcl_HashEntry *nhent; int isNew; struct Method *parentM = Tcl_GetHashValue(hent); char *key = Tcl_GetHashKey(&clsDefn->methods, hent); struct Method *ourM = (struct Method *) Tcl_Alloc(sizeof(struct Method)); ourM->kind = parentM->kind; ourM->name = parentM->name; ourM->commandName = parentM->commandName; Tcl_IncrRefCount(ourM->name); Tcl_IncrRefCount(ourM->commandName); nhent = Tcl_CreateHashEntry(&newClass->methods, key, &isNew); if (!isNew) { struct Method *oldM = Tcl_GetHashValue(hent); Tcl_DecrRefCount(oldM->name); Tcl_DecrRefCount(oldM->commandName); Tcl_Free((char *)oldM); } Tcl_SetHashValue(hent,ourM); } /* Duplicate all the properties */ hent = Tcl_FirstHashEntry(&clsDefn->properties, &hsearch); for (;hent; hent=Tcl_NextHashEntry(&hsearch)) { Tcl_HashEntry *nhent; int isNew; struct Property *parentP = Tcl_GetHashValue(hent); char *key = Tcl_GetHashKey(&clsDefn->properties, hent); struct Property *ourP = (struct Property *) Tcl_Alloc(sizeof(struct Property)); ourP->kind = parentP->kind; ourP->name = parentP->name; ourP->contents = parentP->contents; ourP->tracing = 0; ourP->trace_write_script = Tcl_NewObj(); ourP->trace_read_script = Tcl_NewObj(); ourP->writer = Tcl_NewObj(); /* The other parts are not copied anyway... */ Tcl_IncrRefCount(ourP->name); Tcl_IncrRefCount(ourP->contents); nhent = Tcl_CreateHashEntry(&newClass->properties, key, &isNew); if (!isNew) { struct Property *oldP = Tcl_GetHashValue(hent); Tcl_DecrRefCount(oldP->name); Tcl_DecrRefCount(oldP->contents); Tcl_DecrRefCount(oldP->trace_write_script); Tcl_DecrRefCount(oldP->trace_read_script); Tcl_DecrRefCount(oldP->writer); Tcl_Free((char *)oldP); } Tcl_SetHashValue(hent,ourP); } i++; break; case 'm': if (strncmp(defn,"method",slen)) goto badDefnItem; if (i+2>=deflen) { AppendResult(interp, aSTR("bad method declaration: should be \""), aOBJ(defnObj), aSTR(" methodName methodProcName\""), aEND); return TCL_ERROR; } mthdDefn = (struct Method *)Tcl_Alloc(sizeof(struct Method)); mthdDefn->kind = methkind; /* The next two array lookups shouldn't fail... */ Tcl_ListObjIndex(interp, defList, i+1, &mthdDefn->name); Tcl_ListObjIndex(interp, defList, i+2, &mthdDefn->commandName); Tcl_IncrRefCount(mthdDefn->name); Tcl_IncrRefCount(mthdDefn->commandName); defn = Tcl_GetStringFromObj(updInterp(mthdDefn->name), &slen); hent = Tcl_CreateHashEntry(&newClass->methods, defn, &slen); if (!slen) { struct Method *om = Tcl_GetHashValue(hent); Tcl_DecrRefCount(om->name); Tcl_DecrRefCount(om->commandName); Tcl_Free((char *)om); } Tcl_SetHashValue(hent,mthdDefn); i+=2; break; case 'o': if (strncmp(defn,"object:",slen)) goto badDefnItem; methkind = METHOD_OBJECT; propkind = PROPERTY_OBJECT; break; case 'p': if (strncmp(defn,"property",slen)) goto badDefnItem; if (i+2>=deflen) { AppendResult(interp, aSTR("bad property declaration: should be \""), aOBJ(defnObj), aSTR(" propertyName initialValue\""), aEND); return TCL_ERROR; } propDefn = (struct Property *)Tcl_Alloc(sizeof(struct Property)); propDefn->kind = propkind; /* The next two list operations shouldn't fail... */ Tcl_ListObjIndex(interp, defList, i+1, &propDefn->name); Tcl_ListObjIndex(interp, defList, i+2, &propDefn->contents); Tcl_IncrRefCount(propDefn->name); Tcl_IncrRefCount(propDefn->contents); propDefn->tracing = 0; propDefn->trace_write_script = Tcl_NewObj(); propDefn->trace_read_script = Tcl_NewObj(); propDefn->writer = Tcl_NewObj(); defn = Tcl_GetStringFromObj(updInterp(propDefn->name), &slen); hent = Tcl_CreateHashEntry(&newClass->properties, defn, &slen); if (!slen) { struct Property *op = Tcl_GetHashValue(hent); Tcl_DecrRefCount(op->name); Tcl_DecrRefCount(op->contents); Tcl_DecrRefCount(op->trace_write_script); Tcl_DecrRefCount(op->trace_read_script); Tcl_DecrRefCount(op->writer); Tcl_Free((char *)op); } Tcl_SetHashValue(hent,propDefn); i+=2; break; case 's': if (strncmp(defn,"shared:",slen)) goto badDefnItem; methkind = METHOD_SHARED; propkind = PROPERTY_SHARED; break; case 'v': if (strncmp(defn,"virtual",slen)) goto badDefnItem; newClass->virtual = 1; break; default: badDefnItem: AppendResult(interp, aSTR("unknown or ambiguous definition item \""), aOBJ(defnObj), aSTR("\": should be one of class:, " "constructor:, inherit, method, " "object:, property, shared: or " "virtual"), aEND); return TCL_ERROR; } } return TCL_OK; } /* Implementation of the class system command - see documentation elsewhere */ static int ClassCommand(clientData, interp, objc, objv) ClientData clientData; Tcl_Interp *interp; int objc; Tcl_Obj **objv; { Tcl_HashTable *classes = (Tcl_HashTable *)clientData; Tcl_HashSearch hsearch; Tcl_HashEntry *hent; int len; char *subcmd; register char chr; if (objc<2) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" command ?arg ...?\""), aEND); return TCL_ERROR; } subcmd = Tcl_GetStringFromObj(updInterp(objv[1]), &len); chr = subcmd[0]; if (chr=='d' && !strncmp(subcmd,"define",len)) { /* Define a new class! */ struct Class *newClass; int i; char *name; if (objc<4) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" define name deflist ?deflist ...?\""), aEND); return TCL_ERROR; } for (i=3 ; imethods, TCL_STRING_KEYS); Tcl_InitHashTable(&newClass->properties, TCL_STRING_KEYS); Tcl_InitHashTable(&newClass->objects, TCL_STRING_KEYS); newClass->parents = Tcl_NewListObj(0,NULL); newClass->creatorInterp = interp; for (i=3 ; iparents); /* Need to delete the hash tables properly */ Tcl_Free((char *)newClass); return TCL_ERROR; } } newClass->self = objv[2]; Tcl_IncrRefCount(objv[2]); name = Tcl_GetStringFromObj(updInterp(objv[2]), &len); newClass->classes = classes; newClass->token = Tcl_CreateObjCommand(interp, name, len, ClassImplCmd, newClass, DelClass); Tcl_SetHashValue(Tcl_CreateHashEntry(classes, name, &len), newClass); Tcl_SetObjResult(interp, newClass->self); return TCL_OK; } else if (chr=='e' && !strncmp(subcmd,"exists",len)) { /* Do we have a class name? */ if (objc!=3) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" exists name\""), aEND); return TCL_ERROR; } hent = FindHashEntry(updInterp(classes), objv[2]); Tcl_SetObjResult(interp, Tcl_NewIntObj(hent != NULL)); return TCL_OK; } else if (chr=='i' && !strncmp(subcmd,"info",len)) { /* Find something out about something specific */ struct Object *obj; struct Class *cls; int inObj; if (objc<3) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" info thing arg ?arg?\""), aEND); return TCL_ERROR; } subcmd = Tcl_GetStringFromObj(updInterp(objv[2]), &len); switch (subcmd[0]) { case 'c': if (strncmp(subcmd,"class",len)) goto unknownClassInfoThing; if (objc!=4) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" info class className\""), aEND); return TCL_ERROR; } hent = FindHashEntry(updInterp(classes), objv[3]); if (hent) { Tcl_Obj *ret = Tcl_NewListObj(0,NULL); cls = (struct Class *)Tcl_GetHashValue(hent); Tcl_ListObjAppendElement(interp, ret, Tcl_NewIntObj(cls->virtual)); Tcl_ListObjAppendElement(interp, ret, cls->parents); Tcl_SetObjResult(interp, ret); return TCL_OK; } else { AppendResult(interp, aSTR("unknown class \""), aOBJ(objv[3]), aSTR("\""), aEND); return TCL_ERROR; } case 'o': if (strncmp(subcmd,"object",len)) goto unknownClassInfoThing; if (objc!=4) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" info object objectName\""), aEND); return TCL_ERROR; } if (GetObject(interp, objv[3], classes, &obj) != TCL_OK) { return TCL_ERROR; } else { Tcl_Obj *ret = Tcl_NewListObj(0,NULL); Tcl_ListObjAppendElement(interp, ret, obj->myClass->self); Tcl_ListObjAppendElement(interp, ret, obj->built_with_constr); Tcl_SetObjResult(interp, ret); return TCL_OK; } case 'm': if (strncmp(subcmd,"method",len)) goto unknownClassInfoThing; if (objc!=5) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" info method classOrObject " "methodName\""), aEND); return TCL_ERROR; } hent = FindHashEntry(updInterp(classes), objv[3]); if (hent) { cls = (struct Class *)Tcl_GetHashValue(hent); inObj = 0; } else { if (GetObject(interp, objv[3], classes, &obj) != TCL_OK) { AppendResult(interp, aSTR("\""), aOBJ(objv[3]), aSTR("\" is neither a class or an object"), aEND); return TCL_ERROR; } cls = obj->myClass; inObj = 1; } hent = FindHashEntry(updInterp(&cls->methods), objv[4]); if (hent) { struct Method *mthdDefn = (struct Method *)Tcl_GetHashValue(hent); Tcl_Obj *ret; if ((inObj && (mthdDefn->kind==METHOD_CONSTRUCTOR|| mthdDefn->kind==METHOD_CLASS)) || (!inObj && (mthdDefn->kind==METHOD_OBJECT))) goto unknownMethodForInfo; ret = Tcl_NewListObj(0,NULL); switch (mthdDefn->kind) { case METHOD_CONSTRUCTOR: Tcl_ListObjAppendElement(interp, ret, Tcl_NewStringObj("constructor",-1)); break; case METHOD_CLASS: Tcl_ListObjAppendElement(interp, ret, Tcl_NewStringObj("class",-1)); break; case METHOD_OBJECT: Tcl_ListObjAppendElement(interp, ret, Tcl_NewStringObj("object",-1)); break; case METHOD_SHARED: Tcl_ListObjAppendElement(interp, ret, Tcl_NewStringObj("shared",-1)); break; default: Tcl_ListObjAppendElement(interp, ret, Tcl_NewStringObj("???",-1)); break; } Tcl_ListObjAppendElement(interp, ret, mthdDefn->commandName); Tcl_SetObjResult(interp, ret); return TCL_OK; } else { unknownMethodForInfo: AppendResult(interp, aSTR("unknown method \""), aOBJ(objv[4]), aSTR("\""), aEND); return TCL_ERROR; } case 'p': if (strncmp(subcmd,"property",len)) goto unknownClassInfoThing; if (objc!=5) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" info property classOrObject " "propertyName\""), aEND); return TCL_ERROR; } hent = FindHashEntry(updInterp(classes), objv[3]); if (hent) { cls = (struct Class *)Tcl_GetHashValue(hent); inObj = 0; hent = FindHashEntry(updInterp(&cls->properties), objv[4]); } else { if (GetObject(interp, objv[3], classes, &obj) != TCL_OK) { AppendResult(interp, aSTR("\""), aOBJ(objv[3]), aSTR("\" is neither a class or an object"), aEND); return TCL_ERROR; } inObj = 1; hent = FindHashEntry(updInterp(&obj->properties), objv[4]); } if (hent) { struct Property *propDefn = (struct Property *)Tcl_GetHashValue(hent); Tcl_Obj *ret; if (inObj && propDefn->kind==PROPERTY_CLASS) goto unknownPropertyForInfo; ret = Tcl_NewListObj(0,NULL); switch (propDefn->kind) { case PROPERTY_CLASS: Tcl_ListObjAppendElement(interp, ret, Tcl_NewStringObj("class",-1)); break; case PROPERTY_OBJECT: Tcl_ListObjAppendElement(interp, ret, Tcl_NewStringObj("object",-1)); break; case PROPERTY_SHARED: Tcl_ListObjAppendElement(interp, ret, Tcl_NewStringObj("shared",-1)); break; default: Tcl_ListObjAppendElement(interp, ret, Tcl_NewStringObj("???",-1)); break; } Tcl_ListObjAppendElement(interp, ret, propDefn->writer); Tcl_SetObjResult(interp, ret); return TCL_OK; } else { unknownPropertyForInfo: AppendResult(interp, aSTR("unknown property \""), aOBJ(objv[4]), aSTR("\""), aEND); return TCL_ERROR; } default: unknownClassInfoThing: AppendResult(interp, aSTR("unknown kind of thing \""), aOBJ(objv[2]), aSTR("\": should be one of class, method, object " "or property"), aEND); return TCL_ERROR; } } else if (chr=='l' && !strncmp(subcmd,"list",len)) { /* Lists of things */ Tcl_Obj *list; if (objc<3) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" list thing ?arg ...?\""), aEND); return TCL_ERROR; } subcmd = Tcl_GetStringFromObj(updInterp(objv[2]), &len); chr = subcmd[0]; if (chr=='c' && !strncmp(subcmd,"classes",len)) { int patlen; int namelen; char *pattern; switch (objc) { case 4: pattern = Tcl_GetStringFromObj(updInterp(objv[3]), &patlen); list = Tcl_NewListObj(0,NULL); hent = Tcl_FirstHashEntry(classes,&hsearch); for (;hent; hent=Tcl_NextHashEntry(&hsearch)) { Tcl_Obj *cls = ((struct Class *)Tcl_GetHashValue(hent))->self; if (Tcl_StringMatch(Tcl_GetStringFromObj(updInterp(cls), &namelen), pattern)) Tcl_ListObjAppendElement(interp, list, cls); } Tcl_SetObjResult(interp, list); return TCL_OK; case 3: list = Tcl_NewListObj(0,NULL); hent = Tcl_FirstHashEntry(classes,&hsearch); for (;hent; hent=Tcl_NextHashEntry(&hsearch)) { Tcl_ListObjAppendElement(interp, list, ((struct Class *) Tcl_GetHashValue(hent))->self); } Tcl_SetObjResult(interp, list); return TCL_OK; default: AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" list classes ?pattern?\""), aEND); return TCL_ERROR; } } else if (chr=='m' && !strncmp(subcmd,"methods",len)) { char *name; char *pattern; struct Class *cls; int inObj; switch (objc) { case 4: hent = FindHashEntry(updInterp(classes), objv[3]); if (hent) { cls = (struct Class *)Tcl_GetHashValue(hent); inObj = 0; } else { struct Object *obj; if (GetObject(interp, objv[3], classes, &obj) != TCL_OK) { AppendResult(interp, aSTR("\""), aOBJ(objv[3]), aSTR("\" is neither a class or an object"), aEND); return TCL_ERROR; } cls = obj->myClass; inObj = 1; } hent = Tcl_FirstHashEntry(&cls->methods, &hsearch); list = Tcl_NewListObj(0,NULL); for (;hent; hent=Tcl_NextHashEntry(&hsearch)) { struct Method *mthdDefn = (struct Method *)Tcl_GetHashValue(hent); if ((inObj && (mthdDefn->kind==METHOD_OBJECT || mthdDefn->kind==METHOD_SHARED)) || (!inObj && mthdDefn->kind!=METHOD_OBJECT)) Tcl_ListObjAppendElement(interp, list, mthdDefn->name); } Tcl_SetObjResult(interp, list); return TCL_OK; case 5: pattern = Tcl_GetStringFromObj(updInterp(objv[4]), &len); hent = FindHashEntry(updInterp(classes), objv[3]); if (hent) { cls = (struct Class *)Tcl_GetHashValue(hent); inObj = 0; } else { struct Object *obj; if (GetObject(interp, objv[3], classes, &obj) != TCL_OK) { AppendResult(interp, aSTR("\""), aOBJ(objv[3]), aSTR("\" is neither a class or an object"), aEND); return TCL_ERROR; } cls = obj->myClass; inObj = 1; } hent = Tcl_FirstHashEntry(&cls->methods, &hsearch); list = Tcl_NewListObj(0,NULL); for (;hent; hent=Tcl_NextHashEntry(&hsearch)) { struct Method *mthdDefn = (struct Method *)Tcl_GetHashValue(hent); if ((inObj && (mthdDefn->kind==2 || mthdDefn->kind==3)) || (!inObj && mthdDefn->kind!=2)) { name = Tcl_GetStringFromObj(updInterp(mthdDefn->name), &len); if (Tcl_StringMatch(name, pattern)) Tcl_ListObjAppendElement(interp, list, mthdDefn->name); } } Tcl_SetObjResult(interp, list); return TCL_OK; default: AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" list methods classOrObject ?pattern?\""), aEND); return TCL_ERROR; } } else if (chr=='o' && !strncmp(subcmd,"objects",len)) { int patlen; int namelen; char *pattern; struct Class *cls; switch (objc) { case 5: hent = FindHashEntry(updInterp(classes), objv[3]); if (hent) { cls = (struct Class *)Tcl_GetHashValue(hent); } else { AppendResult(interp, aSTR("unknown class \""), aOBJ(objv[3]), aSTR("\""), aEND); return TCL_ERROR; } pattern = Tcl_GetStringFromObj(updInterp(objv[4]), &patlen); list = Tcl_NewListObj(0,NULL); hent = Tcl_FirstHashEntry(&cls->objects,&hsearch); for (;hent; hent=Tcl_NextHashEntry(&hsearch)) { Tcl_Obj *obj = ((struct Object *)Tcl_GetHashValue(hent))->self; if (Tcl_StringMatch(Tcl_GetStringFromObj(updInterp(obj), &namelen), pattern)) Tcl_ListObjAppendElement(interp, list, obj); } Tcl_SetObjResult(interp, list); return TCL_OK; case 4: hent = FindHashEntry(updInterp(classes), objv[3]); if (hent) { cls = (struct Class *)Tcl_GetHashValue(hent); } else { AppendResult(interp, aSTR("unknown class \""), aOBJ(objv[3]), aSTR("\""), aEND); return TCL_ERROR; } list = Tcl_NewListObj(0,NULL); hent = Tcl_FirstHashEntry(&cls->objects,&hsearch); for (;hent; hent=Tcl_NextHashEntry(&hsearch)) { Tcl_ListObjAppendElement(interp,list,((struct Object *) Tcl_GetHashValue(hent))->self); } Tcl_SetObjResult(interp, list); return TCL_OK; default: AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" list objects class ?pattern?\""), aEND); return TCL_ERROR; } } else if (chr=='p' && !strncmp(subcmd,"properties",len)) { char *name; char *pattern; struct Class *cls; int inObj; switch (objc) { case 4: hent = FindHashEntry(updInterp(classes), objv[3]); if (hent) { cls = (struct Class *)Tcl_GetHashValue(hent); inObj = 0; hent = Tcl_FirstHashEntry(&cls->properties, &hsearch); } else { struct Object *obj; if (GetObject(interp, objv[3], classes, &obj) != TCL_OK) { AppendResult(interp, aSTR("\""), aOBJ(objv[3]), aSTR("\" is neither a class or an object"), aEND); return TCL_ERROR; } cls = obj->myClass; inObj = 1; hent = Tcl_FirstHashEntry(&obj->properties, &hsearch); } list = Tcl_NewListObj(0,NULL); for (;hent; hent=Tcl_NextHashEntry(&hsearch)) { struct Property *propDefn = Tcl_GetHashValue(hent); if (!inObj || propDefn->kind!=0) Tcl_ListObjAppendElement(interp, list, propDefn->name); } Tcl_SetObjResult(interp, list); return TCL_OK; case 5: pattern = Tcl_GetStringFromObj(updInterp(objv[4]), &len); hent = FindHashEntry(updInterp(classes), objv[3]); if (hent) { cls = (struct Class *)Tcl_GetHashValue(hent); inObj = 0; hent = Tcl_FirstHashEntry(&cls->properties, &hsearch); } else { struct Object *obj; if (GetObject(interp, objv[3], classes, &obj) != TCL_OK) { AppendResult(interp, aSTR("\""), aOBJ(objv[3]), aSTR("\" is neither a class or an object"), aEND); return TCL_ERROR; } cls = obj->myClass; inObj = 1; hent = Tcl_FirstHashEntry(&obj->properties, &hsearch); } list = Tcl_NewListObj(0,NULL); for (;hent; hent=Tcl_NextHashEntry(&hsearch)) { struct Property *propDefn = Tcl_GetHashValue(hent); if (!inObj || propDefn->kind!=0) { name = Tcl_GetStringFromObj(updInterp(propDefn->name), &len); if (Tcl_StringMatch(name, pattern)) Tcl_ListObjAppendElement(interp, list, propDefn->name); } } Tcl_SetObjResult(interp, list); return TCL_OK; default: AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[0]), aSTR(" list methods classOrObject ?pattern?\""), aEND); return TCL_ERROR; } } else { AppendResult(interp, aSTR("unknown kind of thing \""), aOBJ(objv[2]), aSTR("\": should be one of classes, methods, objects " "or properties"), aEND); return TCL_ERROR; } } else if (chr=='o' && !strncmp(subcmd,"of",len)) { /* What is the class of an object? */ struct Object *objDefn; if (objc!=3) { AppendResult(interp, aSTR("wrong # args: should be \""), aOBJ(objv[1]), aSTR(" of object\""), aEND); return TCL_ERROR; } if (GetObject(interp, objv[2], classes, &objDefn) != TCL_OK) { return TCL_ERROR; } Tcl_SetObjResult(interp, objDefn->myClass->self); return TCL_OK; } else { AppendResult(interp, aSTR("unknown subcommand \""), aOBJ(objv[1]), aSTR("\": should be one of define, exists, info, list or of"), aEND); return TCL_ERROR; } } /* ---------------------------------------------------------------------- */ /* Deletion commands. * * Everything with the 'ForReal' suffix is called as a of result * Tcl_EventuallyFree (and is thus part of something which has been * Tcl_Preserve-d), whereas the other deletion commands are called as * part of deleting Tcl commands */ static void DelPropForReal(char *clientData) { struct Property *propDefn = (struct Property *)clientData; Tcl_DecrRefCount(propDefn->name); Tcl_DecrRefCount(propDefn->contents); Tcl_DecrRefCount(propDefn->writer); Tcl_DecrRefCount(propDefn->trace_write_script); Tcl_DecrRefCount(propDefn->trace_read_script); Tcl_Free((char *)propDefn); } static void DelObjForReal(char *clientData) { struct Object *objDefn = (struct Object *)clientData; Tcl_HashEntry *hent; Tcl_HashSearch hsearch; hent = Tcl_FirstHashEntry(&objDefn->properties, &hsearch); for (;hent; hent=Tcl_NextHashEntry(&hsearch)) { Tcl_EventuallyFree(Tcl_GetHashValue(hent), DelPropForReal); } Tcl_DeleteHashTable(&objDefn->properties); Tcl_DecrRefCount(objDefn->self); Tcl_DecrRefCount(objDefn->built_with_constr); Tcl_Free((char *)objDefn); } static void DelClassForReal(char *clientData) { struct Class *myClass = (struct Class *)clientData; Tcl_HashSearch hsearch; Tcl_HashEntry *hent; hent = Tcl_FirstHashEntry(&myClass->objects, &hsearch); if (myClass->creatorInterp && !Tcl_InterpDeleted(myClass->creatorInterp)) { for (;hent; hent = Tcl_FirstHashEntry(&myClass->objects, &hsearch)) { struct Object *obj = Tcl_GetHashValue(hent); Tcl_DeleteCommand(myClass->creatorInterp, Tcl_GetCommandName(myClass->creatorInterp, obj->token)); } } else { for (;hent; hent = Tcl_NextHashEntry(&hsearch)) { struct Object *obj = Tcl_GetHashValue(hent); obj->myClass = NULL; } } Tcl_DeleteHashTable(&myClass->objects); hent = Tcl_FirstHashEntry(&myClass->methods, &hsearch); for (;hent; hent = Tcl_NextHashEntry(&hsearch)) { struct Method *mthdDefn = Tcl_GetHashValue(hent); Tcl_DecrRefCount(mthdDefn->name); Tcl_DecrRefCount(mthdDefn->commandName); Tcl_Free((char *)mthdDefn); } Tcl_DeleteHashTable(&myClass->methods); hent = Tcl_FirstHashEntry(&myClass->properties, &hsearch); for (;hent; hent = Tcl_NextHashEntry(&hsearch)) { Tcl_EventuallyFree(Tcl_GetHashValue(hent), DelPropForReal); } Tcl_DeleteHashTable(&myClass->properties); Tcl_DecrRefCount(myClass->parents); Tcl_DecrRefCount(myClass->self); } static void DelObjCmd(ClientData clientData) { struct Object *objDefn = (struct Object *)clientData; Tcl_HashSearch hsearch; Tcl_HashEntry *hent; if (objDefn->myClass) { #if (TCL_RELEASE_SERIAL==1) hent = FindHashEntry(objDefn->myClass->creatorInterp, &objDefn->myClass->objects, objDefn->self); #else hent = FindHashEntry(&objDefn->myClass->objects, objDefn->self); #endif if (hent) Tcl_DeleteHashEntry(hent); objDefn->myClass = NULL; } /* Need to invalidate all references to this object */ hent = Tcl_FirstHashEntry(&objDefn->references, &hsearch); for (;hent; hent=Tcl_NextHashEntry(&hsearch)) { Tcl_Obj *objPtr = (Tcl_Obj *)Tcl_GetHashKey(&objDefn->references, hent); objPtr->typePtr = NULL; } /* We can delete the hash table now, since the object is no longer * registered with the class - the only route available to the * creation of new references... */ Tcl_DeleteHashTable(&objDefn->references); Tcl_EventuallyFree(clientData, DelObjForReal); } static void DelClass(ClientData clientData) { struct Class *myClass = (struct Class *)clientData; Tcl_HashEntry *hent; /* Stop further examination of this class, which is now officially * on its way out... */ if (myClass->classes) { #if (TCL_RELEASE_SERIAL==1) hent = FindHashEntry(myClass->creatorInterp, myClass->classes, myClass->self); #else hent = FindHashEntry(myClass->classes, myClass->self); #endif if (hent) Tcl_DeleteHashEntry(hent); myClass->classes = NULL; } /* Do the rest when it is known to be safe... */ Tcl_EventuallyFree(clientData, DelClassForReal); } static void DelClassCmd(ClientData clientData) { Tcl_HashTable *classes = (Tcl_HashTable *)clientData; Tcl_HashSearch hsearch; Tcl_HashEntry *hent; Tcl_Interp *interp = NULL; hent = Tcl_FirstHashEntry(classes, &hsearch); if (hent) { struct Class *myClass = Tcl_GetHashValue(hent); if (!Tcl_InterpDeleted(myClass->creatorInterp)) interp = myClass->creatorInterp; } for (;hent; hent = Tcl_FirstHashEntry(classes, &hsearch)) { struct Class *myClass = Tcl_GetHashValue(hent); if (interp) { Tcl_DeleteCommand(interp, Tcl_GetCommandName(interp, myClass->token)); } else { myClass->classes = NULL; } } Tcl_DeleteHashTable(classes); } /* ---------------------------------------------------------------------- */ /* Install everything... */ int Dkfobj_Init(Tcl_Interp *interp) { static int installed_types = 0; Tcl_HashTable *classes; if (!installed_types) { Tcl_RegisterObjType(&commandNameType); Tcl_RegisterObjType(&objectType); Tcl_RegisterObjType(&dereferenceMarkerType); installed_types = 1; } classes = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(classes,TCL_STRING_KEYS); Tcl_CreateObjCommand(interp, "class", 5, ClassCommand, classes, DelClassCmd); Tcl_SetVar(interp, "dkfobj_version", "2.0", TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "dkfobj_patchLevel", "2.0a1", TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "dkfobj_rcsinfo", rcsid, TCL_GLOBAL_ONLY); return TCL_OK; }