URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

Compare Revisions

This comparison shows the changes necessary to convert path
```
/or1k/trunk/insight/itcl/itcl/generic
```
from Rev 578 to Rev 1765
↔ Reverse comparison
Compare Path: Rev

With Path: Rev

Rev 578 → Rev 1765

/itcl_methods.c

0,0 → 1,2557

itcl_methods.c Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: itcl.h =================================================================== --- itcl.h (nonexistent) +++ itcl.h (revision 1765) @@ -0,0 +1,188 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * ADDING [incr Tcl] TO A Tcl-BASED APPLICATION: + * + * To add [incr Tcl] facilities to a Tcl application, modify the + * Tcl_AppInit() routine as follows: + * + * 1) Include this header file near the top of the file containing + * Tcl_AppInit(): + * + * #include "itcl.h" + * + * 2) Within the body of Tcl_AppInit(), add the following lines: + * + * if (Itcl_Init(interp) == TCL_ERROR) { + * return TCL_ERROR; + * } + * + * 3) Link your application with libitcl.a + * + * NOTE: An example file "tclAppInit.c" containing the changes shown + * above is included in this distribution. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * RCS: $Id: itcl.h,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $ + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#ifndef ITCL_H +#define ITCL_H + +#include "tcl.h" + +#define ITCL_VERSION "3.0" +#define ITCL_PATCH_LEVEL "3.0" +#define ITCL_MAJOR_VERSION 3 +#define ITCL_MINOR_VERSION 0 +#define ITCL_RELEASE_LEVEL 0 + +/* + * A special definition used to allow this header file to be included + * in resource files so that they can get obtain version information from + * this file. Resource compilers don't like all the C stuff, like typedefs + * and procedure declarations, that occur below. + */ + +#ifndef RESOURCE_INCLUDED + +#include "tclInt.h" + +#ifdef BUILD_itcl +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLEXPORT +#endif + +/* + * Protection levels: + * + * ITCL_PUBLIC - accessible from any namespace + * ITCL_PROTECTED - accessible from namespace that imports in "protected" mode + * ITCL_PRIVATE - accessible only within the namespace that contains it + */ +#define ITCL_PUBLIC 1 +#define ITCL_PROTECTED 2 +#define ITCL_PRIVATE 3 +#define ITCL_DEFAULT_PROTECT 4 + + +/* + * Generic stack. + */ +typedef struct Itcl_Stack { + ClientData *values; /* values on stack */ + int len; /* number of values on stack */ + int max; /* maximum size of stack */ + ClientData space[5]; /* initial space for stack data */ +} Itcl_Stack; + +#define Itcl_GetStackSize(stackPtr) ((stackPtr)->len) + +/* + * Generic linked list. + */ +struct Itcl_List; +typedef struct Itcl_ListElem { + struct Itcl_List* owner; /* list containing this element */ + ClientData value; /* value associated with this element */ + struct Itcl_ListElem *prev; /* previous element in linked list */ + struct Itcl_ListElem *next; /* next element in linked list */ +} Itcl_ListElem; + +typedef struct Itcl_List { + int validate; /* validation stamp */ + int num; /* number of elements */ + struct Itcl_ListElem *head; /* previous element in linked list */ + struct Itcl_ListElem *tail; /* next element in linked list */ +} Itcl_List; + +#define Itcl_FirstListElem(listPtr) ((listPtr)->head) +#define Itcl_LastListElem(listPtr) ((listPtr)->tail) +#define Itcl_NextListElem(elemPtr) ((elemPtr)->next) +#define Itcl_PrevListElem(elemPtr) ((elemPtr)->prev) +#define Itcl_GetListLength(listPtr) ((listPtr)->num) +#define Itcl_GetListValue(elemPtr) ((elemPtr)->value) + +/* + * Token representing the state of an interpreter. + */ +typedef struct Itcl_InterpState_ *Itcl_InterpState; + + +/* + * Exported functions + */ +EXTERN int Itcl_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Itcl_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); + +EXTERN int Itcl_RegisterC _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_CmdProc *proc, ClientData clientData, + Tcl_CmdDeleteProc *deleteProc)); +EXTERN int Itcl_RegisterObjC _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_ObjCmdProc *proc, ClientData clientData, + Tcl_CmdDeleteProc *deleteProc)); +EXTERN int Itcl_FindC _ANSI_ARGS_((Tcl_Interp *interp, char *name, + Tcl_CmdProc **argProcPtr, Tcl_ObjCmdProc **objProcPtr, + ClientData *cDataPtr)); + +EXTERN void Itcl_InitStack _ANSI_ARGS_((Itcl_Stack *stack)); +EXTERN void Itcl_DeleteStack _ANSI_ARGS_((Itcl_Stack *stack)); +EXTERN void Itcl_PushStack _ANSI_ARGS_((ClientData cdata, + Itcl_Stack *stack)); +EXTERN ClientData Itcl_PopStack _ANSI_ARGS_((Itcl_Stack *stack)); +EXTERN ClientData Itcl_PeekStack _ANSI_ARGS_((Itcl_Stack *stack)); +EXTERN ClientData Itcl_GetStackValue _ANSI_ARGS_((Itcl_Stack *stack, + int pos)); + +EXTERN void Itcl_InitList _ANSI_ARGS_((Itcl_List *listPtr)); +EXTERN void Itcl_DeleteList _ANSI_ARGS_((Itcl_List *listPtr)); +EXTERN Itcl_ListElem* Itcl_CreateListElem _ANSI_ARGS_((Itcl_List *listPtr)); +EXTERN Itcl_ListElem* Itcl_DeleteListElem _ANSI_ARGS_((Itcl_ListElem *elemPtr)); +EXTERN Itcl_ListElem* Itcl_InsertList _ANSI_ARGS_((Itcl_List *listPtr, + ClientData val)); +EXTERN Itcl_ListElem* Itcl_InsertListElem _ANSI_ARGS_((Itcl_ListElem *pos, + ClientData val)); +EXTERN Itcl_ListElem* Itcl_AppendList _ANSI_ARGS_((Itcl_List *listPtr, + ClientData val)); +EXTERN Itcl_ListElem* Itcl_AppendListElem _ANSI_ARGS_((Itcl_ListElem *pos, + ClientData val)); +EXTERN void Itcl_SetListValue _ANSI_ARGS_((Itcl_ListElem *elemPtr, + ClientData val)); + +EXTERN void Itcl_EventuallyFree _ANSI_ARGS_((ClientData cdata, + Tcl_FreeProc *fproc)); +EXTERN void Itcl_PreserveData _ANSI_ARGS_((ClientData cdata)); +EXTERN void Itcl_ReleaseData _ANSI_ARGS_((ClientData cdata)); + +EXTERN Itcl_InterpState Itcl_SaveInterpState _ANSI_ARGS_((Tcl_Interp* interp, + int status)); +EXTERN int Itcl_RestoreInterpState _ANSI_ARGS_((Tcl_Interp* interp, + Itcl_InterpState state)); +EXTERN void Itcl_DiscardInterpState _ANSI_ARGS_((Itcl_InterpState state)); + +#endif /* RESOURCE_INCLUDED */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT + +#endif /* ITCL_H */

itcl.h Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: itcl_class.c =================================================================== --- itcl_class.c (nonexistent) +++ itcl_class.c (revision 1765) @@ -0,0 +1,1728 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * These procedures handle class definitions. Classes are composed of + * data members (public/protected/common) and the member functions + * (methods/procs) that operate on them. Each class has its own + * namespace which manages the class scope. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * RCS: $Id: itcl_class.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $ + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +/* + * This structure is a subclass of Tcl_ResolvedVarInfo that contains the + * ItclVarLookup info needed at runtime. + */ +typedef struct ItclResolvedVarInfo { + Tcl_ResolvedVarInfo vinfo; /* This must be the first element. */ + ItclVarLookup *vlookup; /* Pointer to lookup info. */ +} ItclResolvedVarInfo; + +/* + * FORWARD DECLARATIONS + */ +static void ItclDestroyClass _ANSI_ARGS_((ClientData cdata)); +static void ItclDestroyClassNamesp _ANSI_ARGS_((ClientData cdata)); +static void ItclFreeClass _ANSI_ARGS_((char* cdata)); + +static Tcl_Var ItclClassRuntimeVarResolver _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr)); + + +/* + * ------------------------------------------------------------------------ + * Itcl_CreateClass() + * + * Creates a namespace and its associated class definition data. + * If a namespace already exists with that name, then this routine + * returns TCL_ERROR, along with an error message in the interp. + * If successful, it returns TCL_OK and a pointer to the new class + * definition. + * ------------------------------------------------------------------------ + */ +int +Itcl_CreateClass(interp, path, info, rPtr) + Tcl_Interp* interp; /* interpreter that will contain new class */ + char* path; /* name of new class */ + ItclObjectInfo *info; /* info for all known objects */ + ItclClass **rPtr; /* returns: pointer to class definition */ +{ + char *head, *tail; + Tcl_DString buffer; + Tcl_Command cmd; + Tcl_Namespace *classNs; + ItclClass *cdPtr; + ItclVarDefn *vdefn; + Tcl_HashEntry *entry; + int newEntry; + + /* + * Make sure that a class with the given name does not + * already exist in the current namespace context. If a + * namespace exists, that's okay. It may have been created + * to contain stubs during a "namespace import" operation. + * We'll just replace the namespace data below with the + * proper class data. + */ + classNs = Tcl_FindNamespace(interp, path, (Tcl_Namespace*)NULL, + /* flags */ 0); + + if (classNs != NULL && Itcl_IsClassNamespace(classNs)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "class \"", path, "\" already exists", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Make sure that a command with the given class name does not + * already exist in the current namespace. This prevents the + * usual Tcl commands from being clobbered when a programmer + * makes a bogus call like "class info". + */ + cmd = Tcl_FindCommand(interp, path, (Tcl_Namespace*)NULL, + /* flags */ TCL_NAMESPACE_ONLY); + + if (cmd != NULL && !Itcl_IsStub(cmd)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "command \"", path, "\" already exists", + (char*)NULL); + + if (strstr(path,"::") == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + " in namespace \"", + Tcl_GetCurrentNamespace(interp)->fullName, "\"", + (char*)NULL); + } + return TCL_ERROR; + } + + /* + * Make sure that the class name does not have any goofy + * characters: + * + * . => reserved for member access like: class.publicVar + */ + Itcl_ParseNamespPath(path, &buffer, &head, &tail); + + if (strstr(tail,".")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad class name \"", tail, "\"", + (char*)NULL); + Tcl_DStringFree(&buffer); + return TCL_ERROR; + } + Tcl_DStringFree(&buffer); + + /* + * Allocate class definition data. + */ + cdPtr = (ItclClass*)ckalloc(sizeof(ItclClass)); + cdPtr->name = NULL; + cdPtr->fullname = NULL; + cdPtr->interp = interp; + cdPtr->info = info; Itcl_PreserveData((ClientData)info); + cdPtr->namesp = NULL; + cdPtr->accessCmd = NULL; + + Tcl_InitHashTable(&cdPtr->variables, TCL_STRING_KEYS); + Tcl_InitHashTable(&cdPtr->functions, TCL_STRING_KEYS); + + cdPtr->numInstanceVars = 0; + Tcl_InitHashTable(&cdPtr->resolveVars, TCL_STRING_KEYS); + Tcl_InitHashTable(&cdPtr->resolveCmds, TCL_STRING_KEYS); + + Itcl_InitList(&cdPtr->bases); + Itcl_InitList(&cdPtr->derived); + + cdPtr->initCode = NULL; + cdPtr->unique = 0; + cdPtr->flags = 0; + + /* + * Initialize the heritage info--each class starts with its + * own class definition in the heritage. Base classes are + * added to the heritage from the "inherit" statement. + */ + Tcl_InitHashTable(&cdPtr->heritage, TCL_ONE_WORD_KEYS); + (void) Tcl_CreateHashEntry(&cdPtr->heritage, (char*)cdPtr, &newEntry); + + /* + * Create a namespace to represent the class. Add the class + * definition info as client data for the namespace. If the + * namespace already exists, then replace any existing client + * data with the class data. + */ + Itcl_PreserveData((ClientData)cdPtr); + + if (classNs == NULL) { + classNs = Tcl_CreateNamespace(interp, path, + (ClientData)cdPtr, ItclDestroyClassNamesp); + } + else { + if (classNs->clientData && classNs->deleteProc) { + (*classNs->deleteProc)(classNs->clientData); + } + classNs->clientData = (ClientData)cdPtr; + classNs->deleteProc = ItclDestroyClassNamesp; + } + + Itcl_EventuallyFree((ClientData)cdPtr, ItclFreeClass); + + if (classNs == NULL) { + Itcl_ReleaseData((ClientData)cdPtr); + return TCL_ERROR; + } + + cdPtr->namesp = classNs; + + cdPtr->name = (char*)ckalloc((unsigned)(strlen(classNs->name)+1)); + strcpy(cdPtr->name, classNs->name); + + cdPtr->fullname = (char*)ckalloc((unsigned)(strlen(classNs->fullName)+1)); + strcpy(cdPtr->fullname, classNs->fullName); + + /* + * Add special name resolution procedures to the class namespace + * so that members are accessed according to the rules for + * [incr Tcl]. + */ + Tcl_SetNamespaceResolvers(classNs, Itcl_ClassCmdResolver, + Itcl_ClassVarResolver, Itcl_ClassCompiledVarResolver); + + /* + * Add the built-in "this" variable to the list of data members. + */ + (void) Itcl_CreateVarDefn(interp, cdPtr, "this", + (char*)NULL, (char*)NULL, &vdefn); + + vdefn->member->protection = ITCL_PROTECTED; /* always "protected" */ + vdefn->member->flags |= ITCL_THIS_VAR; /* mark as "this" variable */ + + entry = Tcl_CreateHashEntry(&cdPtr->variables, "this", &newEntry); + Tcl_SetHashValue(entry, (ClientData)vdefn); + + /* + * Create a command in the current namespace to manage the class: + * + * ?? + */ + Itcl_PreserveData((ClientData)cdPtr); + + cdPtr->accessCmd = Tcl_CreateObjCommand(interp, + cdPtr->fullname, Itcl_HandleClass, + (ClientData)cdPtr, ItclDestroyClass); + + *rPtr = cdPtr; + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteClass() + * + * Deletes a class by deleting all derived classes and all objects in + * that class, and finally, by destroying the class namespace. This + * procedure provides a friendly way of doing this. If any errors + * are detected along the way, the process is aborted. + * + * Returns TCL_OK if successful, or TCL_ERROR (along with an error + * message in the interpreter) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +int +Itcl_DeleteClass(interp, cdefnPtr) + Tcl_Interp *interp; /* interpreter managing this class */ + ItclClass *cdefnPtr; /* class namespace */ +{ + ItclClass *cdPtr = NULL; + + Itcl_ListElem *elem; + ItclObject *contextObj; + Tcl_HashEntry *entry; + Tcl_HashSearch place; + Tcl_DString buffer; + + /* + * Destroy all derived classes, since these lose their meaning + * when the base class goes away. If anything goes wrong, + * abort with an error. + * + * TRICKY NOTE: When a derived class is destroyed, it + * automatically deletes itself from the "derived" list. + */ + elem = Itcl_FirstListElem(&cdefnPtr->derived); + while (elem) { + cdPtr = (ItclClass*)Itcl_GetListValue(elem); + elem = Itcl_NextListElem(elem); /* advance here--elem will go away */ + + if (Itcl_DeleteClass(interp, cdPtr) != TCL_OK) { + goto deleteClassFail; + } + } + + /* + * Scan through and find all objects that belong to this class. + * Note that more specialized objects have already been + * destroyed above, when derived classes were destroyed. + * Destroy objects and report any errors. + */ + entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place); + while (entry) { + contextObj = (ItclObject*)Tcl_GetHashValue(entry); + if (contextObj->classDefn == cdefnPtr) { + if (Itcl_DeleteObject(interp, contextObj) != TCL_OK) { + cdPtr = cdefnPtr; + goto deleteClassFail; + } + } + entry = Tcl_NextHashEntry(&place); + } + + /* + * Destroy the namespace associated with this class. + * + * TRICKY NOTE: + * The cleanup procedure associated with the namespace is + * invoked automatically. It does all of the same things + * above, but it also disconnects this class from its + * base-class lists, and removes the class access command. + */ + Tcl_DeleteNamespace(cdefnPtr->namesp); + return TCL_OK; + +deleteClassFail: + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, "\n (while deleting class \"", -1); + Tcl_DStringAppend(&buffer, cdPtr->namesp->fullName, -1); + Tcl_DStringAppend(&buffer, "\")", -1); + Tcl_AddErrorInfo(interp, Tcl_DStringValue(&buffer)); + Tcl_DStringFree(&buffer); + return TCL_ERROR; +} + + +/* + * ------------------------------------------------------------------------ + * ItclDestroyClass() + * + * Invoked whenever the access command for a class is destroyed. + * Destroys the namespace associated with the class, which also + * destroys all objects in the class and all derived classes. + * Disconnects this class from the "derived" class lists of its + * base classes, and releases any claim to the class definition + * data. If this is the last use of that data, the class will + * completely vanish at this point. + * ------------------------------------------------------------------------ + */ +static void +ItclDestroyClass(cdata) + ClientData cdata; /* class definition to be destroyed */ +{ + ItclClass *cdefnPtr = (ItclClass*)cdata; + cdefnPtr->accessCmd = NULL; + + Tcl_DeleteNamespace(cdefnPtr->namesp); + Itcl_ReleaseData((ClientData)cdefnPtr); +} + + +/* + * ------------------------------------------------------------------------ + * ItclDestroyClassNamesp() + * + * Invoked whenever the namespace associated with a class is destroyed. + * Destroys all objects associated with this class and all derived + * classes. Disconnects this class from the "derived" class lists + * of its base classes, and removes the class access command. Releases + * any claim to the class definition data. If this is the last use + * of that data, the class will completely vanish at this point. + * ------------------------------------------------------------------------ + */ +static void +ItclDestroyClassNamesp(cdata) + ClientData cdata; /* class definition to be destroyed */ +{ + ItclClass *cdefnPtr = (ItclClass*)cdata; + ItclObject *contextObj; + Itcl_ListElem *elem, *belem; + ItclClass *cdPtr, *basePtr, *derivedPtr; + Tcl_HashEntry *entry; + Tcl_HashSearch place; + + /* + * Destroy all derived classes, since these lose their meaning + * when the base class goes away. + * + * TRICKY NOTE: When a derived class is destroyed, it + * automatically deletes itself from the "derived" list. + */ + elem = Itcl_FirstListElem(&cdefnPtr->derived); + while (elem) { + cdPtr = (ItclClass*)Itcl_GetListValue(elem); + elem = Itcl_NextListElem(elem); /* advance here--elem will go away */ + + Tcl_DeleteNamespace(cdPtr->namesp); + } + + /* + * Scan through and find all objects that belong to this class. + * Destroy them quietly by deleting their access command. + */ + entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place); + while (entry) { + contextObj = (ItclObject*)Tcl_GetHashValue(entry); + if (contextObj->classDefn == cdefnPtr) { + Tcl_DeleteCommandFromToken(cdefnPtr->interp, contextObj->accessCmd); + } + entry = Tcl_NextHashEntry(&place); + } + + /* + * Next, remove this class from the "derived" list in + * all base classes. + */ + belem = Itcl_FirstListElem(&cdefnPtr->bases); + while (belem) { + basePtr = (ItclClass*)Itcl_GetListValue(belem); + + elem = Itcl_FirstListElem(&basePtr->derived); + while (elem) { + derivedPtr = (ItclClass*)Itcl_GetListValue(elem); + if (derivedPtr == cdefnPtr) { + Itcl_ReleaseData( Itcl_GetListValue(elem) ); + elem = Itcl_DeleteListElem(elem); + } else { + elem = Itcl_NextListElem(elem); + } + } + belem = Itcl_NextListElem(belem); + } + + /* + * Next, destroy the access command associated with the class. + */ + if (cdefnPtr->accessCmd) { + Command *cmdPtr = (Command*)cdefnPtr->accessCmd; + + cmdPtr->deleteProc = Itcl_ReleaseData; + Tcl_DeleteCommandFromToken(cdefnPtr->interp, cdefnPtr->accessCmd); + } + + /* + * Release the namespace's claim on the class definition. + */ + Itcl_ReleaseData((ClientData)cdefnPtr); +} + + +/* + * ------------------------------------------------------------------------ + * ItclFreeClass() + * + * Frees all memory associated with a class definition. This is + * usually invoked automatically by Itcl_ReleaseData(), when class + * data is no longer being used. + * ------------------------------------------------------------------------ + */ +static void +ItclFreeClass(cdata) + char *cdata; /* class definition to be destroyed */ +{ + ItclClass *cdefnPtr = (ItclClass*)cdata; + + int newEntry; + Itcl_ListElem *elem; + Tcl_HashSearch place; + Tcl_HashEntry *entry, *hPtr; + ItclVarDefn *vdefn; + ItclVarLookup *vlookup; + Var *varPtr; + Tcl_HashTable varTable; + + /* + * Tear down the list of derived classes. This list should + * really be empty if everything is working properly, but + * release it here just in case. + */ + elem = Itcl_FirstListElem(&cdefnPtr->derived); + while (elem) { + Itcl_ReleaseData( Itcl_GetListValue(elem) ); + elem = Itcl_NextListElem(elem); + } + Itcl_DeleteList(&cdefnPtr->derived); + + /* + * Tear down the variable resolution table. Some records + * appear multiple times in the table (for x, foo::x, etc.) + * so each one has a reference count. + */ + Tcl_InitHashTable(&varTable, TCL_STRING_KEYS); + + entry = Tcl_FirstHashEntry(&cdefnPtr->resolveVars, &place); + while (entry) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + if (--vlookup->usage == 0) { + /* + * If this is a common variable owned by this class, + * then release the class's hold on it. If it's no + * longer being used, move it into a variable table + * for destruction. + */ + if ( (vlookup->vdefn->member->flags & ITCL_COMMON) != 0 && + vlookup->vdefn->member->classDefn == cdefnPtr ) { + varPtr = (Var*)vlookup->var.common; + if (--varPtr->refCount == 0) { + hPtr = Tcl_CreateHashEntry(&varTable, + vlookup->vdefn->member->fullname, &newEntry); + Tcl_SetHashValue(hPtr, (ClientData) varPtr); + } + } + ckfree((char*)vlookup); + } + entry = Tcl_NextHashEntry(&place); + } + + TclDeleteVars((Interp*)cdefnPtr->interp, &varTable); + Tcl_DeleteHashTable(&cdefnPtr->resolveVars); + + /* + * Tear down the virtual method table... + */ + Tcl_DeleteHashTable(&cdefnPtr->resolveCmds); + + /* + * Delete all variable definitions. + */ + entry = Tcl_FirstHashEntry(&cdefnPtr->variables, &place); + while (entry) { + vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry); + Itcl_DeleteVarDefn(vdefn); + entry = Tcl_NextHashEntry(&place); + } + Tcl_DeleteHashTable(&cdefnPtr->variables); + + /* + * Delete all function definitions. + */ + entry = Tcl_FirstHashEntry(&cdefnPtr->functions, &place); + while (entry) { + Itcl_ReleaseData( Tcl_GetHashValue(entry) ); + entry = Tcl_NextHashEntry(&place); + } + Tcl_DeleteHashTable(&cdefnPtr->functions); + + /* + * Release the claim on all base classes. + */ + elem = Itcl_FirstListElem(&cdefnPtr->bases); + while (elem) { + Itcl_ReleaseData( Itcl_GetListValue(elem) ); + elem = Itcl_NextListElem(elem); + } + Itcl_DeleteList(&cdefnPtr->bases); + Tcl_DeleteHashTable(&cdefnPtr->heritage); + + /* + * Free up the object initialization code. + */ + if (cdefnPtr->initCode) { + Tcl_DecrRefCount(cdefnPtr->initCode); + } + + Itcl_ReleaseData((ClientData)cdefnPtr->info); + + ckfree(cdefnPtr->name); + ckfree(cdefnPtr->fullname); + + ckfree((char*)cdefnPtr); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_IsClassNamespace() + * + * Checks to see whether or not the given namespace represents an + * [incr Tcl] class. Returns non-zero if so, and zero otherwise. + * ------------------------------------------------------------------------ + */ +int +Itcl_IsClassNamespace(namesp) + Tcl_Namespace *namesp; /* namespace being tested */ +{ + Namespace *nsPtr = (Namespace*)namesp; + + if (nsPtr != NULL) { + return (nsPtr->deleteProc == ItclDestroyClassNamesp); + } + return 0; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_IsClass() + * + * Checks the given Tcl command to see if it represents an itcl class. + * Returns non-zero if the command is associated with a class. + * ------------------------------------------------------------------------ + */ +int +Itcl_IsClass(cmd) + Tcl_Command cmd; /* command being tested */ +{ + Command *cmdPtr = (Command*)cmd; + + if (cmdPtr->deleteProc == ItclDestroyClass) { + return 1; + } + + /* + * This may be an imported command. Try to get the real + * command and see if it represents a class. + */ + cmdPtr = (Command*)TclGetOriginalCommand(cmd); + if (cmdPtr && cmdPtr->deleteProc == ItclDestroyClass) { + return 1; + } + return 0; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_FindClass() + * + * Searches for the specified class in the active namespace. If the + * class is found, this procedure returns a pointer to the class + * definition. Otherwise, if the autoload flag is non-zero, an + * attempt will be made to autoload the class definition. If it + * still can't be found, this procedure returns NULL, along with an + * error message in the interpreter. + * ------------------------------------------------------------------------ + */ +ItclClass* +Itcl_FindClass(interp, path, autoload) + Tcl_Interp* interp; /* interpreter containing class */ + char* path; /* path name for class */ +{ + Tcl_Namespace* classNs; + + /* + * Search for a namespace with the specified name, and if + * one is found, see if it is a class namespace. + */ + classNs = Itcl_FindClassNamespace(interp, path); + + if (classNs && Itcl_IsClassNamespace(classNs)) { + return (ItclClass*)classNs->clientData; + } + + /* + * If the autoload flag is set, try to autoload the class + * definition. + */ + if (autoload) { + if (Tcl_VarEval(interp, "::auto_load ", path, (char*)NULL) != TCL_OK) { + char msg[256]; + sprintf(msg, "\n (while attempting to autoload class \"%.200s\")", path); + Tcl_AddErrorInfo(interp, msg); + return NULL; + } + Tcl_ResetResult(interp); + + classNs = Itcl_FindClassNamespace(interp, path); + if (classNs && Itcl_IsClassNamespace(classNs)) { + return (ItclClass*)classNs->clientData; + } + } + + Tcl_AppendResult(interp, "class \"", path, "\" not found in context \"", + Tcl_GetCurrentNamespace(interp)->fullName, "\"", + (char*)NULL); + + return NULL; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_FindClassNamespace() + * + * Searches for the specified class namespace. The normal Tcl procedure + * Tcl_FindNamespace also searches for namespaces, but only in the + * current namespace context. This makes it hard to find one class + * from within another. For example, suppose. you have two namespaces + * Foo and Bar. If you're in the context of Foo and you look for + * Bar, you won't find it with Tcl_FindNamespace. This behavior is + * okay for namespaces, but wrong for classes. + * + * This procedure search for a class namespace. If the name is + * absolute (i.e., starts with "::"), then that one name is checked, + * and the class is either found or not. But if the name is relative, + * it is sought in the current namespace context and in the global + * context, just like the normal command lookup. + * + * This procedure returns a pointer to the desired namespace, or + * NULL if the namespace was not found. + * ------------------------------------------------------------------------ + */ +Tcl_Namespace* +Itcl_FindClassNamespace(interp, path) + Tcl_Interp* interp; /* interpreter containing class */ + char* path; /* path name for class */ +{ + Tcl_Namespace* contextNs = Tcl_GetCurrentNamespace(interp); + Tcl_Namespace* classNs; + Tcl_DString buffer; + + /* + * Look up the namespace. If the name is not absolute, then + * see if it's the current namespace, and try the global + * namespace as well. + */ + classNs = Tcl_FindNamespace(interp, path, (Tcl_Namespace*)NULL, + /* flags */ 0); + + if ( !classNs && contextNs->parentPtr != NULL && + (*path != ':' || *(path+1) != ':') ) { + + if (strcmp(contextNs->name, path) == 0) { + classNs = contextNs; + } + else { + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, "::", -1); + Tcl_DStringAppend(&buffer, path, -1); + + classNs = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), + (Tcl_Namespace*)NULL, /* flags */ 0); + + Tcl_DStringFree(&buffer); + } + } + return classNs; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_HandleClass() + * + * Invoked by Tcl whenever the user issues the command associated with + * a class name. Handles the following syntax: + * + * + * ?...? + * + * Without any arguments, the command does nothing. In the olden days, + * this allowed the class name to be invoked by itself to prompt the + * autoloader to load the class definition. Today, this behavior is + * retained for backward compatibility with old releases. + * + * If arguments are specified, then this procedure creates a new + * object named in the appropriate class. Note that if + * contains "#auto", that part is automatically replaced + * by a unique string built from the class name. + * ------------------------------------------------------------------------ + */ +int +Itcl_HandleClass(clientData, interp, objc, objv) + ClientData clientData; /* class definition */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclClass *cdefnPtr = (ItclClass*)clientData; + int result = TCL_OK; + + char unique[256]; /* buffer used for unique part of object names */ + Tcl_DString buffer; /* buffer used to build object names */ + char *token, *objName, tmp, *start, *pos, *match; + + ItclObject *newObj; + Tcl_CallFrame frame; + + /* + * If the command is invoked without an object name, then do nothing. + * This used to support autoloading--that the class name could be + * invoked as a command by itself, prompting the autoloader to + * load the class definition. We retain the behavior here for + * backward-compatibility with earlier releases. + */ + if (objc == 1) { + return TCL_OK; + } + + /* + * If the object name is "::", and if this is an old-style class + * definition, then treat the remaining arguments as a command + * in the class namespace. This used to be the way of invoking + * a class proc, but the new syntax is "class::proc" (without + * spaces). + */ + token = Tcl_GetStringFromObj(objv[1], (int*)NULL); + if ((*token == ':') && (strcmp(token,"::") == 0) && (objc > 2)) { + if ((cdefnPtr->flags & ITCL_OLD_STYLE) != 0) { + + result = Tcl_PushCallFrame(interp, &frame, + cdefnPtr->namesp, /* isProcCallFrame */ 0); + + if (result != TCL_OK) { + return result; + } + result = Itcl_EvalArgs(interp, objc-2, objv+2); + + Tcl_PopCallFrame(interp); + return result; + } + + /* + * If this is not an old-style class, then return an error + * describing the syntax change. + */ + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "syntax \"class :: proc\" is an anachronism\n", + "[incr Tcl] no longer supports this syntax.\n", + "Instead, remove the spaces from your procedure invocations:\n", + " ", + Tcl_GetStringFromObj(objv[0], (int*)NULL), "::", + Tcl_GetStringFromObj(objv[2], (int*)NULL), " ?args?", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Otherwise, we have a proper object name. Create a new instance + * with that name. If the name contains "#auto", replace this with + * a uniquely generated string based on the class name. + */ + Tcl_DStringInit(&buffer); + objName = NULL; + + match = "#auto"; + start = token; + for (pos=start; *pos != '\0'; pos++) { + if (*pos == *match) { + if (*(++match) == '\0') { + tmp = *start; + *start = '\0'; /* null-terminate first part */ + + /* + * Substitute a unique part in for "#auto", and keep + * incrementing a counter until a valid name is found. + */ + do { + sprintf(unique,"%.200s%d", cdefnPtr->name, + cdefnPtr->unique++); + unique[0] = tolower(unique[0]); + + Tcl_DStringTrunc(&buffer, 0); + Tcl_DStringAppend(&buffer, token, -1); + Tcl_DStringAppend(&buffer, unique, -1); + Tcl_DStringAppend(&buffer, start+5, -1); + + objName = Tcl_DStringValue(&buffer); + if (Itcl_FindObject(interp, objName, &newObj) != TCL_OK) { + break; /* if an error is found, bail out! */ + } + } while (newObj != NULL); + + *start = tmp; /* undo null-termination */ + objName = Tcl_DStringValue(&buffer); + break; /* object name is ready to go! */ + } + } + else { + match = "#auto"; + pos = start++; + } + } + + /* + * If "#auto" was not found, then just use object name as-is. + */ + if (objName == NULL) { + objName = token; + } + + /* + * Try to create a new object. If successful, return the + * object name as the result of this command. + */ + result = Itcl_CreateObject(interp, objName, cdefnPtr, + objc-2, objv+2, &newObj); + + if (result == TCL_OK) { + Tcl_SetResult(interp, objName, TCL_VOLATILE); + } + + Tcl_DStringFree(&buffer); + return result; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassCmdResolver() + * + * Used by the class namespaces to handle name resolution for all + * commands. This procedure looks for references to class methods + * and procs, and returns TCL_OK along with the appropriate Tcl + * command in the rPtr argument. If a particular command is private, + * this procedure returns TCL_ERROR and access to the command is + * denied. If a command is not recognized, this procedure returns + * TCL_CONTINUE, and lookup continues via the normal Tcl name + * resolution rules. + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassCmdResolver(interp, name, context, flags, rPtr) + Tcl_Interp *interp; /* current interpreter */ + char* name; /* name of the command being accessed */ + Tcl_Namespace *context; /* namespace performing the resolution */ + int flags; /* TCL_LEAVE_ERR_MSG => leave error messages + * in interp if anything goes wrong */ + Tcl_Command *rPtr; /* returns: resolved command */ +{ + ItclClass *cdefn = (ItclClass*)context->clientData; + + Tcl_HashEntry *entry; + ItclMemberFunc *mfunc; + Command *cmdPtr; + + /* + * If the command is a member function, and if it is + * accessible, return its Tcl command handle. + */ + entry = Tcl_FindHashEntry(&cdefn->resolveCmds, name); + if (!entry) { + return TCL_CONTINUE; + } + + mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); + + + /* + * For protected/private functions, figure out whether or + * not the function is accessible from the current context. + * + * TRICKY NOTE: Use Itcl_GetTrueNamespace to determine + * the current context. If the current call frame is + * "transparent", this handles it properly. + */ + if (mfunc->member->protection != ITCL_PUBLIC) { + context = Itcl_GetTrueNamespace(interp, cdefn->info); + + if (!Itcl_CanAccessFunc(mfunc, context)) { + + if ((flags & TCL_LEAVE_ERR_MSG) != 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't access \"", name, "\": ", + Itcl_ProtectionStr(mfunc->member->protection), + " variable", + (char*)NULL); + } + return TCL_ERROR; + } + } + + /* + * Looks like we found an accessible member function. + * + * TRICKY NOTE: Check to make sure that the command handle + * is still valid. If someone has deleted or renamed the + * command, it may not be. This is just the time to catch + * it--as it is being resolved again by the compiler. + */ + cmdPtr = (Command*)mfunc->accessCmd; + if (!cmdPtr || cmdPtr->deleted) { + mfunc->accessCmd = NULL; + + if ((flags & TCL_LEAVE_ERR_MSG) != 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't access \"", name, "\": deleted or redefined\n", + "(use the \"body\" command to redefine methods/procs)", + (char*)NULL); + } + return TCL_ERROR; /* disallow access! */ + } + + *rPtr = mfunc->accessCmd; + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassVarResolver() + * + * Used by the class namespaces to handle name resolution for runtime + * variable accesses. This procedure looks for references to both + * common variables and instance variables at runtime. It is used as + * a second line of defense, to handle references that could not be + * resolved as compiled locals. + * + * If a variable is found, this procedure returns TCL_OK along with + * the appropriate Tcl variable in the rPtr argument. If a particular + * variable is private, this procedure returns TCL_ERROR and access + * to the variable is denied. If a variable is not recognized, this + * procedure returns TCL_CONTINUE, and lookup continues via the normal + * Tcl name resolution rules. + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassVarResolver(interp, name, context, flags, rPtr) + Tcl_Interp *interp; /* current interpreter */ + char* name; /* name of the variable being accessed */ + Tcl_Namespace *context; /* namespace performing the resolution */ + int flags; /* TCL_LEAVE_ERR_MSG => leave error messages + * in interp if anything goes wrong */ + Tcl_Var *rPtr; /* returns: resolved variable */ +{ + ItclClass *cdefn = (ItclClass*)context->clientData; + ItclObject *contextObj; + Tcl_CallFrame *framePtr; + Tcl_HashEntry *entry; + ItclVarLookup *vlookup; + + assert(Itcl_IsClassNamespace(context)); + + /* + * If this is a global variable, handle it in the usual + * Tcl manner. + */ + if (flags & TCL_GLOBAL_ONLY) { + return TCL_CONTINUE; + } + + /* + * See if the variable is a known data member and accessible. + */ + entry = Tcl_FindHashEntry(&cdefn->resolveVars, name); + if (entry == NULL) { + return TCL_CONTINUE; + } + + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + if (!vlookup->accessible) { + return TCL_CONTINUE; + } + + /* + * If this is a common data member, then its variable + * is easy to find. Return it directly. + */ + if ((vlookup->vdefn->member->flags & ITCL_COMMON) != 0) { + *rPtr = vlookup->var.common; + return TCL_OK; + } + + /* + * If this is an instance variable, then we have to + * find the object context, then index into its data + * array to get the actual variable. + */ + framePtr = _Tcl_GetCallFrame(interp, 0); + + entry = Tcl_FindHashEntry(&cdefn->info->contextFrames, (char*)framePtr); + if (entry == NULL) { + return TCL_CONTINUE; + } + contextObj = (ItclObject*)Tcl_GetHashValue(entry); + + /* + * TRICKY NOTE: We've resolved the variable in the current + * class context, but we must also be careful to get its + * index from the most-specific class context. Variables + * are arranged differently depending on which class + * constructed the object. + */ + if (contextObj->classDefn != vlookup->vdefn->member->classDefn) { + entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars, + vlookup->vdefn->member->fullname); + + if (entry) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + } + } + *rPtr = (Tcl_Var)contextObj->data[vlookup->var.index]; + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassCompiledVarResolver() + * + * Used by the class namespaces to handle name resolution for compile + * time variable accesses. This procedure looks for references to + * both common variables and instance variables at compile time. If + * the variables are found, they are characterized in a generic way + * by their ItclVarLookup record. At runtime, Tcl constructs the + * compiled local variables by calling ItclClassRuntimeVarResolver. + * + * If a variable is found, this procedure returns TCL_OK along with + * information about the variable in the rPtr argument. If a particular + * variable is private, this procedure returns TCL_ERROR and access + * to the variable is denied. If a variable is not recognized, this + * procedure returns TCL_CONTINUE, and lookup continues via the normal + * Tcl name resolution rules. + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassCompiledVarResolver(interp, name, length, context, rPtr) + Tcl_Interp *interp; /* current interpreter */ + char* name; /* name of the variable being accessed */ + int length; /* number of characters in name */ + Tcl_Namespace *context; /* namespace performing the resolution */ + Tcl_ResolvedVarInfo **rPtr; /* returns: info that makes it possible to + * resolve the variable at runtime */ +{ + ItclClass *cdefn = (ItclClass*)context->clientData; + Tcl_HashEntry *entry; + ItclVarLookup *vlookup; + char *buffer, storage[64]; + + assert(Itcl_IsClassNamespace(context)); + + /* + * Copy the name to local storage so we can NULL terminate it. + * If the name is long, allocate extra space for it. + */ + if (length < sizeof(storage)) { + buffer = storage; + } else { + buffer = (char*)ckalloc((unsigned)(length+1)); + } + memcpy((void*)buffer, (void*)name, (size_t)length); + buffer[length] = '\0'; + + entry = Tcl_FindHashEntry(&cdefn->resolveVars, buffer); + + if (buffer != storage) { + ckfree(buffer); + } + + /* + * If the name is not found, or if it is inaccessible, + * continue on with the normal Tcl name resolution rules. + */ + if (entry == NULL) { + return TCL_CONTINUE; + } + + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + if (!vlookup->accessible) { + return TCL_CONTINUE; + } + + /* + * Return the ItclVarLookup record. At runtime, Tcl will + * call ItclClassRuntimeVarResolver with this record, to + * plug in the appropriate variable for the current object + * context. + */ + (*rPtr) = (Tcl_ResolvedVarInfo *) ckalloc(sizeof(ItclResolvedVarInfo)); + (*rPtr)->fetchProc = ItclClassRuntimeVarResolver; + (*rPtr)->deleteProc = NULL; + ((ItclResolvedVarInfo*)(*rPtr))->vlookup = vlookup; + + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * ItclClassRuntimeVarResolver() + * + * Invoked when Tcl sets up the call frame for an [incr Tcl] method/proc + * at runtime. Resolves data members identified earlier by + * Itcl_ClassCompiledVarResolver. Returns the Tcl_Var representation + * for the data member. + * ------------------------------------------------------------------------ + */ +static Tcl_Var +ItclClassRuntimeVarResolver(interp, resVarInfo) + Tcl_Interp *interp; /* current interpreter */ + Tcl_ResolvedVarInfo *resVarInfo; /* contains ItclVarLookup rep + * for variable */ +{ + ItclVarLookup *vlookup = ((ItclResolvedVarInfo*)resVarInfo)->vlookup; + + Tcl_CallFrame *framePtr; + ItclClass *cdefn; + ItclObject *contextObj; + Tcl_HashEntry *entry; + + /* + * If this is a common data member, then the associated + * variable is known directly. + */ + if ((vlookup->vdefn->member->flags & ITCL_COMMON) != 0) { + return vlookup->var.common; + } + cdefn = vlookup->vdefn->member->classDefn; + + /* + * Otherwise, get the current object context and find the + * variable in its data table. + * + * TRICKY NOTE: Get the index for this variable using the + * virtual table for the MOST-SPECIFIC class. + */ + framePtr = _Tcl_GetCallFrame(interp, 0); + + entry = Tcl_FindHashEntry(&cdefn->info->contextFrames, (char*)framePtr); + if (entry) { + contextObj = (ItclObject*)Tcl_GetHashValue(entry); + + if (contextObj != NULL) { + if (contextObj->classDefn != vlookup->vdefn->member->classDefn) { + entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars, + vlookup->vdefn->member->fullname); + + if (entry) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + } + } + return (Tcl_Var)contextObj->data[vlookup->var.index]; + } + } + return NULL; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_BuildVirtualTables() + * + * Invoked whenever the class heritage changes or members are added or + * removed from a class definition to rebuild the member lookup + * tables. There are two tables: + * + * METHODS: resolveCmds + * Used primarily in Itcl_ClassCmdResolver() to resolve all + * command references in a namespace. + * + * DATA MEMBERS: resolveVars + * Used primarily in Itcl_ClassVarResolver() to quickly resolve + * variable references in each class scope. + * + * These tables store every possible name for each command/variable + * (member, class::member, namesp::class::member, etc.). Members + * in a derived class may shadow members with the same name in a + * base class. In that case, the simple name in the resolution + * table will point to the most-specific member. + * ------------------------------------------------------------------------ + */ +void +Itcl_BuildVirtualTables(cdefnPtr) + ItclClass* cdefnPtr; /* class definition being updated */ +{ + Tcl_HashEntry *entry, *hPtr; + Tcl_HashSearch place; + ItclVarLookup *vlookup; + ItclVarDefn *vdefn; + ItclMemberFunc *mfunc; + ItclHierIter hier; + ItclClass *cdPtr; + Namespace* nsPtr; + Tcl_DString buffer, buffer2; + int newEntry; + + Tcl_DStringInit(&buffer); + Tcl_DStringInit(&buffer2); + + /* + * Clear the variable resolution table. + */ + entry = Tcl_FirstHashEntry(&cdefnPtr->resolveVars, &place); + while (entry) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + if (--vlookup->usage == 0) { + ckfree((char*)vlookup); + } + entry = Tcl_NextHashEntry(&place); + } + Tcl_DeleteHashTable(&cdefnPtr->resolveVars); + Tcl_InitHashTable(&cdefnPtr->resolveVars, TCL_STRING_KEYS); + cdefnPtr->numInstanceVars = 0; + + /* + * Set aside the first object-specific slot for the built-in + * "this" variable. Only allocate one of these, even though + * there is a definition for "this" in each class scope. + */ + cdefnPtr->numInstanceVars++; + + /* + * Scan through all classes in the hierarchy, from most to + * least specific. Add a lookup entry for each variable + * into the table. + */ + Itcl_InitHierIter(&hier, cdefnPtr); + cdPtr = Itcl_AdvanceHierIter(&hier); + while (cdPtr != NULL) { + entry = Tcl_FirstHashEntry(&cdPtr->variables, &place); + while (entry) { + vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry); + + vlookup = (ItclVarLookup*)ckalloc(sizeof(ItclVarLookup)); + vlookup->vdefn = vdefn; + vlookup->usage = 0; + vlookup->leastQualName = NULL; + + /* + * If this variable is PRIVATE to another class scope, + * then mark it as "inaccessible". + */ + vlookup->accessible = + ( vdefn->member->protection != ITCL_PRIVATE || + vdefn->member->classDefn == cdefnPtr ); + + /* + * If this is a common variable, then keep a reference to + * the variable directly. Otherwise, keep an index into + * the object's variable table. + */ + if ((vdefn->member->flags & ITCL_COMMON) != 0) { + nsPtr = (Namespace*)cdPtr->namesp; + hPtr = Tcl_FindHashEntry(&nsPtr->varTable, vdefn->member->name); + assert(hPtr != NULL); + + vlookup->var.common = (Tcl_Var)Tcl_GetHashValue(hPtr); + } + else { + /* + * If this is a reference to the built-in "this" + * variable, then its index is "0". Otherwise, + * add another slot to the end of the table. + */ + if ((vdefn->member->flags & ITCL_THIS_VAR) != 0) { + vlookup->var.index = 0; + } + else { + vlookup->var.index = cdefnPtr->numInstanceVars++; + } + } + + /* + * Create all possible names for this variable and enter + * them into the variable resolution table: + * var + * class::var + * namesp1::class::var + * namesp2::namesp1::class::var + * ... + */ + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, vdefn->member->name, -1); + nsPtr = (Namespace*)cdPtr->namesp; + + while (1) { + entry = Tcl_CreateHashEntry(&cdefnPtr->resolveVars, + Tcl_DStringValue(&buffer), &newEntry); + + if (newEntry) { + Tcl_SetHashValue(entry, (ClientData)vlookup); + vlookup->usage++; + + if (!vlookup->leastQualName) { + vlookup->leastQualName = + Tcl_GetHashKey(&cdefnPtr->resolveVars, entry); + } + } + + if (nsPtr == NULL) { + break; + } + Tcl_DStringSetLength(&buffer2, 0); + Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1); + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, nsPtr->name, -1); + Tcl_DStringAppend(&buffer, "::", -1); + Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1); + + nsPtr = nsPtr->parentPtr; + } + + /* + * If this record is not needed, free it now. + */ + if (vlookup->usage == 0) { + ckfree((char*)vlookup); + } + entry = Tcl_NextHashEntry(&place); + } + cdPtr = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + /* + * Clear the command resolution table. + */ + Tcl_DeleteHashTable(&cdefnPtr->resolveCmds); + Tcl_InitHashTable(&cdefnPtr->resolveCmds, TCL_STRING_KEYS); + + /* + * Scan through all classes in the hierarchy, from most to + * least specific. Look for the first (most-specific) definition + * of each member function, and enter it into the table. + */ + Itcl_InitHierIter(&hier, cdefnPtr); + cdPtr = Itcl_AdvanceHierIter(&hier); + while (cdPtr != NULL) { + entry = Tcl_FirstHashEntry(&cdPtr->functions, &place); + while (entry) { + mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); + + /* + * Create all possible names for this function and enter + * them into the command resolution table: + * func + * class::func + * namesp1::class::func + * namesp2::namesp1::class::func + * ... + */ + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, mfunc->member->name, -1); + nsPtr = (Namespace*)cdPtr->namesp; + + while (1) { + entry = Tcl_CreateHashEntry(&cdefnPtr->resolveCmds, + Tcl_DStringValue(&buffer), &newEntry); + + if (newEntry) { + Tcl_SetHashValue(entry, (ClientData)mfunc); + } + + if (nsPtr == NULL) { + break; + } + Tcl_DStringSetLength(&buffer2, 0); + Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1); + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, nsPtr->name, -1); + Tcl_DStringAppend(&buffer, "::", -1); + Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1); + + nsPtr = nsPtr->parentPtr; + } + entry = Tcl_NextHashEntry(&place); + } + cdPtr = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + Tcl_DStringFree(&buffer); + Tcl_DStringFree(&buffer2); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_CreateVarDefn() + * + * Creates a new class variable definition. If this is a public + * variable, it may have a bit of "config" code that is used to + * update the object whenever the variable is modified via the + * built-in "configure" method. + * + * Returns TCL_ERROR along with an error message in the specified + * interpreter if anything goes wrong. Otherwise, this returns + * TCL_OK and a pointer to the new variable definition in "vdefnPtr". + * ------------------------------------------------------------------------ + */ +int +Itcl_CreateVarDefn(interp, cdefn, name, init, config, vdefnPtr) + Tcl_Interp *interp; /* interpreter managing this transaction */ + ItclClass* cdefn; /* class containing this variable */ + char* name; /* variable name */ + char* init; /* initial value */ + char* config; /* code invoked when variable is configured */ + ItclVarDefn** vdefnPtr; /* returns: new variable definition */ +{ + int newEntry; + ItclVarDefn *vdefn; + ItclMemberCode *mcode; + Tcl_HashEntry *entry; + + /* + * Add this variable to the variable table for the class. + * Make sure that the variable name does not already exist. + */ + entry = Tcl_CreateHashEntry(&cdefn->variables, name, &newEntry); + if (!newEntry) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "variable name \"", name, "\" already defined in class \"", + cdefn->fullname, "\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * If this variable has some "config" code, try to capture + * its implementation. + */ + if (config) { + if (Itcl_CreateMemberCode(interp, cdefn, (char*)NULL, config, + &mcode) != TCL_OK) { + + Tcl_DeleteHashEntry(entry); + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)mcode); + Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode); + } + else { + mcode = NULL; + } + + + /* + * If everything looks good, create the variable definition. + */ + vdefn = (ItclVarDefn*)ckalloc(sizeof(ItclVarDefn)); + vdefn->member = Itcl_CreateMember(interp, cdefn, name); + vdefn->member->code = mcode; + + if (vdefn->member->protection == ITCL_DEFAULT_PROTECT) { + vdefn->member->protection = ITCL_PROTECTED; + } + + if (init) { + vdefn->init = (char*)ckalloc((unsigned)(strlen(init)+1)); + strcpy(vdefn->init, init); + } + else { + vdefn->init = NULL; + } + + Tcl_SetHashValue(entry, (ClientData)vdefn); + + *vdefnPtr = vdefn; + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteVarDefn() + * + * Destroys a variable definition created by Itcl_CreateVarDefn(), + * freeing all resources associated with it. + * ------------------------------------------------------------------------ + */ +void +Itcl_DeleteVarDefn(vdefn) + ItclVarDefn *vdefn; /* variable definition to be destroyed */ +{ + Itcl_DeleteMember(vdefn->member); + + if (vdefn->init) { + ckfree(vdefn->init); + } + ckfree((char*)vdefn); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_GetCommonVar() + * + * Returns the current value for a common class variable. The member + * name is interpreted with respect to the given class scope. That + * scope is installed as the current context before querying the + * variable. This by-passes the protection level in case the variable + * is "private". + * + * If successful, this procedure returns a pointer to a string value + * which remains alive until the variable changes it value. If + * anything goes wrong, this returns NULL. + * ------------------------------------------------------------------------ + */ +char* +Itcl_GetCommonVar(interp, name, contextClass) + Tcl_Interp *interp; /* current interpreter */ + char *name; /* name of desired instance variable */ + ItclClass *contextClass; /* name is interpreted in this scope */ +{ + char *val = NULL; + int result; + Tcl_CallFrame frame; + + /* + * Activate the namespace for the given class. That installs + * the appropriate name resolution rules and by-passes any + * security restrictions. + */ + result = Tcl_PushCallFrame(interp, &frame, + contextClass->namesp, /*isProcCallFrame*/ 0); + + if (result == TCL_OK) { + val = Tcl_GetVar2(interp, name, (char*)NULL, 0); + Tcl_PopCallFrame(interp); + } + return val; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_CreateMember() + * + * Creates the data record representing a class member. This is the + * generic representation for a data member or member function. + * Returns a pointer to the new representation. + * ------------------------------------------------------------------------ + */ +ItclMember* +Itcl_CreateMember(interp, cdefn, name) + Tcl_Interp* interp; /* interpreter managing this action */ + ItclClass *cdefn; /* class definition */ + char* name; /* name of new member */ +{ + ItclMember *memPtr; + int fullsize; + + /* + * Allocate the memory for a class member and fill in values. + */ + memPtr = (ItclMember*)ckalloc(sizeof(ItclMember)); + memPtr->interp = interp; + memPtr->classDefn = cdefn; + memPtr->flags = 0; + memPtr->protection = Itcl_Protection(interp, 0); + memPtr->code = NULL; + + fullsize = strlen(cdefn->fullname) + strlen(name) + 2; + memPtr->fullname = (char*)ckalloc((unsigned)(fullsize+1)); + strcpy(memPtr->fullname, cdefn->fullname); + strcat(memPtr->fullname, "::"); + strcat(memPtr->fullname, name); + + memPtr->name = (char*)ckalloc((unsigned)(strlen(name)+1)); + strcpy(memPtr->name, name); + + return memPtr; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteMember() + * + * Destroys all data associated with the given member function definition. + * Usually invoked by the interpreter when a member function is deleted. + * ------------------------------------------------------------------------ + */ +void +Itcl_DeleteMember(memPtr) + ItclMember *memPtr; /* pointer to member function definition */ +{ + if (memPtr) { + ckfree(memPtr->name); + ckfree(memPtr->fullname); + + if (memPtr->code) { + Itcl_ReleaseData((ClientData)memPtr->code); + } + memPtr->code = NULL; + + ckfree((char*)memPtr); + } +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_InitHierIter() + * + * Initializes an iterator for traversing the hierarchy of the given + * class. Subsequent calls to Itcl_AdvanceHierIter() will return + * the base classes in order from most-to-least specific. + * ------------------------------------------------------------------------ + */ +void +Itcl_InitHierIter(iter,cdefn) + ItclHierIter *iter; /* iterator used for traversal */ + ItclClass *cdefn; /* class definition for start of traversal */ +{ + Itcl_InitStack(&iter->stack); + Itcl_PushStack((ClientData)cdefn, &iter->stack); + iter->current = cdefn; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteHierIter() + * + * Destroys an iterator for traversing class hierarchies, freeing + * all memory associated with it. + * ------------------------------------------------------------------------ + */ +void +Itcl_DeleteHierIter(iter) + ItclHierIter *iter; /* iterator used for traversal */ +{ + Itcl_DeleteStack(&iter->stack); + iter->current = NULL; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_AdvanceHierIter() + * + * Moves a class hierarchy iterator forward to the next base class. + * Returns a pointer to the current class definition, or NULL when + * the end of the hierarchy has been reached. + * ------------------------------------------------------------------------ + */ +ItclClass* +Itcl_AdvanceHierIter(iter) + ItclHierIter *iter; /* iterator used for traversal */ +{ + register Itcl_ListElem *elem; + ItclClass *cdPtr; + + iter->current = (ItclClass*)Itcl_PopStack(&iter->stack); + + /* + * Push classes onto the stack in reverse order, so that + * they will be popped off in the proper order. + */ + if (iter->current) { + cdPtr = (ItclClass*)iter->current; + elem = Itcl_LastListElem(&cdPtr->bases); + while (elem) { + Itcl_PushStack(Itcl_GetListValue(elem), &iter->stack); + elem = Itcl_PrevListElem(elem); + } + } + return iter->current; +}

itcl_class.c Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: itcl_cmds.c =================================================================== --- itcl_cmds.c (nonexistent) +++ itcl_cmds.c (revision 1765) @@ -0,0 +1,1359 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * This file defines information that tracks classes and objects + * at a global level for a given interpreter. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * RCS: $Id: itcl_cmds.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $ + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +/* + * FORWARD DECLARATIONS + */ +static void ItclDelObjectInfo _ANSI_ARGS_((char* cdata)); +static int Initialize _ANSI_ARGS_((Tcl_Interp *interp)); +static int ItclHandleStubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static void ItclDeleteStub _ANSI_ARGS_((ClientData cdata)); + +/* + * The following string is the startup script executed in new + * interpreters. It locates the Tcl code in the [incr Tcl] library + * directory and loads it in. + */ + +static char initScript[] = "\n\ +namespace eval ::itcl {\n\ + proc _find_init {} {\n\ + global env tcl_library\n\ + variable library\n\ + variable version\n\ + rename _find_init {}\n\ + if {[catch {uplevel #0 source -rsrc itcl}] == 0} {\n\ + return\n\ + }\n\ + tcl_findLibrary itcl 3.0 {} itcl.tcl ITCL_LIBRARY ::itcl::library {} {} itcl\n\ + }\n\ + _find_init\n\ +}"; + +/* + * The following script is used to initialize Itcl in a safe interpreter. + */ + +static char safeInitScript[] = +"proc ::itcl::local {class name args} {\n\ + set ptr [uplevel eval [list $class $name] $args]\n\ + uplevel [list set itcl-local-$ptr $ptr]\n\ + set cmd [uplevel namespace which -command $ptr]\n\ + uplevel [list trace variable itcl-local-$ptr u \"::itcl::delete object $cmd; list\"]\n\ + return $ptr\n\ +}"; + + +/* + * ------------------------------------------------------------------------ + * Initialize() + * + * Invoked whenever a new interpeter is created to install the + * [incr Tcl] package. Usually invoked within Tcl_AppInit() at + * the start of execution. + * + * Creates the "::itcl" namespace and installs access commands for + * creating classes and querying info. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error + * message in the interpreter) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +static int +Initialize(interp) + Tcl_Interp *interp; /* interpreter to be updated */ +{ + Tcl_CmdInfo cmdInfo; + Tcl_Namespace *itclNs; + ItclObjectInfo *info; + + if (Tcl_PkgRequire(interp, "Tcl", TCL_VERSION, 1) == NULL) { + return TCL_ERROR; + } + + /* + * See if [incr Tcl] is already installed. + */ + if (Tcl_GetCommandInfo(interp, "::itcl::class", &cmdInfo)) { + Tcl_SetResult(interp, "already installed: [incr Tcl]", TCL_STATIC); + return TCL_ERROR; + } + + /* + * Initialize the ensemble package first, since we need this + * for other parts of [incr Tcl]. + */ + if (Itcl_EnsembleInit(interp) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Create the top-level data structure for tracking objects. + * Store this as "associated data" for easy access, but link + * it to the itcl namespace for ownership. + */ + info = (ItclObjectInfo*)ckalloc(sizeof(ItclObjectInfo)); + info->interp = interp; + Tcl_InitHashTable(&info->objects, TCL_ONE_WORD_KEYS); + Itcl_InitStack(&info->transparentFrames); + Tcl_InitHashTable(&info->contextFrames, TCL_ONE_WORD_KEYS); + info->protection = ITCL_DEFAULT_PROTECT; + Itcl_InitStack(&info->cdefnStack); + + Tcl_SetAssocData(interp, ITCL_INTERP_DATA, + (Tcl_InterpDeleteProc*)NULL, (ClientData)info); + + /* + * Install commands into the "::itcl" namespace. + */ + Tcl_CreateObjCommand(interp, "::itcl::class", Itcl_ClassCmd, + (ClientData)info, Itcl_ReleaseData); + Itcl_PreserveData((ClientData)info); + + Tcl_CreateObjCommand(interp, "::itcl::body", Itcl_BodyCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::configbody", Itcl_ConfigBodyCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + + Itcl_EventuallyFree((ClientData)info, ItclDelObjectInfo); + + /* + * Create the "itcl::find" command for high-level queries. + */ + if (Itcl_CreateEnsemble(interp, "::itcl::find") != TCL_OK) { + return TCL_ERROR; + } + if (Itcl_AddEnsemblePart(interp, "::itcl::find", + "classes", "?pattern?", + Itcl_FindClassesCmd, + (ClientData)info, Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)info); + + if (Itcl_AddEnsemblePart(interp, "::itcl::find", + "objects", "?-class className? ?-isa className? ?pattern?", + Itcl_FindObjectsCmd, + (ClientData)info, Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)info); + + + /* + * Create the "itcl::delete" command to delete objects + * and classes. + */ + if (Itcl_CreateEnsemble(interp, "::itcl::delete") != TCL_OK) { + return TCL_ERROR; + } + if (Itcl_AddEnsemblePart(interp, "::itcl::delete", + "class", "name ?name...?", + Itcl_DelClassCmd, + (ClientData)info, Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)info); + + if (Itcl_AddEnsemblePart(interp, "::itcl::delete", + "object", "name ?name...?", + Itcl_DelObjectCmd, + (ClientData)info, Itcl_ReleaseData) != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)info); + + /* + * Add "code" and "scope" commands for handling scoped values. + */ + Tcl_CreateObjCommand(interp, "::itcl::code", Itcl_CodeCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::scope", Itcl_ScopeCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + + /* + * Add commands for handling import stubs at the Tcl level. + */ + if (Itcl_CreateEnsemble(interp, "::itcl::import::stub") != TCL_OK) { + return TCL_ERROR; + } + if (Itcl_AddEnsemblePart(interp, "::itcl::import::stub", + "create", "name", Itcl_StubCreateCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) { + return TCL_ERROR; + } + if (Itcl_AddEnsemblePart(interp, "::itcl::import::stub", + "exists", "name", Itcl_StubExistsCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Install a variable resolution procedure to handle scoped + * values everywhere within the interpreter. + */ + Tcl_AddInterpResolvers(interp, "itcl", (Tcl_ResolveCmdProc*)NULL, + Itcl_ScopedVarResolver, (Tcl_ResolveCompiledVarProc*)NULL); + + /* + * Install the "itcl::parser" namespace used to parse the + * class definitions. + */ + if (Itcl_ParseInit(interp, info) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Create "itcl::builtin" namespace for commands that + * are automatically built into class definitions. + */ + if (Itcl_BiInit(interp) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Install stuff needed for backward compatibility with previous + * version of [incr Tcl]. + */ + if (Itcl_OldInit(interp, info) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Export all commands in the "itcl" namespace so that they + * can be imported with something like "namespace import itcl::*" + */ + itclNs = Tcl_FindNamespace(interp, "::itcl", (Tcl_Namespace*)NULL, + TCL_LEAVE_ERR_MSG); + + if (!itclNs || + Tcl_Export(interp, itclNs, "*", /* resetListFirst */ 1) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Set up the variables containing version info. + */ + + Tcl_SetVar(interp, "::itcl::patchLevel", ITCL_PATCH_LEVEL, + TCL_NAMESPACE_ONLY); + + Tcl_SetVar(interp, "::itcl::version", ITCL_VERSION, + TCL_NAMESPACE_ONLY); + + /* + * Package is now loaded. + */ + if (Tcl_PkgProvide(interp, "Itcl", ITCL_VERSION) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_Init() + * + * Invoked whenever a new INTERPRETER is created to install the + * [incr Tcl] package. Usually invoked within Tcl_AppInit() at + * the start of execution. + * + * Creates the "::itcl" namespace and installs access commands for + * creating classes and querying info. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error + * message in the interpreter) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +int +Itcl_Init(interp) + Tcl_Interp *interp; /* interpreter to be updated */ +{ + if (Initialize(interp) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_Eval(interp, initScript); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_SafeInit() + * + * Invoked whenever a new SAFE INTERPRETER is created to install + * the [incr Tcl] package. + * + * Creates the "::itcl" namespace and installs access commands for + * creating classes and querying info. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error + * message in the interpreter) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +int +Itcl_SafeInit(interp) + Tcl_Interp *interp; /* interpreter to be updated */ +{ + if (Initialize(interp) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_Eval(interp, safeInitScript); +} + + +/* + * ------------------------------------------------------------------------ + * ItclDelObjectInfo() + * + * Invoked when the management info for [incr Tcl] is no longer being + * used in an interpreter. This will only occur when all class + * manipulation commands are removed from the interpreter. + * ------------------------------------------------------------------------ + */ +static void +ItclDelObjectInfo(cdata) + char* cdata; /* client data for class command */ +{ + ItclObjectInfo *info = (ItclObjectInfo*)cdata; + + ItclObject *contextObj; + Tcl_HashSearch place; + Tcl_HashEntry *entry; + + /* + * Destroy all known objects by deleting their access + * commands. + */ + entry = Tcl_FirstHashEntry(&info->objects, &place); + while (entry) { + contextObj = (ItclObject*)Tcl_GetHashValue(entry); + Tcl_DeleteCommandFromToken(info->interp, contextObj->accessCmd); + entry = Tcl_NextHashEntry(&place); + } + Tcl_DeleteHashTable(&info->objects); + + /* + * Discard all known object contexts. + */ + entry = Tcl_FirstHashEntry(&info->contextFrames, &place); + while (entry) { + Itcl_ReleaseData( Tcl_GetHashValue(entry) ); + entry = Tcl_NextHashEntry(&place); + } + Tcl_DeleteHashTable(&info->contextFrames); + + Itcl_DeleteStack(&info->transparentFrames); + Itcl_DeleteStack(&info->cdefnStack); + ckfree((char*)info); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_FindClassesCmd() + * + * Part of the "::info" ensemble. Invoked by Tcl whenever the user + * issues an "info classes" command to query the list of classes + * in the current namespace. Handles the following syntax: + * + * info classes ?? + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_FindClassesCmd(clientData, interp, objc, objv) + ClientData clientData; /* class/object info */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp); + Tcl_Namespace *globalNs = Tcl_GetGlobalNamespace(interp); + int forceFullNames = 0; + + char *pattern; + char *name; + int i, nsearch, newEntry; + Tcl_HashTable unique; + Tcl_HashEntry *entry; + Tcl_HashSearch place; + Tcl_Namespace *search[2]; + Tcl_Command cmd, originalCmd; + Namespace *nsPtr; + Tcl_Obj *listPtr, *objPtr; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; + } + + if (objc == 2) { + pattern = Tcl_GetStringFromObj(objv[1], (int*)NULL); + forceFullNames = (strstr(pattern, "::") != NULL); + } else { + pattern = NULL; + } + + /* + * Search through all commands in the current namespace and + * in the global namespace. If we find any commands that + * represent classes, report them. + */ + listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL); + + nsearch = 0; + search[nsearch++] = activeNs; + if (activeNs != globalNs) { + search[nsearch++] = globalNs; + } + + Tcl_InitHashTable(&unique, TCL_ONE_WORD_KEYS); + + for (i=0; i < nsearch; i++) { + nsPtr = (Namespace*)search[i]; + + entry = Tcl_FirstHashEntry(&nsPtr->cmdTable, &place); + while (entry) { + cmd = (Tcl_Command)Tcl_GetHashValue(entry); + if (Itcl_IsClass(cmd)) { + originalCmd = TclGetOriginalCommand(cmd); + + /* + * Report full names if: + * - the pattern has namespace qualifiers + * - the class namespace is not in the current namespace + * - the class's object creation command is imported from + * another namespace. + * + * Otherwise, report short names. + */ + if (forceFullNames || nsPtr != (Namespace*)activeNs || + originalCmd != NULL) { + + objPtr = Tcl_NewStringObj((char*)NULL, 0); + Tcl_GetCommandFullName(interp, cmd, objPtr); + name = Tcl_GetStringFromObj(objPtr, (int*)NULL); + } else { + name = Tcl_GetCommandName(interp, cmd); + objPtr = Tcl_NewStringObj(name, -1); + } + + if (originalCmd) { + cmd = originalCmd; + } + Tcl_CreateHashEntry(&unique, (char*)cmd, &newEntry); + + if (newEntry && (!pattern || Tcl_StringMatch(name, pattern))) { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + listPtr, objPtr); + } + } + entry = Tcl_NextHashEntry(&place); + } + } + Tcl_DeleteHashTable(&unique); + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_FindObjectsCmd() + * + * Part of the "::info" ensemble. Invoked by Tcl whenever the user + * issues an "info objects" command to query the list of known objects. + * Handles the following syntax: + * + * info objects ?-class ? ?-isa ? ?? + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +int +Itcl_FindObjectsCmd(clientData, interp, objc, objv) + ClientData clientData; /* class/object info */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp); + Tcl_Namespace *globalNs = Tcl_GetGlobalNamespace(interp); + int forceFullNames = 0; + + char *pattern = NULL; + ItclClass *classDefn = NULL; + ItclClass *isaDefn = NULL; + + char *name, *token; + int i, pos, nsearch, newEntry, match; + ItclObject *contextObj; + Tcl_HashTable unique; + Tcl_HashEntry *entry; + Tcl_HashSearch place; + Tcl_Namespace *search[2]; + Tcl_Command cmd, originalCmd; + Namespace *nsPtr; + Command *cmdPtr; + Tcl_Obj *listPtr, *objPtr; + + /* + * Parse arguments: + * objects ?-class ? ?-isa ? ?? + */ + pos = 0; + while (++pos < objc) { + token = Tcl_GetStringFromObj(objv[pos], (int*)NULL); + if (*token != '-') { + if (!pattern) { + pattern = token; + forceFullNames = (strstr(pattern, "::") != NULL); + } else { + break; + } + } + else if ((pos+1 < objc) && (strcmp(token,"-class") == 0)) { + name = Tcl_GetStringFromObj(objv[pos+1], (int*)NULL); + classDefn = Itcl_FindClass(interp, name, /* autoload */ 1); + if (classDefn == NULL) { + return TCL_ERROR; + } + pos++; + } + else if ((pos+1 < objc) && (strcmp(token,"-isa") == 0)) { + name = Tcl_GetStringFromObj(objv[pos+1], (int*)NULL); + isaDefn = Itcl_FindClass(interp, name, /* autoload */ 1); + if (isaDefn == NULL) { + return TCL_ERROR; + } + pos++; + } + else { + break; + } + } + + if (pos < objc) { + Tcl_WrongNumArgs(interp, 1, objv, + "?-class className? ?-isa className? ?pattern?"); + return TCL_ERROR; + } + + /* + * Search through all commands in the current namespace and + * in the global namespace. If we find any commands that + * represent objects, report them. + */ + listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL); + + nsearch = 0; + search[nsearch++] = activeNs; + if (activeNs != globalNs) { + search[nsearch++] = globalNs; + } + + Tcl_InitHashTable(&unique, TCL_ONE_WORD_KEYS); + + for (i=0; i < nsearch; i++) { + nsPtr = (Namespace*)search[i]; + + entry = Tcl_FirstHashEntry(&nsPtr->cmdTable, &place); + while (entry) { + cmd = (Tcl_Command)Tcl_GetHashValue(entry); + if (Itcl_IsObject(cmd)) { + originalCmd = TclGetOriginalCommand(cmd); + if (originalCmd) { + cmd = originalCmd; + } + cmdPtr = (Command*)cmd; + contextObj = (ItclObject*)cmdPtr->objClientData; + + /* + * Report full names if: + * - the pattern has namespace qualifiers + * - the class namespace is not in the current namespace + * - the class's object creation command is imported from + * another namespace. + * + * Otherwise, report short names. + */ + if (forceFullNames || nsPtr != (Namespace*)activeNs || + originalCmd != NULL) { + + objPtr = Tcl_NewStringObj((char*)NULL, 0); + Tcl_GetCommandFullName(interp, cmd, objPtr); + name = Tcl_GetStringFromObj(objPtr, (int*)NULL); + } else { + name = Tcl_GetCommandName(interp, cmd); + objPtr = Tcl_NewStringObj(name, -1); + } + + Tcl_CreateHashEntry(&unique, (char*)cmd, &newEntry); + + match = 0; + if (newEntry && (!pattern || Tcl_StringMatch(name, pattern))) { + if (!classDefn || (contextObj->classDefn == classDefn)) { + if (!isaDefn) { + match = 1; + } else { + entry = Tcl_FindHashEntry( + &contextObj->classDefn->heritage, + (char*)isaDefn); + + if (entry) { + match = 1; + } + } + } + } + + if (match) { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, + listPtr, objPtr); + } else { + Tcl_IncrRefCount(objPtr); /* throw away the name */ + Tcl_DecrRefCount(objPtr); + } + } + entry = Tcl_NextHashEntry(&place); + } + } + Tcl_DeleteHashTable(&unique); + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ProtectionCmd() + * + * Invoked by Tcl whenever the user issues a protection setting + * command like "public" or "private". Creates commands and + * variables, and assigns a protection level to them. Protection + * levels are defined as follows: + * + * public => accessible from any namespace + * protected => accessible from selected namespaces + * private => accessible only in the namespace where it was defined + * + * Handles the following syntax: + * + * public ? ...? + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +int +Itcl_ProtectionCmd(clientData, interp, objc, objv) + ClientData clientData; /* protection level (public/protected/private) */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + int pLevel = (int)clientData; + + int result; + int oldLevel; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "command ?arg arg...?"); + return TCL_ERROR; + } + + oldLevel = Itcl_Protection(interp, pLevel); + + if (objc == 2) { + /* CYGNUS LOCAL - Fix for 8.1 */ +#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + result = Tcl_EvalObj(interp, objv[1]); +#else + result = Tcl_EvalObj(interp, objv[1], 0); +#endif + /* END CYGNUS LOCAL */ + } else { + result = Itcl_EvalArgs(interp, objc-1, objv+1); + } + + if (result == TCL_BREAK) { + Tcl_SetResult(interp, "invoked \"break\" outside of a loop", + TCL_STATIC); + result = TCL_ERROR; + } + else if (result == TCL_CONTINUE) { + Tcl_SetResult(interp, "invoked \"continue\" outside of a loop", + TCL_STATIC); + result = TCL_ERROR; + } + else if (result != TCL_OK) { + char mesg[256], *name; + name = Tcl_GetStringFromObj(objv[0], (int*)NULL); + sprintf(mesg, "\n (%.100s body line %d)", + name, interp->errorLine); + Tcl_AddErrorInfo(interp, mesg); + } + + Itcl_Protection(interp, oldLevel); + return result; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_DelClassCmd() + * + * Part of the "delete" ensemble. Invoked by Tcl whenever the + * user issues a "delete class" command to delete classes. + * Handles the following syntax: + * + * delete class ?...? + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_DelClassCmd(clientData, interp, objc, objv) + ClientData clientData; /* unused */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + int i; + char *name; + ItclClass *cdefn; + + /* + * Since destroying a base class will destroy all derived + * classes, calls like "destroy class Base Derived" could + * fail. Break this into two passes: first check to make + * sure that all classes on the command line are valid, + * then delete them. + */ + for (i=1; i < objc; i++) { + name = Tcl_GetStringFromObj(objv[i], (int*)NULL); + cdefn = Itcl_FindClass(interp, name, /* autoload */ 1); + if (cdefn == NULL) { + return TCL_ERROR; + } + } + + for (i=1; i < objc; i++) { + name = Tcl_GetStringFromObj(objv[i], (int*)NULL); + cdefn = Itcl_FindClass(interp, name, /* autoload */ 0); + + if (cdefn) { + Tcl_ResetResult(interp); + if (Itcl_DeleteClass(interp, cdefn) != TCL_OK) { + return TCL_ERROR; + } + } + } + Tcl_ResetResult(interp); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_DelObjectCmd() + * + * Part of the "delete" ensemble. Invoked by Tcl whenever the user + * issues a "delete object" command to delete [incr Tcl] objects. + * Handles the following syntax: + * + * delete object ?...? + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +int +Itcl_DelObjectCmd(clientData, interp, objc, objv) + ClientData clientData; /* object management info */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + int i; + char *name; + ItclObject *contextObj; + + /* + * Scan through the list of objects and attempt to delete them. + * If anything goes wrong (i.e., destructors fail), then + * abort with an error. + */ + for (i=1; i < objc; i++) { + name = Tcl_GetStringFromObj(objv[i], (int*)NULL); + if (Itcl_FindObject(interp, name, &contextObj) != TCL_OK) { + return TCL_ERROR; + } + + if (contextObj == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "object \"", name, "\" not found", + (char*)NULL); + return TCL_ERROR; + } + + if (Itcl_DeleteObject(interp, contextObj) != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ScopeCmd() + * + * Invoked by Tcl whenever the user issues a "scope" command to + * create a fully qualified variable name. Handles the following + * syntax: + * + * scope + * + * If the input string is already fully qualified (starts with "::"), + * then this procedure does nothing. Otherwise, it looks for a + * data member called and returns its fully qualified + * name. If the is a common data member, this procedure + * returns a name of the form: + * + * ::namesp::namesp::class::variable + * + * If the is an instance variable, this procedure returns + * a name of the form: + * + * @itcl ::namesp::namesp::object variable + * + * This kind of scoped value is recognized by the Itcl_ScopedVarResolver + * proc, which handles variable resolution for the entire interpreter. + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_ScopeCmd(dummy, interp, objc, objv) + ClientData dummy; /* unused */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + int result = TCL_OK; + Tcl_Namespace *contextNs = Tcl_GetCurrentNamespace(interp); + char *openParen = NULL; + + register char *p; + char *token; + ItclClass *contextClass; + ItclObject *contextObj; + ItclObjectInfo *info; + Tcl_CallFrame *framePtr; + Tcl_HashEntry *entry; + ItclVarLookup *vlookup; + Tcl_Obj *objPtr; + Tcl_Var var; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "varname"); + return TCL_ERROR; + } + + /* + * If this looks like a fully qualified name already, + * then return it as is. + */ + token = Tcl_GetStringFromObj(objv[1], (int*)NULL); + if (*token == ':' && *(token+1) == ':') { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } + + /* + * If the variable name is an array reference, pick out + * the array name and use that for the lookup operations + * below. + */ + for (p=token; *p != '\0'; p++) { + if (*p == '(') { + openParen = p; + } + else if (*p == ')' && openParen) { + *openParen = '\0'; + break; + } + } + + /* + * Figure out what context we're in. If this is a class, + * then look up the variable in the class definition. + * If this is a namespace, then look up the variable in its + * varTable. Note that the normal Itcl_GetContext function + * returns an error if we're not in a class context, so we + * perform a similar function here, the hard way. + * + * TRICKY NOTE: If this is an array reference, we'll get + * the array variable as the variable name. We must be + * careful to add the index (everything from openParen + * onward) as well. + */ + if (Itcl_IsClassNamespace(contextNs)) { + contextClass = (ItclClass*)contextNs->clientData; + + entry = Tcl_FindHashEntry(&contextClass->resolveVars, token); + if (!entry) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "variable \"", token, "\" not found in class \"", + contextClass->fullname, "\"", + (char*)NULL); + result = TCL_ERROR; + goto scopeCmdDone; + } + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + + if (vlookup->vdefn->member->flags & ITCL_COMMON) { + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + Tcl_AppendToObj(resultPtr, vlookup->vdefn->member->fullname, -1); + if (openParen) { + *openParen = '('; + Tcl_AppendToObj(resultPtr, openParen, -1); + openParen = NULL; + } + result = TCL_OK; + goto scopeCmdDone; + } + + /* + * If this is not a common variable, then we better have + * an object context. Return the name "@itcl object variable". + */ + framePtr = _Tcl_GetCallFrame(interp, 0); + info = contextClass->info; + + entry = Tcl_FindHashEntry(&info->contextFrames, (char*)framePtr); + if (!entry) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't scope variable \"", token, + "\": missing object context\"", + (char*)NULL); + result = TCL_ERROR; + goto scopeCmdDone; + } + contextObj = (ItclObject*)Tcl_GetHashValue(entry); + + Tcl_AppendElement(interp, "@itcl"); + + objPtr = Tcl_NewStringObj((char*)NULL, 0); + Tcl_IncrRefCount(objPtr); + Tcl_GetCommandFullName(interp, contextObj->accessCmd, objPtr); + Tcl_AppendElement(interp, Tcl_GetStringFromObj(objPtr, (int*)NULL)); + Tcl_DecrRefCount(objPtr); + + objPtr = Tcl_NewStringObj((char*)NULL, 0); + Tcl_IncrRefCount(objPtr); + Tcl_AppendToObj(objPtr, vlookup->vdefn->member->fullname, -1); + + if (openParen) { + *openParen = '('; + Tcl_AppendToObj(objPtr, openParen, -1); + openParen = NULL; + } + Tcl_AppendElement(interp, Tcl_GetStringFromObj(objPtr, (int*)NULL)); + Tcl_DecrRefCount(objPtr); + } + + /* + * We must be in an ordinary namespace context. Resolve + * the variable using Tcl_FindNamespaceVar. + * + * TRICKY NOTE: If this is an array reference, we'll get + * the array variable as the variable name. We must be + * careful to add the index (everything from openParen + * onward) as well. + */ + else { + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + + var = Tcl_FindNamespaceVar(interp, token, contextNs, + TCL_NAMESPACE_ONLY); + + if (!var) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "variable \"", token, "\" not found in namespace \"", + contextNs->fullName, "\"", + (char*)NULL); + result = TCL_ERROR; + goto scopeCmdDone; + } + + Tcl_GetVariableFullName(interp, var, resultPtr); + if (openParen) { + *openParen = '('; + Tcl_AppendToObj(resultPtr, openParen, -1); + openParen = NULL; + } + } + +scopeCmdDone: + if (openParen) { + *openParen = '('; + } + return result; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_CodeCmd() + * + * Invoked by Tcl whenever the user issues a "code" command to + * create a scoped command string. Handles the following syntax: + * + * code ?-namespace foo? arg ?arg arg ...? + * + * Unlike the scope command, the code command DOES NOT look for + * scoping information at the beginning of the command. So scopes + * will nest in the code command. + * + * The code command is similar to the "namespace code" command in + * Tcl, but it preserves the list structure of the input arguments, + * so it is a lot more useful. + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_CodeCmd(dummy, interp, objc, objv) + ClientData dummy; /* unused */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + Tcl_Namespace *contextNs = Tcl_GetCurrentNamespace(interp); + + int pos; + char *token; + Tcl_Obj *listPtr, *objPtr; + + /* + * Handle flags like "-namespace"... + */ + for (pos=1; pos < objc; pos++) { + token = Tcl_GetStringFromObj(objv[pos], (int*)NULL); + if (*token != '-') { + break; + } + + if (strcmp(token, "-namespace") == 0) { + if (objc == 2) { + Tcl_WrongNumArgs(interp, 1, objv, + "?-namespace name? command ?arg arg...?"); + return TCL_ERROR; + } else { + token = Tcl_GetStringFromObj(objv[pos+1], (int*)NULL); + contextNs = Tcl_FindNamespace(interp, token, + (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); + + if (!contextNs) { + return TCL_ERROR; + } + pos++; + } + } + else if (strcmp(token, "--") == 0) { + pos++; + break; + } + else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option \"", token, "\": should be -namespace or --", + (char*)NULL); + return TCL_ERROR; + } + } + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, + "?-namespace name? command ?arg arg...?"); + return TCL_ERROR; + } + + /* + * Now construct a scoped command by integrating the + * current namespace context, and appending the remaining + * arguments AS A LIST... + */ + listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("namespace", -1)); + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj("inscope", -1)); + + if (contextNs == Tcl_GetGlobalNamespace(interp)) { + objPtr = Tcl_NewStringObj("::", -1); + } else { + objPtr = Tcl_NewStringObj(contextNs->fullName, -1); + } + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + + if (objc-pos == 1) { + objPtr = objv[pos]; + } else { + objPtr = Tcl_NewListObj(objc-pos, &objv[pos]); + } + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_StubCreateCmd() + * + * Invoked by Tcl whenever the user issues a "stub create" command to + * create an autoloading stub for imported commands. Handles the + * following syntax: + * + * stub create + * + * Creates a command called . Executing this command will cause + * the real command to be autoloaded. + * ------------------------------------------------------------------------ + */ +int +Itcl_StubCreateCmd(clientData, interp, objc, objv) + ClientData clientData; /* not used */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + char *cmdName; + Command *cmdPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + cmdName = Tcl_GetStringFromObj(objv[1], (int*)NULL); + + /* + * Create a stub command with the characteristic ItclDeleteStub + * procedure. That way, we can recognize this command later + * on as a stub. Save the cmd token as client data, so we can + * get the full name of this command later on. + */ + cmdPtr = (Command *) Tcl_CreateObjCommand(interp, cmdName, + ItclHandleStubCmd, (ClientData)NULL, + (Tcl_CmdDeleteProc*)ItclDeleteStub); + + cmdPtr->objClientData = (ClientData) cmdPtr; + + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_StubExistsCmd() + * + * Invoked by Tcl whenever the user issues a "stub exists" command to + * see if an existing command is an autoloading stub. Handles the + * following syntax: + * + * stub exists + * + * Looks for a command called and checks to see if it is an + * autoloading stub. Returns a boolean result. + * ------------------------------------------------------------------------ + */ +int +Itcl_StubExistsCmd(clientData, interp, objc, objv) + ClientData clientData; /* not used */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + char *cmdName; + Tcl_Command cmd; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + cmdName = Tcl_GetStringFromObj(objv[1], (int*)NULL); + + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace*)NULL, 0); + + if (cmd != NULL && Itcl_IsStub(cmd)) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_IsStub() + * + * Checks the given Tcl command to see if it represents an autoloading + * stub created by the "stub create" command. Returns non-zero if + * the command is indeed a stub. + * ------------------------------------------------------------------------ + */ +int +Itcl_IsStub(cmd) + Tcl_Command cmd; /* command being tested */ +{ + Command *cmdPtr = (Command*)cmd; + + /* + * This may be an imported command, but don't try to get the + * original. Just check to see if this particular command + * is a stub. If we really want the original command, we'll + * find it at a higher level. + */ + if (cmdPtr->deleteProc == ItclDeleteStub) { + return 1; + } + return 0; +} + + +/* + * ------------------------------------------------------------------------ + * ItclHandleStubCmd() + * + * Invoked by Tcl to handle commands created by "stub create". + * Calls "auto_load" with the full name of the current command to + * trigger autoloading of the real implementation. Then, calls the + * command to handle its function. If successful, this command + * returns TCL_OK along with the result from the real implementation + * of this command. Otherwise, it returns TCL_ERROR, along with an + * error message in the interpreter. + * ------------------------------------------------------------------------ + */ +static int +ItclHandleStubCmd(clientData, interp, objc, objv) + ClientData clientData; /* command token for this stub */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + Tcl_Command cmd = (Tcl_Command) clientData; + + int result, loaded; + char *cmdName; + int cmdlinec; + Tcl_Obj **cmdlinev; + Tcl_Obj *objAutoLoad[2], *objPtr, *cmdNamePtr, *cmdlinePtr; + + cmdNamePtr = Tcl_NewStringObj((char*)NULL, 0); + Tcl_GetCommandFullName(interp, cmd, cmdNamePtr); + Tcl_IncrRefCount(cmdNamePtr); + cmdName = Tcl_GetStringFromObj(cmdNamePtr, (int*)NULL); + + /* + * Try to autoload the real command for this stub. + */ + objAutoLoad[0] = Tcl_NewStringObj("::auto_load", -1); + Tcl_IncrRefCount(objAutoLoad[0]); + objAutoLoad[1] = cmdNamePtr; + Tcl_IncrRefCount(objAutoLoad[1]); + + result = Itcl_EvalArgs(interp, 2, objAutoLoad); + + Tcl_DecrRefCount(objAutoLoad[0]); + Tcl_DecrRefCount(objAutoLoad[1]); + + if (result != TCL_OK) { + Tcl_DecrRefCount(cmdNamePtr); + return TCL_ERROR; + } + + objPtr = Tcl_GetObjResult(interp); + result = Tcl_GetIntFromObj(interp, objPtr, &loaded); + if (result != TCL_OK || !loaded) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't autoload \"", cmdName, "\"", (char*)NULL); + Tcl_DecrRefCount(cmdNamePtr); + return TCL_ERROR; + } + + /* + * At this point, the real implementation has been loaded. + * Invoke the command again with the arguments passed in. + */ + cmdlinePtr = Itcl_CreateArgs(interp, cmdName, objc-1, objv+1); + + (void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr, + &cmdlinec, &cmdlinev); + + Tcl_ResetResult(interp); + result = Itcl_EvalArgs(interp, cmdlinec, cmdlinev); + Tcl_DecrRefCount(cmdlinePtr); + + return result; +} + + +/* + * ------------------------------------------------------------------------ + * ItclDeleteStub() + * + * Invoked by Tcl whenever a stub command is deleted. This procedure + * does nothing, but its presence identifies a command as a stub. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static void +ItclDeleteStub(cdata) + ClientData cdata; /* not used */ +{ + /* do nothing */ +}

itcl_cmds.c Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: itcl_migrate.c =================================================================== --- itcl_migrate.c (nonexistent) +++ itcl_migrate.c (revision 1765) @@ -0,0 +1,139 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * This file contains procedures that belong in the Tcl/Tk core. + * Hopefully, they'll migrate there soon. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * RCS: $Id: itcl_migrate.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $ + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + + +/* + *---------------------------------------------------------------------- + * + * _Tcl_GetCallFrame -- + * + * Checks the call stack and returns the call frame some number + * of levels up. It is often useful to know the invocation + * context for a command. + * + * Results: + * Returns a token for the call frame 0 or more levels up in + * the call stack. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_CallFrame* +_Tcl_GetCallFrame(interp, level) + Tcl_Interp *interp; /* interpreter being queried */ + int level; /* number of levels up in the call stack (>= 0) */ +{ + Interp *iPtr = (Interp*)interp; + CallFrame *framePtr; + + if (level < 0) { + panic("itcl: _Tcl_GetCallFrame called with bad number of levels"); + } + + framePtr = iPtr->varFramePtr; + while (framePtr && level > 0) { + framePtr = framePtr->callerVarPtr; + level--; + } + return (Tcl_CallFrame*)framePtr; +} + + +/* + *---------------------------------------------------------------------- + * + * _Tcl_ActivateCallFrame -- + * + * Makes an existing call frame the current frame on the + * call stack. Usually called in conjunction with + * _Tcl_GetCallFrame to simulate the effect of an "uplevel" + * command. + * + * Note that this procedure is different from Tcl_PushCallFrame, + * which adds a new call frame to the call stack. This procedure + * assumes that the call frame is already initialized, and it + * merely activates it on the call stack. + * + * Results: + * Returns a token for the call frame that was in effect before + * activating the new context. That call frame can be restored + * by calling _Tcl_ActivateCallFrame again. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_CallFrame* +_Tcl_ActivateCallFrame(interp, framePtr) + Tcl_Interp *interp; /* interpreter being queried */ + Tcl_CallFrame *framePtr; /* call frame to be activated */ +{ + Interp *iPtr = (Interp*)interp; + CallFrame *oldFramePtr; + + oldFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = (CallFrame *) framePtr; + + return (Tcl_CallFrame *) oldFramePtr; +} + +/* + *---------------------------------------------------------------------- + * + * _TclNewVar -- + * + * Create a new heap-allocated variable that will eventually be + * entered into a hashtable. + * + * Results: + * The return value is a pointer to the new variable structure. It is + * marked as a scalar variable (and not a link or array variable). Its + * value initially is NULL. The variable is not part of any hash table + * yet. Since it will be in a hashtable and not in a call frame, its + * name field is set NULL. It is initially marked as undefined. + * + * Side effects: + * Storage gets allocated. + * + *---------------------------------------------------------------------- + */ + +Var * +_TclNewVar() +{ + register Var *varPtr; + + varPtr = (Var *) ckalloc(sizeof(Var)); + varPtr->value.objPtr = NULL; + varPtr->name = NULL; + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE); + return varPtr; +}

itcl_migrate.c Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: itcl_objects.c =================================================================== --- itcl_objects.c (nonexistent) +++ itcl_objects.c (revision 1765) @@ -0,0 +1,1208 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * This segment handles "objects" which are instantiated from class + * definitions. Objects contain public/protected/private data members + * from all classes in a derivation hierarchy. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * RCS: $Id: itcl_objects.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $ + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +/* + * FORWARD DECLARATIONS + */ +static void ItclReportObjectUsage _ANSI_ARGS_((Tcl_Interp *interp, + ItclObject* obj)); + +static char* ItclTraceThisVar _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, char *name1, char *name2, int flags)); + +static void ItclDestroyObject _ANSI_ARGS_((ClientData cdata)); +static void ItclFreeObject _ANSI_ARGS_((char* cdata)); + +static int ItclDestructBase _ANSI_ARGS_((Tcl_Interp *interp, + ItclObject* obj, ItclClass* cdefn, int flags)); + +static void ItclCreateObjVar _ANSI_ARGS_((Tcl_Interp *interp, + ItclVarDefn* vdefn, ItclObject* obj)); + + +/* + * ------------------------------------------------------------------------ + * Itcl_CreateObject() + * + * Creates a new object instance belonging to the given class. + * Supports complex object names like "namesp::namesp::name" by + * following the namespace path and creating the object in the + * desired namespace. + * + * Automatically creates and initializes data members, including the + * built-in protected "this" variable containing the object name. + * Installs an access command in the current namespace, and invokes + * the constructor to initialize the object. + * + * If any errors are encountered, the object is destroyed and this + * procedure returns TCL_ERROR (along with an error message in the + * interpreter). Otherwise, it returns TCL_OK, along with a pointer + * to the new object data in roPtr. + * ------------------------------------------------------------------------ + */ +int +Itcl_CreateObject(interp, name, cdefn, objc, objv, roPtr) + Tcl_Interp *interp; /* interpreter mananging new object */ + char* name; /* name of new object */ + ItclClass *cdefn; /* class for new object */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ + ItclObject **roPtr; /* returns: pointer to object data */ +{ + ItclClass *cdefnPtr = (ItclClass*)cdefn; + int result = TCL_OK; + + char *head, *tail; + Tcl_DString buffer, objName; + Tcl_Namespace *parentNs; + ItclContext context; + Tcl_Command cmd; + ItclObject *newObj; + ItclClass *cdPtr; + ItclVarDefn *vdefn; + ItclHierIter hier; + Tcl_HashEntry *entry; + Tcl_HashSearch place; + int newEntry; + Itcl_InterpState istate; + + /* + * If installing an object access command will clobber another + * command, signal an error. + */ + cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace*)NULL, /* flags */ 0); + if (cmd != NULL && !Itcl_IsStub(cmd)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "command \"", name, "\" already exists in namespace \"", + Tcl_GetCurrentNamespace(interp)->fullName, "\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Extract the namespace context and the simple object + * name for the new object. + */ + Itcl_ParseNamespPath(name, &buffer, &head, &tail); + if (head) { + parentNs = Itcl_FindClassNamespace(interp, head); + + if (!parentNs) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "namespace \"", head, "\" not found in context \"", + Tcl_GetCurrentNamespace(interp)->fullName, "\"", + (char*)NULL); + Tcl_DStringFree(&buffer); + return TCL_ERROR; + } + } else { + parentNs = Tcl_GetCurrentNamespace(interp); + } + + Tcl_DStringInit(&objName); + if (parentNs != Tcl_GetGlobalNamespace(interp)) { + Tcl_DStringAppend(&objName, parentNs->fullName, -1); + } + Tcl_DStringAppend(&objName, "::", -1); + Tcl_DStringAppend(&objName, tail, -1); + + /* + * Create a new object and initialize it. + */ + newObj = (ItclObject*)ckalloc(sizeof(ItclObject)); + newObj->classDefn = cdefnPtr; + Itcl_PreserveData((ClientData)cdefnPtr); + + newObj->dataSize = cdefnPtr->numInstanceVars; + newObj->data = (Var**)ckalloc((unsigned)(newObj->dataSize*sizeof(Var*))); + + newObj->constructed = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(newObj->constructed, TCL_STRING_KEYS); + newObj->destructed = NULL; + + /* + * Add a command to the current namespace with the object name. + * This is done before invoking the constructors so that the + * command can be used during construction to query info. + */ + Itcl_PreserveData((ClientData)newObj); + newObj->accessCmd = Tcl_CreateObjCommand(interp, + Tcl_DStringValue(&objName), Itcl_HandleInstance, + (ClientData)newObj, ItclDestroyObject); + + Itcl_PreserveData((ClientData)newObj); /* while we're using this... */ + Itcl_EventuallyFree((ClientData)newObj, ItclFreeObject); + + Tcl_DStringFree(&buffer); + Tcl_DStringFree(&objName); + + /* + * Install the class namespace and object context so that + * the object's data members can be initialized via simple + * "set" commands. + */ + if (Itcl_PushContext(interp, (ItclMember*)NULL, cdefnPtr, newObj, + &context) != TCL_OK) { + + return TCL_ERROR; + } + + Itcl_InitHierIter(&hier, cdefn); + + cdPtr = Itcl_AdvanceHierIter(&hier); + while (cdPtr != NULL) { + entry = Tcl_FirstHashEntry(&cdPtr->variables, &place); + while (entry) { + vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry); + if ((vdefn->member->flags & ITCL_THIS_VAR) != 0) { + if (cdPtr == cdefnPtr) { + ItclCreateObjVar(interp, vdefn, newObj); + Tcl_SetVar2(interp, "this", (char*)NULL, "", 0); + Tcl_TraceVar2(interp, "this", (char*)NULL, + TCL_TRACE_READS|TCL_TRACE_WRITES, ItclTraceThisVar, + (ClientData)newObj); + } + } + else if ( (vdefn->member->flags & ITCL_COMMON) == 0) { + ItclCreateObjVar(interp, vdefn, newObj); + } + entry = Tcl_NextHashEntry(&place); + } + cdPtr = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + Itcl_PopContext(interp, &context); /* back to calling context */ + + /* + * Now construct the object. Look for a constructor in the + * most-specific class, and if there is one, invoke it. + * This will cause a chain reaction, making sure that all + * base classes constructors are invoked as well, in order + * from least- to most-specific. Any constructors that are + * not called out explicitly in "initCode" code fragments are + * invoked implicitly without arguments. + */ + result = Itcl_InvokeMethodIfExists(interp, "constructor", + cdefn, newObj, objc, objv); + + /* + * If there is no constructor, construct the base classes + * in case they have constructors. This will cause the + * same chain reaction. + */ + if (!Tcl_FindHashEntry(&cdefn->functions, "constructor")) { + result = Itcl_ConstructBase(interp, newObj, cdefn); + } + + /* + * If construction failed, then delete the object access + * command. This will destruct the object and delete the + * object data. Be careful to save and restore the interpreter + * state, since the destructors may generate errors of their own. + */ + if (result != TCL_OK) { + istate = Itcl_SaveInterpState(interp, result); + if (newObj->accessCmd != NULL) { + Tcl_DeleteCommandFromToken(interp, newObj->accessCmd); + newObj->accessCmd = NULL; + } + result = Itcl_RestoreInterpState(interp, istate); + } + + /* + * At this point, the object is fully constructed. + * Destroy the "constructed" table in the object data, since + * it is no longer needed. + */ + Tcl_DeleteHashTable(newObj->constructed); + ckfree((char*)newObj->constructed); + newObj->constructed = NULL; + + /* + * Add it to the list of all known objects. The only + * tricky thing to watch out for is the case where the + * object deleted itself inside its own constructor. + * In that case, we don't want to add the object to + * the list of valid objects. We can determine that + * the object deleted itself by checking to see if its + * accessCmd member is NULL. + */ + if ((result == TCL_OK) && (newObj->accessCmd != NULL)) { + entry = Tcl_CreateHashEntry(&cdefnPtr->info->objects, + (char*)newObj->accessCmd, &newEntry); + + Tcl_SetHashValue(entry, (ClientData)newObj); + } + + /* + * Release the object. If it was destructed above, it will + * die at this point. + */ + Itcl_ReleaseData((ClientData)newObj); + + *roPtr = newObj; + return result; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteObject() + * + * Attempts to delete an object by invoking its destructor. + * + * If the destructor is successful, then the object is deleted by + * removing its access command, and this procedure returns TCL_OK. + * Otherwise, the object will remain alive, and this procedure + * returns TCL_ERROR (along with an error message in the interpreter). + * ------------------------------------------------------------------------ + */ +int +Itcl_DeleteObject(interp, contextObj) + Tcl_Interp *interp; /* interpreter mananging object */ + ItclObject *contextObj; /* object to be deleted */ +{ + ItclClass *cdefnPtr = (ItclClass*)contextObj->classDefn; + + Tcl_HashEntry *entry; + Command *cmdPtr; + + Itcl_PreserveData((ClientData)contextObj); + + /* + * Invoke the object's destructors. + */ + if (Itcl_DestructObject(interp, contextObj, 0) != TCL_OK) { + Itcl_ReleaseData((ClientData)contextObj); + return TCL_ERROR; + } + + /* + * Remove the object from the global list. + */ + entry = Tcl_FindHashEntry(&cdefnPtr->info->objects, + (char*)contextObj->accessCmd); + + if (entry) { + Tcl_DeleteHashEntry(entry); + } + + /* + * Change the object's access command so that it can be + * safely deleted without attempting to destruct the object + * again. Then delete the access command. If this is + * the last use of the object data, the object will die here. + */ + cmdPtr = (Command*)contextObj->accessCmd; + cmdPtr->deleteProc = Itcl_ReleaseData; + + Tcl_DeleteCommandFromToken(interp, contextObj->accessCmd); + contextObj->accessCmd = NULL; + + Itcl_ReleaseData((ClientData)contextObj); /* object should die here */ + + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_DestructObject() + * + * Invokes the destructor for a particular object. Usually invoked + * by Itcl_DeleteObject() or Itcl_DestroyObject() as a part of the + * object destruction process. If the ITCL_IGNORE_ERRS flag is + * included, all destructors are invoked even if errors are + * encountered, and the result will always be TCL_OK. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error + * message in the interpreter) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +int +Itcl_DestructObject(interp, contextObj, flags) + Tcl_Interp *interp; /* interpreter mananging new object */ + ItclObject *contextObj; /* object to be destructed */ + int flags; /* flags: ITCL_IGNORE_ERRS */ +{ + int result; + + /* + * If there is a "destructed" table, then this object is already + * being destructed. Flag an error, unless errors are being + * ignored. + */ + if (contextObj->destructed) { + if ((flags & ITCL_IGNORE_ERRS) == 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't delete an object while it is being destructed", + (char*)NULL); + return TCL_ERROR; + } + return TCL_OK; + } + + /* + * Create a "destructed" table to keep track of which destructors + * have been invoked. This is used in ItclDestructBase to make + * sure that all base class destructors have been called, + * explicitly or implicitly. + */ + contextObj->destructed = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(contextObj->destructed, TCL_STRING_KEYS); + + /* + * Destruct the object starting from the most-specific class. + * If all goes well, return the null string as the result. + */ + result = ItclDestructBase(interp, contextObj, contextObj->classDefn, flags); + + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } + + Tcl_DeleteHashTable(contextObj->destructed); + ckfree((char*)contextObj->destructed); + contextObj->destructed = NULL; + + return result; +} + +/* + * ------------------------------------------------------------------------ + * ItclDestructBase() + * + * Invoked by Itcl_DestructObject() to recursively destruct an object + * from the specified class level. Finds and invokes the destructor + * for the specified class, and then recursively destructs all base + * classes. If the ITCL_IGNORE_ERRS flag is included, all destructors + * are invoked even if errors are encountered, and the result will + * always be TCL_OK. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error message + * in interp->result) on error. + * ------------------------------------------------------------------------ + */ +static int +ItclDestructBase(interp, contextObj, contextClass, flags) + Tcl_Interp *interp; /* interpreter */ + ItclObject *contextObj; /* object being destructed */ + ItclClass *contextClass; /* current class being destructed */ + int flags; /* flags: ITCL_IGNORE_ERRS */ +{ + int result; + Itcl_ListElem *elem; + ItclClass *cdefn; + + /* + * Look for a destructor in this class, and if found, + * invoke it. + */ + if (!Tcl_FindHashEntry(contextObj->destructed, contextClass->name)) { + + result = Itcl_InvokeMethodIfExists(interp, "destructor", + contextClass, contextObj, 0, (Tcl_Obj* CONST*)NULL); + + if (result != TCL_OK) { + return TCL_ERROR; + } + } + + /* + * Scan through the list of base classes recursively and destruct + * them. Traverse the list in normal order, so that we destruct + * from most- to least-specific. + */ + elem = Itcl_FirstListElem(&contextClass->bases); + while (elem) { + cdefn = (ItclClass*)Itcl_GetListValue(elem); + + if (ItclDestructBase(interp, contextObj, cdefn, flags) != TCL_OK) { + return TCL_ERROR; + } + elem = Itcl_NextListElem(elem); + } + + /* + * Throw away any result from the destructors and return. + */ + Tcl_ResetResult(interp); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_FindObject() + * + * Searches for an object with the specified name, which have + * namespace scope qualifiers like "namesp::namesp::name", or may + * be a scoped value such as "namespace inscope ::foo obj". + * + * If an error is encountered, this procedure returns TCL_ERROR + * along with an error message in the interpreter. Otherwise, it + * returns TCL_OK. If an object was found, "roPtr" returns a + * pointer to the object data. Otherwise, it returns NULL. + * ------------------------------------------------------------------------ + */ +int +Itcl_FindObject(interp, name, roPtr) + Tcl_Interp *interp; /* interpreter containing this object */ + char *name; /* name of the object */ + ItclObject **roPtr; /* returns: object data or NULL */ +{ + Tcl_Namespace *contextNs = NULL; + + char *cmdName; + Tcl_Command cmd; + Command *cmdPtr; + + /* + * The object name may be a scoped value of the form + * "namespace inscope ". If it is, + * decode it. + */ + if (Itcl_DecodeScopedCommand(interp, name, &contextNs, &cmdName) + != TCL_OK) { + return TCL_ERROR; + } + + /* + * Look for the object's access command, and see if it has + * the appropriate command handler. + */ + cmd = Tcl_FindCommand(interp, cmdName, contextNs, /* flags */ 0); + if (cmd != NULL && Itcl_IsObject(cmd)) { + cmdPtr = (Command*)cmd; + *roPtr = (ItclObject*)cmdPtr->objClientData; + } + else { + *roPtr = NULL; + } + + if (cmdName != name) { + ckfree(cmdName); + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_IsObject() + * + * Checks the given Tcl command to see if it represents an itcl object. + * Returns non-zero if the command is associated with an object. + * ------------------------------------------------------------------------ + */ +int +Itcl_IsObject(cmd) + Tcl_Command cmd; /* command being tested */ +{ + Command *cmdPtr = (Command*)cmd; + + if (cmdPtr->deleteProc == ItclDestroyObject) { + return 1; + } + + /* + * This may be an imported command. Try to get the real + * command and see if it represents an object. + */ + cmdPtr = (Command*)TclGetOriginalCommand(cmd); + if (cmdPtr && cmdPtr->deleteProc == ItclDestroyObject) { + return 1; + } + return 0; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ObjectIsa() + * + * Checks to see if an object belongs to the given class. An object + * "is-a" member of the class if the class appears anywhere in its + * inheritance hierarchy. Returns non-zero if the object belongs to + * the class, and zero otherwise. + * ------------------------------------------------------------------------ + */ +int +Itcl_ObjectIsa(contextObj, cdefn) + ItclObject *contextObj; /* object being tested */ + ItclClass *cdefn; /* class to test for "is-a" relationship */ +{ + Tcl_HashEntry *entry; + entry = Tcl_FindHashEntry(&contextObj->classDefn->heritage, (char*)cdefn); + return (entry != NULL); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_HandleInstance() + * + * Invoked by Tcl whenever the user issues a command associated with + * an object instance. Handles the following syntax: + * + * ... + * + * ------------------------------------------------------------------------ + */ +int +Itcl_HandleInstance(clientData, interp, objc, objv) + ClientData clientData; /* object definition */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclObject *contextObj = (ItclObject*)clientData; + + int result; + char *token; + Tcl_HashEntry *entry; + ItclMemberFunc *mfunc; + ItclObjectInfo *info; + ItclContext context; + CallFrame *framePtr; + + if (objc < 2) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be one of...", + (char*)NULL); + ItclReportObjectUsage(interp, contextObj); + return TCL_ERROR; + } + + /* + * Make sure that the specified operation is really an + * object method, and it is accessible. If not, return usage + * information for the object. + */ + token = Tcl_GetStringFromObj(objv[1], (int*)NULL); + mfunc = NULL; + + entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveCmds, token); + if (entry) { + mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); + + if ((mfunc->member->flags & ITCL_COMMON) != 0) { + mfunc = NULL; + } + else if (mfunc->member->protection != ITCL_PUBLIC) { + Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp, + mfunc->member->classDefn->info); + + if (!Itcl_CanAccessFunc(mfunc, contextNs)) { + mfunc = NULL; + } + } + } + + if ( !mfunc && (*token != 'i' || strcmp(token,"info") != 0) ) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option \"", token, "\": should be one of...", + (char*)NULL); + ItclReportObjectUsage(interp, contextObj); + return TCL_ERROR; + } + + /* + * Install an object context and invoke the method. + * + * TRICKY NOTE: We need to pass the object context into the + * method, but activating the context here puts us one level + * down, and when the method is called, it will activate its + * own context, putting us another level down. If anyone + * were to execute an "uplevel" command in the method, they + * would notice the extra call frame. So we mark this frame + * as "transparent" and Itcl_EvalMemberCode will automatically + * do an "uplevel" operation to correct the problem. + */ + info = contextObj->classDefn->info; + + if (Itcl_PushContext(interp, (ItclMember*)NULL, contextObj->classDefn, + contextObj, &context) != TCL_OK) { + + return TCL_ERROR; + } + + framePtr = &context.frame; + Itcl_PushStack((ClientData)framePtr, &info->transparentFrames); + + result = Itcl_EvalArgs(interp, objc-1, objv+1); + + Itcl_PopStack(&info->transparentFrames); + Itcl_PopContext(interp, &context); + + return result; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_GetInstanceVar() + * + * Returns the current value for an object data member. The member + * name is interpreted with respect to the given class scope, which + * is usually the most-specific class for the object. + * + * If successful, this procedure returns a pointer to a string value + * which remains alive until the variable changes it value. If + * anything goes wrong, this returns NULL. + * ------------------------------------------------------------------------ + */ +char* +Itcl_GetInstanceVar(interp, name, contextObj, contextClass) + Tcl_Interp *interp; /* current interpreter */ + char *name; /* name of desired instance variable */ + ItclObject *contextObj; /* current object */ + ItclClass *contextClass; /* name is interpreted in this scope */ +{ + ItclContext context; + char *val; + + /* + * Make sure that the current namespace context includes an + * object that is being manipulated. + */ + if (contextObj == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot access object-specific info without an object context", + (char*)NULL); + return NULL; + } + + /* + * Install the object context and access the data member + * like any other variable. + */ + if (Itcl_PushContext(interp, (ItclMember*)NULL, contextClass, + contextObj, &context) != TCL_OK) { + + return NULL; + } + + val = Tcl_GetVar2(interp, name, (char*)NULL, TCL_LEAVE_ERR_MSG); + Itcl_PopContext(interp, &context); + + return val; +} + + +/* + * ------------------------------------------------------------------------ + * ItclReportObjectUsage() + * + * Appends information to the given interp summarizing the usage + * for all of the methods available for this object. Useful when + * reporting errors in Itcl_HandleInstance(). + * ------------------------------------------------------------------------ + */ +static void +ItclReportObjectUsage(interp, contextObj) + Tcl_Interp *interp; /* current interpreter */ + ItclObject *contextObj; /* current object */ +{ + ItclClass *cdefnPtr = (ItclClass*)contextObj->classDefn; + int ignore = ITCL_CONSTRUCTOR | ITCL_DESTRUCTOR | ITCL_COMMON; + + int cmp; + char *name; + Itcl_List cmdList; + Itcl_ListElem *elem; + Tcl_HashEntry *entry; + Tcl_HashSearch place; + ItclMemberFunc *mfunc, *cmpDefn; + Tcl_Obj *resultPtr; + + /* + * Scan through all methods in the virtual table and sort + * them in alphabetical order. Report only the methods + * that have simple names (no ::'s) and are accessible. + */ + Itcl_InitList(&cmdList); + entry = Tcl_FirstHashEntry(&cdefnPtr->resolveCmds, &place); + while (entry) { + name = Tcl_GetHashKey(&cdefnPtr->resolveCmds, entry); + mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); + + if (strstr(name,"::") || (mfunc->member->flags & ignore) != 0) { + mfunc = NULL; + } + else if (mfunc->member->protection != ITCL_PUBLIC) { + Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp, + mfunc->member->classDefn->info); + + if (!Itcl_CanAccessFunc(mfunc, contextNs)) { + mfunc = NULL; + } + } + + if (mfunc) { + elem = Itcl_FirstListElem(&cmdList); + while (elem) { + cmpDefn = (ItclMemberFunc*)Itcl_GetListValue(elem); + cmp = strcmp(mfunc->member->name, cmpDefn->member->name); + if (cmp < 0) { + Itcl_InsertListElem(elem, (ClientData)mfunc); + mfunc = NULL; + break; + } + else if (cmp == 0) { + mfunc = NULL; + break; + } + elem = Itcl_NextListElem(elem); + } + if (mfunc) { + Itcl_AppendList(&cmdList, (ClientData)mfunc); + } + } + entry = Tcl_NextHashEntry(&place); + } + + /* + * Add a series of statements showing usage info. + */ + resultPtr = Tcl_GetObjResult(interp); + elem = Itcl_FirstListElem(&cmdList); + while (elem) { + mfunc = (ItclMemberFunc*)Itcl_GetListValue(elem); + Tcl_AppendToObj(resultPtr, "\n ", -1); + Itcl_GetMemberFuncUsage(mfunc, contextObj, resultPtr); + + elem = Itcl_NextListElem(elem); + } + Itcl_DeleteList(&cmdList); +} + + +/* + * ------------------------------------------------------------------------ + * ItclTraceThisVar() + * + * Invoked to handle read/write traces on the "this" variable built + * into each object. + * + * On read, this procedure updates the "this" variable to contain the + * current object name. This is done dynamically, since an object's + * identity can change if its access command is renamed. + * + * On write, this procedure returns an error string, warning that + * the "this" variable cannot be set. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static char* +ItclTraceThisVar(cdata, interp, name1, name2, flags) + ClientData cdata; /* object instance data */ + Tcl_Interp *interp; /* interpreter managing this variable */ + char *name1; /* variable name */ + char *name2; /* unused */ + int flags; /* flags indicating read/write */ +{ + ItclObject *contextObj = (ItclObject*)cdata; + char *objName; + Tcl_Obj *objPtr; + + /* + * Handle read traces on "this" + */ + if ((flags & TCL_TRACE_READS) != 0) { + objPtr = Tcl_NewStringObj("", -1); + Tcl_IncrRefCount(objPtr); + + if (contextObj->accessCmd) { + Tcl_GetCommandFullName(contextObj->classDefn->interp, + contextObj->accessCmd, objPtr); + } + + objName = Tcl_GetStringFromObj(objPtr, (int*)NULL); + Tcl_SetVar(interp, name1, objName, 0); + + Tcl_DecrRefCount(objPtr); + return NULL; + } + + /* + * Handle write traces on "this" + */ + if ((flags & TCL_TRACE_WRITES) != 0) { + return "variable \"this\" cannot be modified"; + } + return NULL; +} + + +/* + * ------------------------------------------------------------------------ + * ItclDestroyObject() + * + * Invoked when the object access command is deleted to implicitly + * destroy the object. Invokes the object's destructors, ignoring + * any errors encountered along the way. Removes the object from + * the list of all known objects and releases the access command's + * claim to the object data. + * + * Note that the usual way to delete an object is via Itcl_DeleteObject(). + * This procedure is provided as a back-up, to handle the case when + * an object is deleted by removing its access command. + * ------------------------------------------------------------------------ + */ +static void +ItclDestroyObject(cdata) + ClientData cdata; /* object instance data */ +{ + ItclObject *contextObj = (ItclObject*)cdata; + ItclClass *cdefnPtr = (ItclClass*)contextObj->classDefn; + Tcl_HashEntry *entry; + Itcl_InterpState istate; + + /* + * Attempt to destruct the object, but ignore any errors. + */ + istate = Itcl_SaveInterpState(cdefnPtr->interp, 0); + Itcl_DestructObject(cdefnPtr->interp, contextObj, ITCL_IGNORE_ERRS); + Itcl_RestoreInterpState(cdefnPtr->interp, istate); + + /* + * Now, remove the object from the global object list. + * We're careful to do this here, after calling the destructors. + * Once the access command is nulled out, the "this" variable + * won't work properly. + */ + if (contextObj->accessCmd) { + entry = Tcl_FindHashEntry(&cdefnPtr->info->objects, + (char*)contextObj->accessCmd); + + if (entry) { + Tcl_DeleteHashEntry(entry); + } + contextObj->accessCmd = NULL; + } + + Itcl_ReleaseData((ClientData)contextObj); +} + + +/* + * ------------------------------------------------------------------------ + * ItclFreeObject() + * + * Deletes all instance variables and frees all memory associated with + * the given object instance. This is usually invoked automatically + * by Itcl_ReleaseData(), when an object's data is no longer being used. + * ------------------------------------------------------------------------ + */ +static void +ItclFreeObject(cdata) + char* cdata; /* object instance data */ +{ + ItclObject *contextObj = (ItclObject*)cdata; + Tcl_Interp *interp = contextObj->classDefn->interp; + + int i; + ItclClass *cdPtr; + ItclHierIter hier; + Tcl_HashSearch place; + Tcl_HashEntry *entry; + ItclVarDefn *vdefn; + ItclContext context; + Itcl_InterpState istate; + + /* + * Install the class namespace and object context so that + * the object's data members can be destroyed via simple + * "unset" commands. This makes sure that traces work properly + * and all memory gets cleaned up. + * + * NOTE: Be careful to save and restore the interpreter state. + * Data can get freed in the middle of any operation, and + * we can't affort to clobber the interpreter with any errors + * from below. + */ + istate = Itcl_SaveInterpState(interp, 0); + + /* + * Scan through all object-specific data members and destroy the + * actual variables that maintain the object state. Do this + * by unsetting each variable, so that traces are fired off + * correctly. Make sure that the built-in "this" variable is + * only destroyed once. Also, be careful to activate the + * namespace for each class, so that private variables can + * be accessed. + */ + Itcl_InitHierIter(&hier, contextObj->classDefn); + cdPtr = Itcl_AdvanceHierIter(&hier); + while (cdPtr != NULL) { + + if (Itcl_PushContext(interp, (ItclMember*)NULL, cdPtr, + contextObj, &context) == TCL_OK) { + + entry = Tcl_FirstHashEntry(&cdPtr->variables, &place); + while (entry) { + vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry); + if ((vdefn->member->flags & ITCL_THIS_VAR) != 0) { + if (cdPtr == contextObj->classDefn) { + Tcl_UnsetVar2(interp, vdefn->member->fullname, + (char*)NULL, 0); + } + } + else if ((vdefn->member->flags & ITCL_COMMON) == 0) { + Tcl_UnsetVar2(interp, vdefn->member->fullname, + (char*)NULL, 0); + } + entry = Tcl_NextHashEntry(&place); + } + Itcl_PopContext(interp, &context); + } + + cdPtr = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + /* + * Free the memory associated with object-specific variables. + * For normal variables this would be done automatically by + * CleanupVar() when the variable is unset. But object-specific + * variables are protected by an extra reference count, and they + * must be deleted explicitly here. + */ + for (i=0; i < contextObj->dataSize; i++) { + if (contextObj->data[i]) { + ckfree((char*)contextObj->data[i]); + } + } + + Itcl_RestoreInterpState(interp, istate); + + /* + * Free any remaining memory associated with the object. + */ + ckfree((char*)contextObj->data); + + if (contextObj->constructed) { + Tcl_DeleteHashTable(contextObj->constructed); + ckfree((char*)contextObj->constructed); + } + if (contextObj->destructed) { + Tcl_DeleteHashTable(contextObj->destructed); + ckfree((char*)contextObj->destructed); + } + Itcl_ReleaseData((ClientData)contextObj->classDefn); + + ckfree((char*)contextObj); +} + + +/* + * ------------------------------------------------------------------------ + * ItclCreateObjVar() + * + * Creates one variable acting as a data member for a specific + * object. Initializes the variable according to its definition, + * and sets up its reference count so that it cannot be deleted + * by ordinary means. Installs the new variable directly into + * the data array for the specified object. + * ------------------------------------------------------------------------ + */ +static void +ItclCreateObjVar(interp, vdefn, contextObj) + Tcl_Interp* interp; /* interpreter managing this object */ + ItclVarDefn* vdefn; /* variable definition */ + ItclObject* contextObj; /* object being updated */ +{ + Var *varPtr; + Tcl_HashEntry *entry; + ItclVarLookup *vlookup; + ItclContext context; + + varPtr = _TclNewVar(); + varPtr->name = vdefn->member->name; + varPtr->nsPtr = (Namespace*)vdefn->member->classDefn->namesp; + + /* + * NOTE: Tcl reports a "dangling upvar" error for variables + * with a null "hPtr" field. Put something non-zero + * in here to keep Tcl_SetVar2() happy. The only time + * this field is really used is it remove a variable + * from the hash table that contains it in CleanupVar, + * but since these variables are protected by their + * higher refCount, they will not be deleted by CleanupVar + * anyway. These variables are unset and removed in + * ItclFreeObject(). + */ + varPtr->hPtr = (Tcl_HashEntry*)0x1; + varPtr->refCount = 1; /* protect from being deleted */ + + /* + * Install the new variable in the object's data array. + * Look up the appropriate index for the object using + * the data table in the class definition. + */ + entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars, + vdefn->member->fullname); + + if (entry) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + contextObj->data[vlookup->var.index] = varPtr; + } + + /* + * If this variable has an initial value, initialize it + * here using a "set" command. + * + * TRICKY NOTE: We push an object context for the class that + * owns the variable, so that we don't have any trouble + * accessing it. + */ + if (vdefn->init) { + if (Itcl_PushContext(interp, (ItclMember*)NULL, + vdefn->member->classDefn, contextObj, &context) == TCL_OK) { + + Tcl_SetVar2(interp, vdefn->member->fullname, + (char*)NULL, vdefn->init, 0); + Itcl_PopContext(interp, &context); + } + } +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ScopedVarResolver() + * + * This procedure is installed to handle variable resolution throughout + * an entire interpreter. It looks for scoped variable references of + * the form: + * + * @itcl ::namesp::namesp::object variable + * + * If a reference like this is recognized, this procedure finds the + * desired variable in the object and returns the variable, along with + * the status code TCL_OK. If the variable does not start with + * "@itcl", this procedure returns TCL_CONTINUE, and variable + * resolution continues using the normal rules. If anything goes + * wrong, this procedure returns TCL_ERROR, and access to the + * variable is denied. + * ------------------------------------------------------------------------ + */ +int +Itcl_ScopedVarResolver(interp, name, contextNs, flags, rPtr) + Tcl_Interp *interp; /* current interpreter */ + char *name; /* variable name being resolved */ + Tcl_Namespace *contextNs; /* current namespace context */ + int flags; /* TCL_LEAVE_ERR_MSG => leave error message */ + Tcl_Var *rPtr; /* returns: resolved variable */ +{ + int namec; + char **namev; + Tcl_Interp *errs; + Tcl_CmdInfo cmdInfo; + ItclObject *contextObj; + ItclVarLookup *vlookup; + Tcl_HashEntry *entry; + + /* + * See if the variable starts with "@itcl". If not, then + * let the variable resolution process continue. + */ + if (*name != '@' || strncmp(name, "@itcl", 5) != 0) { + return TCL_CONTINUE; + } + + /* + * Break the variable name into parts and extract the object + * name and the variable name. + */ + if (flags & TCL_LEAVE_ERR_MSG) { + errs = interp; + } else { + errs = NULL; + } + + if (Tcl_SplitList(errs, name, &namec, &namev) != TCL_OK) { + return TCL_ERROR; + } + if (namec != 3) { + if (errs) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(errs), + "scoped variable \"", name, "\" is malformed: ", + "should be: @itcl object variable", + (char*)NULL); + } + ckfree((char*)namev); + return TCL_ERROR; + } + + /* + * Look for the command representing the object and extract + * the object context. + */ + if (!Tcl_GetCommandInfo(interp, namev[1], &cmdInfo)) { + if (errs) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(errs), + "can't resolve scoped variable \"", name, "\": ", + "can't find object ", namev[1], + (char*)NULL); + } + ckfree((char*)namev); + return TCL_ERROR; + } + contextObj = (ItclObject*)cmdInfo.objClientData; + + /* + * Resolve the variable with respect to the most-specific + * class definition. + */ + entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars, namev[2]); + if (!entry) { + if (errs) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(errs), + "can't resolve scoped variable \"", name, "\": ", + "no such data member ", namev[2], + (char*)NULL); + } + ckfree((char*)namev); + return TCL_ERROR; + } + + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + *rPtr = (Tcl_Var) contextObj->data[vlookup->var.index]; + + ckfree((char*)namev); + return TCL_OK; +}

itcl_objects.c Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: itcl_ensemble.c =================================================================== --- itcl_ensemble.c (nonexistent) +++ itcl_ensemble.c (revision 1765) @@ -0,0 +1,2248 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * This part handles ensembles, which support compound commands in Tcl. + * The usual "info" command is an ensemble with parts like "info body" + * and "info globals". Extension developers can extend commands like + * "info" by adding their own parts to the ensemble. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * RCS: $Id: itcl_ensemble.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $ + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +/* + * Data used to represent an ensemble: + */ +struct Ensemble; +typedef struct EnsemblePart { + char *name; /* name of this part */ + int minChars; /* chars needed to uniquely identify part */ + Command *cmdPtr; /* command handling this part */ + char *usage; /* usage string describing syntax */ + struct Ensemble* ensemble; /* ensemble containing this part */ +} EnsemblePart; + +/* + * Data used to represent an ensemble: + */ +typedef struct Ensemble { + Tcl_Interp *interp; /* interpreter containing this ensemble */ + EnsemblePart **parts; /* list of parts in this ensemble */ + int numParts; /* number of parts in part list */ + int maxParts; /* current size of parts list */ + Tcl_Command cmd; /* command representing this ensemble */ + EnsemblePart* parent; /* parent part for sub-ensembles + * NULL => toplevel ensemble */ +} Ensemble; + +/* + * Data shared by ensemble access commands and ensemble parser: + */ +typedef struct EnsembleParser { + Tcl_Interp* master; /* master interp containing ensembles */ + Tcl_Interp* parser; /* slave interp for parsing */ + Ensemble* ensData; /* add parts to this ensemble */ +} EnsembleParser; + +/* + * Declarations for local procedures to this file: + */ +static void FreeEnsInvocInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); +static void DupEnsInvocInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, + Tcl_Obj *copyPtr)); +static void UpdateStringOfEnsInvoc _ANSI_ARGS_((Tcl_Obj *objPtr)); +static int SetEnsInvocFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); + +/* + * This structure defines a Tcl object type that takes the + * place of a part name during ensemble invocations. When an + * error occurs and the caller tries to print objv[0], it will + * get a string that contains a complete path to the ensemble + * part. + */ +Tcl_ObjType itclEnsInvocType = { + "ensembleInvoc", /* name */ + FreeEnsInvocInternalRep, /* freeIntRepProc */ + DupEnsInvocInternalRep, /* dupIntRepProc */ + UpdateStringOfEnsInvoc, /* updateStringProc */ + SetEnsInvocFromAny /* setFromAnyProc */ +}; + +/* + * Boolean flag indicating whether or not the "ensemble" object + * type has been registered with the Tcl compiler. + */ +static int ensInitialized = 0; + +/* + * Forward declarations for the procedures used in this file. + */ +static void GetEnsembleUsage _ANSI_ARGS_((Ensemble *ensData, + Tcl_Obj *objPtr)); + +static void GetEnsemblePartUsage _ANSI_ARGS_((EnsemblePart *ensPart, + Tcl_Obj *objPtr)); + +static int CreateEnsemble _ANSI_ARGS_((Tcl_Interp *interp, + Ensemble *parentEnsData, char *ensName)); + +static int AddEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp, + Ensemble* ensData, char* partName, char* usageInfo, + Tcl_ObjCmdProc *objProc, ClientData clientData, + Tcl_CmdDeleteProc *deleteProc, EnsemblePart **rVal)); + +static void DeleteEnsemble _ANSI_ARGS_((ClientData clientData)); + +static int FindEnsemble _ANSI_ARGS_((Tcl_Interp *interp, char **nameArgv, + int nameArgc, Ensemble** ensDataPtr)); + +static int CreateEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp, + Ensemble *ensData, char* partName, EnsemblePart **ensPartPtr)); + +static void DeleteEnsemblePart _ANSI_ARGS_((EnsemblePart *ensPart)); + +static int FindEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp, + Ensemble *ensData, char* partName, EnsemblePart **rensPart)); + +static int FindEnsemblePartIndex _ANSI_ARGS_((Ensemble *ensData, + char *partName, int *posPtr)); + +static void ComputeMinChars _ANSI_ARGS_((Ensemble *ensData, int pos)); + +static int HandleEnsemble _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); + +static EnsembleParser* GetEnsembleParser _ANSI_ARGS_((Tcl_Interp *interp)); + +static void DeleteEnsParser _ANSI_ARGS_((ClientData clientData, + Tcl_Interp* interp)); + + + +/* + *---------------------------------------------------------------------- + * + * Itcl_EnsembleInit -- + * + * Called when any interpreter is created to make sure that + * things are properly set up for ensembles. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes + * wrong. + * + * Side effects: + * On the first call, the "ensemble" object type is registered + * with the Tcl compiler. If an error is encountered, an error + * is left as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +int +Itcl_EnsembleInit(interp) + Tcl_Interp *interp; /* interpreter being initialized */ +{ + if (!ensInitialized) { + Tcl_RegisterObjType(&itclEnsInvocType); + ensInitialized = 1; + } + + Tcl_CreateObjCommand(interp, "::itcl::ensemble", + Itcl_EnsembleCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_CreateEnsemble -- + * + * Creates an ensemble command, or adds a sub-ensemble to an + * existing ensemble command. The ensemble name is a space- + * separated list. The first word in the list is the command + * name for the top-level ensemble. Other names do not have + * commands associated with them; they are merely sub-ensembles + * within the ensemble. So a name like "a::b::foo bar baz" + * represents an ensemble command called "foo" in the namespace + * "a::b" that has a sub-ensemble "bar", that has a sub-ensemble + * "baz". + * + * If the name is a single word, then this procedure creates + * a top-level ensemble and installs an access command for it. + * If a command already exists with that name, it is deleted. + * + * If the name has more than one word, then the leading words + * are treated as a path name for an existing ensemble. The + * last word is treated as the name for a new sub-ensemble. + * If an part already exists with that name, it is an error. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes + * wrong. + * + * Side effects: + * If an error is encountered, an error is left as the result + * in the interpreter. + * + *---------------------------------------------------------------------- + */ +int +Itcl_CreateEnsemble(interp, ensName) + Tcl_Interp *interp; /* interpreter to be updated */ + char* ensName; /* name of the new ensemble */ +{ + char **nameArgv = NULL; + int nameArgc; + Ensemble *parentEnsData; + Tcl_DString buffer; + + /* + * Split the ensemble name into its path components. + */ + if (Tcl_SplitList(interp, ensName, &nameArgc, &nameArgv) != TCL_OK) { + goto ensCreateFail; + } + if (nameArgc < 1) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid ensemble name \"", ensName, "\"", + (char*)NULL); + goto ensCreateFail; + } + + /* + * If there is more than one path component, then follow + * the path down to the last component, to find the containing + * ensemble. + */ + parentEnsData = NULL; + if (nameArgc > 1) { + if (FindEnsemble(interp, nameArgv, nameArgc-1, &parentEnsData) + != TCL_OK) { + goto ensCreateFail; + } + + if (parentEnsData == NULL) { + char *pname = Tcl_Merge(nameArgc-1, nameArgv); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid ensemble name \"", pname, "\"", + (char*)NULL); + ckfree(pname); + goto ensCreateFail; + } + } + + /* + * Create the ensemble. + */ + if (CreateEnsemble(interp, parentEnsData, nameArgv[nameArgc-1]) + != TCL_OK) { + goto ensCreateFail; + } + + ckfree((char*)nameArgv); + return TCL_OK; + +ensCreateFail: + if (nameArgv) { + ckfree((char*)nameArgv); + } + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, "\n (while creating ensemble \"", -1); + Tcl_DStringAppend(&buffer, ensName, -1); + Tcl_DStringAppend(&buffer, "\")", -1); + Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&buffer), -1); + Tcl_DStringFree(&buffer); + + return TCL_ERROR; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_AddEnsemblePart -- + * + * Adds a part to an ensemble which has been created by + * Itcl_CreateEnsemble. Ensembles are addressed by name, as + * described in Itcl_CreateEnsemble. + * + * If the ensemble already has a part with the specified name, + * this procedure returns an error. Otherwise, it adds a new + * part to the ensemble. + * + * Any client data specified is automatically passed to the + * handling procedure whenever the part is invoked. It is + * automatically destroyed by the deleteProc when the part is + * deleted. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes + * wrong. + * + * Side effects: + * If an error is encountered, an error is left as the result + * in the interpreter. + * + *---------------------------------------------------------------------- + */ +int +Itcl_AddEnsemblePart(interp, ensName, partName, usageInfo, + objProc, clientData, deleteProc) + + Tcl_Interp *interp; /* interpreter to be updated */ + char* ensName; /* ensemble containing this part */ + char* partName; /* name of the new part */ + char* usageInfo; /* usage info for argument list */ + Tcl_ObjCmdProc *objProc; /* handling procedure for part */ + ClientData clientData; /* client data associated with part */ + Tcl_CmdDeleteProc *deleteProc; /* procedure used to destroy client data */ +{ + char **nameArgv = NULL; + int nameArgc; + Ensemble *ensData; + EnsemblePart *ensPart; + Tcl_DString buffer; + + /* + * Parse the ensemble name and look for a containing ensemble. + */ + if (Tcl_SplitList(interp, ensName, &nameArgc, &nameArgv) != TCL_OK) { + goto ensPartFail; + } + if (FindEnsemble(interp, nameArgv, nameArgc, &ensData) != TCL_OK) { + goto ensPartFail; + } + + if (ensData == NULL) { + char *pname = Tcl_Merge(nameArgc, nameArgv); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid ensemble name \"", pname, "\"", + (char*)NULL); + ckfree(pname); + goto ensPartFail; + } + + /* + * Install the new part into the part list. + */ + if (AddEnsemblePart(interp, ensData, partName, usageInfo, + objProc, clientData, deleteProc, &ensPart) != TCL_OK) { + goto ensPartFail; + } + + ckfree((char*)nameArgv); + return TCL_OK; + +ensPartFail: + if (nameArgv) { + ckfree((char*)nameArgv); + } + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, "\n (while adding to ensemble \"", -1); + Tcl_DStringAppend(&buffer, ensName, -1); + Tcl_DStringAppend(&buffer, "\")", -1); + Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&buffer), -1); + Tcl_DStringFree(&buffer); + + return TCL_ERROR; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_GetEnsemblePart -- + * + * Looks for a part within an ensemble, and returns information + * about it. + * + * Results: + * If the ensemble and its part are found, this procedure + * loads information about the part into the "infoPtr" structure + * and returns 1. Otherwise, it returns 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +int +Itcl_GetEnsemblePart(interp, ensName, partName, infoPtr) + Tcl_Interp *interp; /* interpreter to be updated */ + char *ensName; /* ensemble containing the part */ + char *partName; /* name of the desired part */ + Tcl_CmdInfo *infoPtr; /* returns: info associated with part */ +{ + char **nameArgv = NULL; + int nameArgc; + Ensemble *ensData; + EnsemblePart *ensPart; + Command *cmdPtr; + Itcl_InterpState state; + + /* + * Parse the ensemble name and look for a containing ensemble. + * Save the interpreter state before we do this. If we get any + * errors, we don't want them to affect the interpreter. + */ + state = Itcl_SaveInterpState(interp, TCL_OK); + + if (Tcl_SplitList(interp, ensName, &nameArgc, &nameArgv) != TCL_OK) { + goto ensGetFail; + } + if (FindEnsemble(interp, nameArgv, nameArgc, &ensData) != TCL_OK) { + goto ensGetFail; + } + if (ensData == NULL) { + goto ensGetFail; + } + + /* + * Look for a part with the desired name. If found, load + * its data into the "infoPtr" structure. + */ + if (FindEnsemblePart(interp, ensData, partName, &ensPart) + != TCL_OK || ensPart == NULL) { + goto ensGetFail; + } + + cmdPtr = ensPart->cmdPtr; + infoPtr->isNativeObjectProc = (cmdPtr->objProc != TclInvokeStringCommand); + infoPtr->objProc = cmdPtr->objProc; + infoPtr->objClientData = cmdPtr->objClientData; + infoPtr->proc = cmdPtr->proc; + infoPtr->clientData = cmdPtr->clientData; + infoPtr->deleteProc = cmdPtr->deleteProc; + infoPtr->deleteData = cmdPtr->deleteData; + infoPtr->namespacePtr = (Tcl_Namespace*)cmdPtr->nsPtr; + + Itcl_DiscardInterpState(state); + return 1; + +ensGetFail: + Itcl_RestoreInterpState(interp, state); + return 0; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_IsEnsemble -- + * + * Determines whether or not an existing command is an ensemble. + * + * Results: + * Returns non-zero if the command is an ensemble, and zero + * otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +int +Itcl_IsEnsemble(infoPtr) + Tcl_CmdInfo* infoPtr; /* command info from Tcl_GetCommandInfo() */ +{ + if (infoPtr) { + return (infoPtr->deleteProc == DeleteEnsemble); + } + return 0; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_GetEnsembleUsage -- + * + * Returns a summary of all of the parts of an ensemble and + * the meaning of their arguments. Each part is listed on + * a separate line. Having this summary is sometimes useful + * when building error messages for the "@error" handler in + * an ensemble. + * + * Ensembles are accessed by name, as described in + * Itcl_CreateEnsemble. + * + * Results: + * If the ensemble is found, its usage information is appended + * onto the object "objPtr", and this procedure returns + * non-zero. It is the responsibility of the caller to + * initialize and free the object. If anything goes wrong, + * this procedure returns 0. + * + * Side effects: + * Object passed in is modified. + * + *---------------------------------------------------------------------- + */ +int +Itcl_GetEnsembleUsage(interp, ensName, objPtr) + Tcl_Interp *interp; /* interpreter containing the ensemble */ + char *ensName; /* name of the ensemble */ + Tcl_Obj *objPtr; /* returns: summary of usage info */ +{ + char **nameArgv = NULL; + int nameArgc; + Ensemble *ensData; + Itcl_InterpState state; + + /* + * Parse the ensemble name and look for the ensemble. + * Save the interpreter state before we do this. If we get + * any errors, we don't want them to affect the interpreter. + */ + state = Itcl_SaveInterpState(interp, TCL_OK); + + if (Tcl_SplitList(interp, ensName, &nameArgc, &nameArgv) != TCL_OK) { + goto ensUsageFail; + } + if (FindEnsemble(interp, nameArgv, nameArgc, &ensData) != TCL_OK) { + goto ensUsageFail; + } + if (ensData == NULL) { + goto ensUsageFail; + } + + /* + * Add a summary of usage information to the return buffer. + */ + GetEnsembleUsage(ensData, objPtr); + + Itcl_DiscardInterpState(state); + return 1; + +ensUsageFail: + Itcl_RestoreInterpState(interp, state); + return 0; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_GetEnsembleUsageForObj -- + * + * Returns a summary of all of the parts of an ensemble and + * the meaning of their arguments. This procedure is just + * like Itcl_GetEnsembleUsage, but it determines the desired + * ensemble from a command line argument. The argument should + * be the first argument on the command line--the ensemble + * command or one of its parts. + * + * Results: + * If the ensemble is found, its usage information is appended + * onto the object "objPtr", and this procedure returns + * non-zero. It is the responsibility of the caller to + * initialize and free the object. If anything goes wrong, + * this procedure returns 0. + * + * Side effects: + * Object passed in is modified. + * + *---------------------------------------------------------------------- + */ +int +Itcl_GetEnsembleUsageForObj(interp, ensObjPtr, objPtr) + Tcl_Interp *interp; /* interpreter containing the ensemble */ + Tcl_Obj *ensObjPtr; /* argument representing ensemble */ + Tcl_Obj *objPtr; /* returns: summary of usage info */ +{ + Ensemble *ensData; + Tcl_Obj *chainObj; + Tcl_Command cmd; + Command *cmdPtr; + + /* + * If the argument is an ensemble part, then follow the chain + * back to the command word for the entire ensemble. + */ + chainObj = ensObjPtr; + while (chainObj && chainObj->typePtr == &itclEnsInvocType) { + chainObj = (Tcl_Obj*)chainObj->internalRep.twoPtrValue.ptr2; + } + + if (chainObj) { + cmd = Tcl_GetCommandFromObj(interp, chainObj); + cmdPtr = (Command*)cmd; + if (cmdPtr->deleteProc == DeleteEnsemble) { + ensData = (Ensemble*)cmdPtr->objClientData; + GetEnsembleUsage(ensData, objPtr); + return 1; + } + } + return 0; +} + + +/* + *---------------------------------------------------------------------- + * + * GetEnsembleUsage -- + * + * + * Returns a summary of all of the parts of an ensemble and + * the meaning of their arguments. Each part is listed on + * a separate line. This procedure is used internally to + * generate usage information for error messages. + * + * Results: + * Appends usage information onto the object in "objPtr". + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static void +GetEnsembleUsage(ensData, objPtr) + Ensemble *ensData; /* ensemble data */ + Tcl_Obj *objPtr; /* returns: summary of usage info */ +{ + char *spaces = " "; + int isOpenEnded = 0; + + int i; + EnsemblePart *ensPart; + + for (i=0; i < ensData->numParts; i++) { + ensPart = ensData->parts[i]; + + if (*ensPart->name == '@' && strcmp(ensPart->name,"@error") == 0) { + isOpenEnded = 1; + } + else { + Tcl_AppendToObj(objPtr, spaces, -1); + GetEnsemblePartUsage(ensPart, objPtr); + spaces = "\n "; + } + } + if (isOpenEnded) { + Tcl_AppendToObj(objPtr, + "\n...and others described on the man page", -1); + } +} + + +/* + *---------------------------------------------------------------------- + * + * GetEnsemblePartUsage -- + * + * Determines the usage for a single part within an ensemble, + * and appends a summary onto a dynamic string. The usage + * is a combination of the part name and the argument summary. + * It is the caller's responsibility to initialize and free + * the dynamic string. + * + * Results: + * Returns usage information in the object "objPtr". + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static void +GetEnsemblePartUsage(ensPart, objPtr) + EnsemblePart *ensPart; /* ensemble part for usage info */ + Tcl_Obj *objPtr; /* returns: usage information */ +{ + EnsemblePart *part; + Command *cmdPtr; + char *name; + Itcl_List trail; + Itcl_ListElem *elem; + Tcl_DString buffer; + + /* + * Build the trail of ensemble names leading to this part. + */ + Tcl_DStringInit(&buffer); + Itcl_InitList(&trail); + for (part=ensPart; part; part=part->ensemble->parent) { + Itcl_InsertList(&trail, (ClientData)part); + } + + cmdPtr = (Command*)ensPart->ensemble->cmd; + name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); + Tcl_DStringAppendElement(&buffer, name); + + for (elem=Itcl_FirstListElem(&trail); elem; elem=Itcl_NextListElem(elem)) { + part = (EnsemblePart*)Itcl_GetListValue(elem); + Tcl_DStringAppendElement(&buffer, part->name); + } + Itcl_DeleteList(&trail); + + /* + * If the part has usage info, use it directly. + */ + if (ensPart->usage && *ensPart->usage != '\0') { + Tcl_DStringAppend(&buffer, " ", 1); + Tcl_DStringAppend(&buffer, ensPart->usage, -1); + } + + /* + * If the part is itself an ensemble, summarize its usage. + */ + else if (ensPart->cmdPtr && + ensPart->cmdPtr->deleteProc == DeleteEnsemble) { + Tcl_DStringAppend(&buffer, " option ?arg arg ...?", 21); + } + + Tcl_AppendToObj(objPtr, Tcl_DStringValue(&buffer), + Tcl_DStringLength(&buffer)); + + Tcl_DStringFree(&buffer); +} + + +/* + *---------------------------------------------------------------------- + * + * CreateEnsemble -- + * + * Creates an ensemble command, or adds a sub-ensemble to an + * existing ensemble command. Works like Itcl_CreateEnsemble, + * except that the ensemble name is a single name, not a path. + * If a parent ensemble is specified, then a new ensemble is + * added to that parent. If a part already exists with the + * same name, it is an error. If a parent ensemble is not + * specified, then a top-level ensemble is created. If a + * command already exists with the same name, it is deleted. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes + * wrong. + * + * Side effects: + * If an error is encountered, an error is left as the result + * in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +CreateEnsemble(interp, parentEnsData, ensName) + Tcl_Interp *interp; /* interpreter to be updated */ + Ensemble *parentEnsData; /* parent ensemble or NULL */ + char *ensName; /* name of the new ensemble */ +{ + Ensemble *ensData; + EnsemblePart *ensPart; + Command *cmdPtr; + Tcl_CmdInfo cmdInfo; + + /* + * Create the data associated with the ensemble. + */ + ensData = (Ensemble*)ckalloc(sizeof(Ensemble)); + ensData->interp = interp; + ensData->numParts = 0; + ensData->maxParts = 10; + ensData->parts = (EnsemblePart**)ckalloc( + (unsigned)(ensData->maxParts*sizeof(EnsemblePart*)) + ); + ensData->cmd = NULL; + ensData->parent = NULL; + + /* + * If there is no parent data, then this is a top-level + * ensemble. Create the ensemble by installing its access + * command. + * + * BE CAREFUL: Set the string-based proc to the wrapper + * procedure TclInvokeObjectCommand. Otherwise, the + * ensemble command may fail. For example, it will fail + * when invoked as a hidden command. + */ + if (parentEnsData == NULL) { + ensData->cmd = Tcl_CreateObjCommand(interp, ensName, + HandleEnsemble, (ClientData)ensData, DeleteEnsemble); + + if (Tcl_GetCommandInfo(interp, ensName, &cmdInfo)) { + cmdInfo.proc = TclInvokeObjectCommand; + Tcl_SetCommandInfo(interp, ensName, &cmdInfo); + } + return TCL_OK; + } + + /* + * Otherwise, this ensemble is contained within another parent. + * Install the new ensemble as a part within its parent. + */ + if (CreateEnsemblePart(interp, parentEnsData, ensName, &ensPart) + != TCL_OK) { + DeleteEnsemble((ClientData)ensData); + return TCL_ERROR; + } + + ensData->cmd = parentEnsData->cmd; + ensData->parent = ensPart; + + cmdPtr = (Command*)ckalloc(sizeof(Command)); + cmdPtr->hPtr = NULL; + cmdPtr->nsPtr = ((Command*)ensData->cmd)->nsPtr; + cmdPtr->refCount = 0; + cmdPtr->cmdEpoch = 0; + cmdPtr->compileProc = NULL; + cmdPtr->objProc = HandleEnsemble; + cmdPtr->objClientData = (ClientData)ensData; + cmdPtr->proc = NULL; + cmdPtr->clientData = NULL; + cmdPtr->deleteProc = DeleteEnsemble; + cmdPtr->deleteData = cmdPtr->objClientData; + cmdPtr->deleted = 0; + cmdPtr->importRefPtr = NULL; + + ensPart->cmdPtr = cmdPtr; + + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * AddEnsemblePart -- + * + * Adds a part to an existing ensemble. Works like + * Itcl_AddEnsemblePart, but the part name is a single word, + * not a path. + * + * If the ensemble already has a part with the specified name, + * this procedure returns an error. Otherwise, it adds a new + * part to the ensemble. + * + * Any client data specified is automatically passed to the + * handling procedure whenever the part is invoked. It is + * automatically destroyed by the deleteProc when the part is + * deleted. + * + * Results: + * Returns TCL_OK if successful, along with a pointer to the + * new part. Returns TCL_ERROR if anything goes wrong. + * + * Side effects: + * If an error is encountered, an error is left as the result + * in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +AddEnsemblePart(interp, ensData, partName, usageInfo, + objProc, clientData, deleteProc, rVal) + + Tcl_Interp *interp; /* interpreter to be updated */ + Ensemble* ensData; /* ensemble that will contain this part */ + char* partName; /* name of the new part */ + char* usageInfo; /* usage info for argument list */ + Tcl_ObjCmdProc *objProc; /* handling procedure for part */ + ClientData clientData; /* client data associated with part */ + Tcl_CmdDeleteProc *deleteProc; /* procedure used to destroy client data */ + EnsemblePart **rVal; /* returns: new ensemble part */ +{ + EnsemblePart *ensPart; + Command *cmdPtr; + + /* + * Install the new part into the part list. + */ + if (CreateEnsemblePart(interp, ensData, partName, &ensPart) != TCL_OK) { + return TCL_ERROR; + } + + if (usageInfo) { + ensPart->usage = ckalloc((unsigned)(strlen(usageInfo)+1)); + strcpy(ensPart->usage, usageInfo); + } + + cmdPtr = (Command*)ckalloc(sizeof(Command)); + cmdPtr->hPtr = NULL; + cmdPtr->nsPtr = ((Command*)ensData->cmd)->nsPtr; + cmdPtr->refCount = 0; + cmdPtr->cmdEpoch = 0; + cmdPtr->compileProc = NULL; + cmdPtr->objProc = objProc; + cmdPtr->objClientData = (ClientData)clientData; + cmdPtr->proc = NULL; + cmdPtr->clientData = NULL; + cmdPtr->deleteProc = deleteProc; + cmdPtr->deleteData = (ClientData)clientData; + cmdPtr->deleted = 0; + cmdPtr->importRefPtr = NULL; + + ensPart->cmdPtr = cmdPtr; + *rVal = ensPart; + + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * DeleteEnsemble -- + * + * Invoked when the command associated with an ensemble is + * destroyed, to delete the ensemble. Destroys all parts + * included in the ensemble, and frees all memory associated + * with it. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static void +DeleteEnsemble(clientData) + ClientData clientData; /* ensemble data */ +{ + Ensemble* ensData = (Ensemble*)clientData; + + /* + * BE CAREFUL: Each ensemble part removes itself from the list. + * So keep deleting the first part until all parts are gone. + */ + while (ensData->numParts > 0) { + DeleteEnsemblePart(ensData->parts[0]); + } + ckfree((char*)ensData->parts); + ckfree((char*)ensData); +} + + +/* + *---------------------------------------------------------------------- + * + * FindEnsemble -- + * + * Searches for an ensemble command and follows a path to + * sub-ensembles. + * + * Results: + * Returns TCL_OK if the ensemble was found, along with a + * pointer to the ensemble data in "ensDataPtr". Returns + * TCL_ERROR if anything goes wrong. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +FindEnsemble(interp, nameArgv, nameArgc, ensDataPtr) + Tcl_Interp *interp; /* interpreter containing the ensemble */ + char **nameArgv; /* path of names leading to ensemble */ + int nameArgc; /* number of strings in nameArgv */ + Ensemble** ensDataPtr; /* returns: ensemble data */ +{ + int i; + Command* cmdPtr; + Ensemble *ensData; + EnsemblePart *ensPart; + + *ensDataPtr = NULL; /* assume that no data will be found */ + + /* + * If there are no names in the path, then return an error. + */ + if (nameArgc < 1) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invalid ensemble name \"\"", -1); + return TCL_ERROR; + } + + /* + * Use the first name to find the command for the top-level + * ensemble. + */ + cmdPtr = (Command*) Tcl_FindCommand(interp, nameArgv[0], + (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); + + if (cmdPtr == NULL || cmdPtr->deleteProc != DeleteEnsemble) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "command \"", nameArgv[0], "\" is not an ensemble", + (char*)NULL); + return TCL_ERROR; + } + ensData = (Ensemble*)cmdPtr->objClientData; + + /* + * Follow the trail of sub-ensemble names. + */ + for (i=1; i < nameArgc; i++) { + if (FindEnsemblePart(interp, ensData, nameArgv[i], &ensPart) + != TCL_OK) { + return TCL_ERROR; + } + if (ensPart == NULL) { + char *pname = Tcl_Merge(i, nameArgv); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid ensemble name \"", pname, "\"", + (char*)NULL); + ckfree(pname); + return TCL_ERROR; + } + + cmdPtr = ensPart->cmdPtr; + if (cmdPtr == NULL || cmdPtr->deleteProc != DeleteEnsemble) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "part \"", nameArgv[i], "\" is not an ensemble", + (char*)NULL); + return TCL_ERROR; + } + ensData = (Ensemble*)cmdPtr->objClientData; + } + *ensDataPtr = ensData; + + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * CreateEnsemblePart -- + * + * Creates a new part within an ensemble. + * + * Results: + * If successful, this procedure returns TCL_OK, along with a + * pointer to the new part in "ensPartPtr". If a part with the + * same name already exists, this procedure returns TCL_ERROR. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +CreateEnsemblePart(interp, ensData, partName, ensPartPtr) + Tcl_Interp *interp; /* interpreter containing the ensemble */ + Ensemble *ensData; /* ensemble being modified */ + char* partName; /* name of the new part */ + EnsemblePart **ensPartPtr; /* returns: new ensemble part */ +{ + int i, pos, size; + EnsemblePart** partList; + EnsemblePart* part; + + /* + * If a matching entry was found, then return an error. + */ + if (FindEnsemblePartIndex(ensData, partName, &pos)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "part \"", partName, "\" already exists in ensemble", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Otherwise, make room for a new entry. Keep the parts in + * lexicographical order, so we can search them quickly + * later. + */ + if (ensData->numParts >= ensData->maxParts) { + size = ensData->maxParts*sizeof(EnsemblePart*); + partList = (EnsemblePart**)ckalloc((unsigned)2*size); + memcpy((VOID*)partList, (VOID*)ensData->parts, (size_t)size); + ckfree((char*)ensData->parts); + + ensData->parts = partList; + ensData->maxParts *= 2; + } + + for (i=ensData->numParts; i > pos; i--) { + ensData->parts[i] = ensData->parts[i-1]; + } + ensData->numParts++; + + part = (EnsemblePart*)ckalloc(sizeof(EnsemblePart)); + part->name = (char*)ckalloc((unsigned)(strlen(partName)+1)); + strcpy(part->name, partName); + part->cmdPtr = NULL; + part->usage = NULL; + part->ensemble = ensData; + + ensData->parts[pos] = part; + + /* + * Compare the new part against the one on either side of + * it. Determine how many letters are needed in each part + * to guarantee that an abbreviated form is unique. Update + * the parts on either side as well, since they are influenced + * by the new part. + */ + ComputeMinChars(ensData, pos); + ComputeMinChars(ensData, pos-1); + ComputeMinChars(ensData, pos+1); + + *ensPartPtr = part; + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * DeleteEnsemblePart -- + * + * Deletes a single part from an ensemble. The part must have + * been created previously by CreateEnsemblePart. + * + * If the part has a delete proc, then it is called to free the + * associated client data. + * + * Results: + * None. + * + * Side effects: + * Delete proc is called. + * + *---------------------------------------------------------------------- + */ +static void +DeleteEnsemblePart(ensPart) + EnsemblePart *ensPart; /* part being destroyed */ +{ + int i, pos; + Command *cmdPtr; + Ensemble *ensData; + cmdPtr = ensPart->cmdPtr; + + /* + * If this part has a delete proc, then call it to free + * up the client data. + */ + if (cmdPtr->deleteData && cmdPtr->deleteProc) { + (*cmdPtr->deleteProc)(cmdPtr->deleteData); + } + ckfree((char*)cmdPtr); + + /* + * Find this part within its ensemble, and remove it from + * the list of parts. + */ + if (FindEnsemblePartIndex(ensPart->ensemble, ensPart->name, &pos)) { + ensData = ensPart->ensemble; + for (i=pos; i < ensData->numParts-1; i++) { + ensData->parts[i] = ensData->parts[i+1]; + } + ensData->numParts--; + } + + /* + * Free the memory associated with the part. + */ + if (ensPart->usage) { + ckfree(ensPart->usage); + } + ckfree(ensPart->name); + ckfree((char*)ensPart); +} + + +/* + *---------------------------------------------------------------------- + * + * FindEnsemblePart -- + * + * Searches for a part name within an ensemble. Recognizes + * unique abbreviations for part names. + * + * Results: + * If the part name is not a unique abbreviation, this procedure + * returns TCL_ERROR. Otherwise, it returns TCL_OK. If the + * part can be found, "rensPart" returns a pointer to the part. + * Otherwise, it returns NULL. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +FindEnsemblePart(interp, ensData, partName, rensPart) + Tcl_Interp *interp; /* interpreter containing the ensemble */ + Ensemble *ensData; /* ensemble being searched */ + char* partName; /* name of the desired part */ + EnsemblePart **rensPart; /* returns: pointer to the desired part */ +{ + int pos = 0; + int first, last, nlen; + int i, cmp; + + *rensPart = NULL; + + /* + * Search for the desired part name. + * All parts are in lexicographical order, so use a + * binary search to find the part quickly. Match only + * as many characters as are included in the specified + * part name. + */ + first = 0; + last = ensData->numParts-1; + nlen = strlen(partName); + + while (last >= first) { + pos = (first+last)/2; + if (*partName == *ensData->parts[pos]->name) { + cmp = strncmp(partName, ensData->parts[pos]->name, nlen); + if (cmp == 0) { + break; /* found it! */ + } + } + else if (*partName < *ensData->parts[pos]->name) { + cmp = -1; + } + else { + cmp = 1; + } + + if (cmp > 0) { + first = pos+1; + } else { + last = pos-1; + } + } + + /* + * If a matching entry could not be found, then quit. + */ + if (last < first) { + return TCL_OK; + } + + /* + * If a matching entry was found, there may be some ambiguity + * if the user did not specify enough characters. Find the + * top-most match in the list, and see if the part name has + * enough characters. If there are two parts like "foo" + * and "food", this allows us to match "foo" exactly. + */ + if (nlen < ensData->parts[pos]->minChars) { + while (pos > 0) { + pos--; + if (strncmp(partName, ensData->parts[pos]->name, nlen) != 0) { + pos++; + break; + } + } + } + if (nlen < ensData->parts[pos]->minChars) { + Tcl_Obj *resultPtr = Tcl_NewStringObj((char*)NULL, 0); + + Tcl_AppendStringsToObj(resultPtr, + "ambiguous option \"", partName, "\": should be one of...", + (char*)NULL); + + for (i=pos; i < ensData->numParts; i++) { + if (strncmp(partName, ensData->parts[i]->name, nlen) != 0) { + break; + } + Tcl_AppendToObj(resultPtr, "\n ", 3); + GetEnsemblePartUsage(ensData->parts[i], resultPtr); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_ERROR; + } + + /* + * Found a match. Return the desired part. + */ + *rensPart = ensData->parts[pos]; + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * FindEnsemblePartIndex -- + * + * Searches for a part name within an ensemble. The part name + * must be an exact match for an existing part name in the + * ensemble. This procedure is useful for managing (i.e., + * creating and deleting) parts in an ensemble. + * + * Results: + * If an exact match is found, this procedure returns + * non-zero, along with the index of the part in posPtr. + * Otherwise, it returns zero, along with an index in posPtr + * indicating where the part should be. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static int +FindEnsemblePartIndex(ensData, partName, posPtr) + Ensemble *ensData; /* ensemble being searched */ + char *partName; /* name of desired part */ + int *posPtr; /* returns: index for part */ +{ + int pos = 0; + int first, last; + int cmp; + + /* + * Search for the desired part name. + * All parts are in lexicographical order, so use a + * binary search to find the part quickly. + */ + first = 0; + last = ensData->numParts-1; + + while (last >= first) { + pos = (first+last)/2; + if (*partName == *ensData->parts[pos]->name) { + cmp = strcmp(partName, ensData->parts[pos]->name); + if (cmp == 0) { + break; /* found it! */ + } + } + else if (*partName < *ensData->parts[pos]->name) { + cmp = -1; + } + else { + cmp = 1; + } + + if (cmp > 0) { + first = pos+1; + } else { + last = pos-1; + } + } + + if (last >= first) { + *posPtr = pos; + return 1; + } + *posPtr = first; + return 0; +} + + +/* + *---------------------------------------------------------------------- + * + * ComputeMinChars -- + * + * Compares part names on an ensemble's part list and + * determines the minimum number of characters needed for a + * unique abbreviation. The parts on either side of a + * particular part index are compared. As long as there is + * a part on one side or the other, this procedure updates + * the parts to have the proper minimum abbreviations. + * + * Results: + * None. + * + * Side effects: + * Updates three parts within the ensemble to remember + * the minimum abbreviations. + * + *---------------------------------------------------------------------- + */ +static void +ComputeMinChars(ensData, pos) + Ensemble *ensData; /* ensemble being modified */ + int pos; /* index of part being updated */ +{ + int min, max; + char *p, *q; + + /* + * If the position is invalid, do nothing. + */ + if (pos < 0 || pos >= ensData->numParts) { + return; + } + + /* + * Start by assuming that only the first letter is required + * to uniquely identify this part. Then compare the name + * against each neighboring part to determine the real minimum. + */ + ensData->parts[pos]->minChars = 1; + + if (pos-1 >= 0) { + p = ensData->parts[pos]->name; + q = ensData->parts[pos-1]->name; + for (min=1; *p == *q && *p != '\0' && *q != '\0'; min++) { + p++; + q++; + } + if (min > ensData->parts[pos]->minChars) { + ensData->parts[pos]->minChars = min; + } + } + + if (pos+1 < ensData->numParts) { + p = ensData->parts[pos]->name; + q = ensData->parts[pos+1]->name; + for (min=1; *p == *q && *p != '\0' && *q != '\0'; min++) { + p++; + q++; + } + if (min > ensData->parts[pos]->minChars) { + ensData->parts[pos]->minChars = min; + } + } + + max = strlen(ensData->parts[pos]->name); + if (ensData->parts[pos]->minChars > max) { + ensData->parts[pos]->minChars = max; + } +} + + +/* + *---------------------------------------------------------------------- + * + * HandleEnsemble -- + * + * Invoked by Tcl whenever the user issues an ensemble-style + * command. Handles commands of the form: + * + * ? ...? + * + * Looks for the within the ensemble, and if it + * exists, the procedure transfers control to it. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything + * goes wrong. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +HandleEnsemble(clientData, interp, objc, objv) + ClientData clientData; /* ensemble data */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + Ensemble *ensData = (Ensemble*)clientData; + + int i, result; + Command *cmdPtr; + EnsemblePart *ensPart; + char *partName; + int partNameLen; + Tcl_Obj *cmdlinePtr, *chainObj; + int cmdlinec; + Tcl_Obj **cmdlinev; + + /* + * If a part name is not specified, return an error that + * summarizes the usage for this ensemble. + */ + if (objc < 2) { + Tcl_Obj *resultPtr = Tcl_NewStringObj( + "wrong # args: should be one of...\n", -1); + + GetEnsembleUsage(ensData, resultPtr); + Tcl_SetObjResult(interp, resultPtr); + return TCL_ERROR; + } + + /* + * Lookup the desired part. If an ambiguous abbrevition is + * found, return an error immediately. + */ + partName = Tcl_GetStringFromObj(objv[1], &partNameLen); + if (FindEnsemblePart(interp, ensData, partName, &ensPart) != TCL_OK) { + return TCL_ERROR; + } + + /* + * If the part was not found, then look for an "@error" part + * to handle the error. + */ + if (ensPart == NULL) { + if (FindEnsemblePart(interp, ensData, "@error", &ensPart) != TCL_OK) { + return TCL_ERROR; + } + if (ensPart != NULL) { + cmdPtr = (Command*)ensPart->cmdPtr; + result = (*cmdPtr->objProc)(cmdPtr->objClientData, + interp, objc, objv); + return result; + } + } + if (ensPart == NULL) { + return Itcl_EnsembleErrorCmd((ClientData)ensData, + interp, objc-1, objv+1); + } + + /* + * Pass control to the part, and return the result. + */ + chainObj = Tcl_NewObj(); + chainObj->bytes = NULL; + chainObj->typePtr = &itclEnsInvocType; + chainObj->internalRep.twoPtrValue.ptr1 = (VOID *) ensPart; + Tcl_IncrRefCount(objv[1]); + chainObj->internalRep.twoPtrValue.ptr2 = (VOID *) objv[0]; + Tcl_IncrRefCount(objv[0]); + + cmdlinePtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, cmdlinePtr, chainObj); + for (i=2; i < objc; i++) { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, cmdlinePtr, objv[i]); + } + Tcl_IncrRefCount(cmdlinePtr); + + result = Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr, + &cmdlinec, &cmdlinev); + + if (result == TCL_OK) { + cmdPtr = (Command*)ensPart->cmdPtr; + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, + cmdlinec, cmdlinev); + } + Tcl_DecrRefCount(cmdlinePtr); + + return result; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_EnsembleCmd -- + * + * Invoked by Tcl whenever the user issues the "ensemble" + * command to manipulate an ensemble. Handles the following + * syntax: + * + * ensemble ? ...? + * ensemble { + * part + * ensemble { + * ... + * } + * } + * + * Finds or creates the ensemble , and then executes + * the commands to add parts. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything + * goes wrong. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +int +Itcl_EnsembleCmd(clientData, interp, objc, objv) + ClientData clientData; /* ensemble data */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + int status; + char *ensName; + EnsembleParser *ensInfo; + Ensemble *ensData, *savedEnsData; + EnsemblePart *ensPart; + Tcl_Command cmd; + Command *cmdPtr; + Tcl_Obj *objPtr; + + /* + * Make sure that an ensemble name was specified. + */ + if (objc < 2) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"", + Tcl_GetStringFromObj(objv[0], (int*)NULL), + " name ?command arg arg...?\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * If this is the "ensemble" command in the main interpreter, + * then the client data will be null. Otherwise, it is + * the "ensemble" command in the ensemble body parser, and + * the client data indicates which ensemble we are modifying. + */ + if (clientData) { + ensInfo = (EnsembleParser*)clientData; + } else { + ensInfo = GetEnsembleParser(interp); + } + ensData = ensInfo->ensData; + + /* + * Find or create the desired ensemble. If an ensemble is + * being built, then this "ensemble" command is enclosed in + * another "ensemble" command. Use the current ensemble as + * the parent, and find or create an ensemble part within it. + */ + ensName = Tcl_GetStringFromObj(objv[1], (int*)NULL); + + if (ensData) { + if (FindEnsemblePart(interp, ensData, ensName, &ensPart) != TCL_OK) { + ensPart = NULL; + } + if (ensPart == NULL) { + if (CreateEnsemble(interp, ensData, ensName) != TCL_OK) { + return TCL_ERROR; + } + if (FindEnsemblePart(interp, ensData, ensName, &ensPart) + != TCL_OK) { + panic("Itcl_EnsembleCmd: can't create ensemble"); + } + } + + cmdPtr = (Command*)ensPart->cmdPtr; + if (cmdPtr->deleteProc != DeleteEnsemble) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "part \"", Tcl_GetStringFromObj(objv[1], (int*)NULL), + "\" is not an ensemble", + (char*)NULL); + return TCL_ERROR; + } + ensData = (Ensemble*)cmdPtr->objClientData; + } + + /* + * Otherwise, the desired ensemble is a top-level ensemble. + * Find or create the access command for the ensemble, and + * then get its data. + */ + else { + cmd = Tcl_FindCommand(interp, ensName, (Tcl_Namespace*)NULL, 0); + if (cmd == NULL) { + if (CreateEnsemble(interp, (Ensemble*)NULL, ensName) + != TCL_OK) { + return TCL_ERROR; + } + cmd = Tcl_FindCommand(interp, ensName, (Tcl_Namespace*)NULL, 0); + } + cmdPtr = (Command*)cmd; + + if (cmdPtr == NULL || cmdPtr->deleteProc != DeleteEnsemble) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "command \"", Tcl_GetStringFromObj(objv[1], (int*)NULL), + "\" is not an ensemble", + (char*)NULL); + return TCL_ERROR; + } + ensData = (Ensemble*)cmdPtr->objClientData; + } + + /* + * At this point, we have the data for the ensemble that is + * being manipulated. Plug this into the parser, and then + * interpret the rest of the arguments in the ensemble parser. + */ + status = TCL_OK; + savedEnsData = ensInfo->ensData; + ensInfo->ensData = ensData; + + if (objc == 3) { + /* CYGNUS LOCAL - fix for Tcl8.1 */ +#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + status = Tcl_EvalObj(ensInfo->parser, objv[2]); +#else + status = Tcl_EvalObj(ensInfo->parser, objv[2], 0); +#endif + } + else if (objc > 3) { + objPtr = Tcl_NewListObj(objc-2, objv+2); +#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + status = Tcl_EvalObj(ensInfo->parser, objPtr); +#else + Tcl_IncrRefCount(objPtr); + status = Tcl_EvalObj(ensInfo->parser, objPtr, 0); +#endif + /* END CYGNUS LOCAL */ + Tcl_DecrRefCount(objPtr); /* we're done with the object */ + } + + /* + * Copy the result from the parser interpreter to the + * master interpreter. If an error was encountered, + * copy the error info first, and then set the result. + * Otherwise, the offending command is reported twice. + */ + if (status == TCL_ERROR) { + char *errInfo = Tcl_GetVar2(ensInfo->parser, "::errorInfo", + (char*)NULL, TCL_GLOBAL_ONLY); + + if (errInfo) { + Tcl_AddObjErrorInfo(interp, errInfo, -1); + } + + if (objc == 3) { + char msg[128]; + sprintf(msg, "\n (\"ensemble\" body line %d)", + ensInfo->parser->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } + } + Tcl_SetObjResult(interp, Tcl_GetObjResult(ensInfo->parser)); + + ensInfo->ensData = savedEnsData; + return status; +} + + +/* + *---------------------------------------------------------------------- + * + * GetEnsembleParser -- + * + * Returns the slave interpreter that acts as a parser for + * the body of an "ensemble" definition. The first time that + * this is called for an interpreter, the parser is created + * and registered as associated data. After that, it is + * simply returned. + * + * Results: + * Returns a pointer to the ensemble parser data structure. + * + * Side effects: + * On the first call, the ensemble parser is created and + * registered as "itcl_ensembleParser" with the interpreter. + * + *---------------------------------------------------------------------- + */ +static EnsembleParser* +GetEnsembleParser(interp) + Tcl_Interp *interp; /* interpreter handling the ensemble */ +{ + Namespace *nsPtr; + Tcl_Namespace *childNs; + EnsembleParser *ensInfo; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_Command cmd; + + /* + * Look for an existing ensemble parser. If it is found, + * return it immediately. + */ + ensInfo = (EnsembleParser*) Tcl_GetAssocData(interp, + "itcl_ensembleParser", NULL); + + if (ensInfo) { + return ensInfo; + } + + /* + * Create a slave interpreter that can be used to parse + * the body of an ensemble definition. + */ + ensInfo = (EnsembleParser*)ckalloc(sizeof(EnsembleParser)); + ensInfo->master = interp; + ensInfo->parser = Tcl_CreateInterp(); + ensInfo->ensData = NULL; + + /* + * Remove all namespaces and all normal commands from the + * parser interpreter. + */ + nsPtr = (Namespace*)Tcl_GetGlobalNamespace(ensInfo->parser); + + for (hPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { + + childNs = (Tcl_Namespace*)Tcl_GetHashValue(hPtr); + Tcl_DeleteNamespace(childNs); + } + + for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { + + cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); + Tcl_DeleteCommandFromToken(ensInfo->parser, cmd); + } + + /* + * Add the allowed commands to the parser interpreter: + * part, delete, ensemble + */ + Tcl_CreateObjCommand(ensInfo->parser, "part", Itcl_EnsPartCmd, + (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(ensInfo->parser, "option", Itcl_EnsPartCmd, + (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(ensInfo->parser, "ensemble", Itcl_EnsembleCmd, + (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL); + + /* + * Install the parser data, so we'll have it the next time + * we call this procedure. + */ + (void) Tcl_SetAssocData(interp, "itcl_ensembleParser", + DeleteEnsParser, (ClientData)ensInfo); + + return ensInfo; +} + + +/* + *---------------------------------------------------------------------- + * + * DeleteEnsParser -- + * + * Called when an interpreter is destroyed to clean up the + * ensemble parser within it. Destroys the slave interpreter + * and frees up the data associated with it. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +static void +DeleteEnsParser(clientData, interp) + ClientData clientData; /* client data for ensemble-related commands */ + Tcl_Interp *interp; /* interpreter containing the data */ +{ + EnsembleParser* ensInfo = (EnsembleParser*)clientData; + Tcl_DeleteInterp(ensInfo->parser); + ckfree((char*)ensInfo); +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_EnsPartCmd -- + * + * Invoked by Tcl whenever the user issues the "part" command + * to manipulate an ensemble. This command can only be used + * inside the "ensemble" command, which handles ensembles. + * Handles the following syntax: + * + * ensemble { + * part + * } + * + * Adds a new part called to the ensemble. If a + * part already exists with that name, it is an error. The + * new part is handled just like an ordinary Tcl proc, with + * a list of and a of code to execute. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything + * goes wrong. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +int +Itcl_EnsPartCmd(clientData, interp, objc, objv) + ClientData clientData; /* ensemble data */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + EnsembleParser *ensInfo = (EnsembleParser*)clientData; + Ensemble *ensData = (Ensemble*)ensInfo->ensData; + + int status, varArgs, space; + char *partName, *usage; + Proc *procPtr; + Command *cmdPtr; + CompiledLocal *localPtr; + EnsemblePart *ensPart; + Tcl_DString buffer; + + if (objc != 4) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"", + Tcl_GetStringFromObj(objv[0], (int*)NULL), + " name args body\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Create a Tcl-style proc definition using the specified args + * and body. This is not a proc in the usual sense. It belongs + * to the namespace that contains the ensemble, but it is + * accessed through the ensemble, not through a Tcl command. + */ + partName = Tcl_GetStringFromObj(objv[1], (int*)NULL); + cmdPtr = (Command*)ensData->cmd; + + if (TclCreateProc(interp, cmdPtr->nsPtr, partName, objv[2], objv[3], + &procPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Deduce the usage information from the argument list. + * We'll register this when we create the part, in a moment. + */ + Tcl_DStringInit(&buffer); + varArgs = 0; + space = 0; + + for (localPtr=procPtr->firstLocalPtr; + localPtr != NULL; + localPtr=localPtr->nextPtr) { + + if (TclIsVarArgument(localPtr)) { + varArgs = 0; + if (strcmp(localPtr->name, "args") == 0) { + varArgs = 1; + } + else if (localPtr->defValuePtr) { + if (space) { + Tcl_DStringAppend(&buffer, " ", 1); + } + Tcl_DStringAppend(&buffer, "?", 1); + Tcl_DStringAppend(&buffer, localPtr->name, -1); + Tcl_DStringAppend(&buffer, "?", 1); + space = 1; + } + else { + if (space) { + Tcl_DStringAppend(&buffer, " ", 1); + } + Tcl_DStringAppend(&buffer, localPtr->name, -1); + space = 1; + } + } + } + if (varArgs) { + if (space) { + Tcl_DStringAppend(&buffer, " ", 1); + } + Tcl_DStringAppend(&buffer, "?arg arg ...?", 13); + } + + usage = Tcl_DStringValue(&buffer); + + /* + * Create a new part within the ensemble. If successful, + * plug the command token into the proc; we'll need it later + * if we try to compile the Tcl code for the part. If + * anything goes wrong, clean up before bailing out. + */ + status = AddEnsemblePart(interp, ensData, partName, usage, + TclObjInterpProc, (ClientData)procPtr, TclProcDeleteProc, + &ensPart); + + if (status == TCL_OK) { + procPtr->cmdPtr = ensPart->cmdPtr; + } else { + TclProcDeleteProc((ClientData)procPtr); + } + Tcl_DStringFree(&buffer); + + return status; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_EnsembleErrorCmd -- + * + * Invoked when the user tries to access an unknown part for + * an ensemble. Acts as the default handler for the "@error" + * part. Generates an error message like: + * + * bad option "foo": should be one of... + * info args procname + * info body procname + * info cmdcount + * ... + * + * Results: + * Always returns TCL_OK. + * + * Side effects: + * Returns the error message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +int +Itcl_EnsembleErrorCmd(clientData, interp, objc, objv) + ClientData clientData; /* ensemble info */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + Ensemble *ensData = (Ensemble*)clientData; + + char *cmdName; + Tcl_Obj *objPtr; + + cmdName = Tcl_GetStringFromObj(objv[0], (int*)NULL); + + objPtr = Tcl_NewStringObj((char*)NULL, 0); + Tcl_AppendStringsToObj(objPtr, + "bad option \"", cmdName, "\": should be one of...\n", + (char*)NULL); + GetEnsembleUsage(ensData, objPtr); + + Tcl_SetObjResult(interp, objPtr); + return TCL_ERROR; +} + + +/* + *---------------------------------------------------------------------- + * + * FreeEnsInvocInternalRep -- + * + * Frees the resources associated with an ensembleInvoc object's + * internal representation. + * + * Results: + * None. + * + * Side effects: + * Decrements the ref count of the two objects referenced by + * this object. If there are no more uses, this will free + * the other objects. + * + *---------------------------------------------------------------------- + */ +static void +FreeEnsInvocInternalRep(objPtr) + register Tcl_Obj *objPtr; /* namespName object with internal + * representation to free */ +{ + Tcl_Obj *prevArgObj = (Tcl_Obj*)objPtr->internalRep.twoPtrValue.ptr2; + + if (prevArgObj) { + Tcl_DecrRefCount(prevArgObj); + } +} + + +/* + *---------------------------------------------------------------------- + * + * DupEnsInvocInternalRep -- + * + * Initializes the internal representation of an ensembleInvoc + * object to a copy of the internal representation of + * another ensembleInvoc object. + * + * This shouldn't be called. Normally, a temporary ensembleInvoc + * object is created while an ensemble call is in progress. + * This object may be converted to string form if an error occurs. + * It does not stay around long, and there is no reason for it + * to be duplicated. + * + * Results: + * None. + * + * Side effects: + * copyPtr's internal rep is set to duplicates of the objects + * pointed to by srcPtr's internal rep. + * + *---------------------------------------------------------------------- + */ +static void +DupEnsInvocInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + EnsemblePart *ensPart = (EnsemblePart*)srcPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *prevArgObj = (Tcl_Obj*)srcPtr->internalRep.twoPtrValue.ptr2; + Tcl_Obj *objPtr; + + copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) ensPart; + + if (prevArgObj) { + objPtr = Tcl_DuplicateObj(prevArgObj); + copyPtr->internalRep.twoPtrValue.ptr2 = (VOID *) objPtr; + } +} + + +/* + *---------------------------------------------------------------------- + * + * SetEnsInvocFromAny -- + * + * Generates the internal representation for an ensembleInvoc + * object. This conversion really shouldn't take place. + * Normally, a temporary ensembleInvoc object is created while + * an ensemble call is in progress. This object may be converted + * to string form if an error occurs. But there is no reason + * for any other object to be converted to ensembleInvoc form. + * + * Results: + * Always returns TCL_OK. + * + * Side effects: + * The string representation is saved as if it were the + * command line argument for the ensemble invocation. The + * reference to the ensemble part is set to NULL. + * + *---------------------------------------------------------------------- + */ +static int +SetEnsInvocFromAny(interp, objPtr) + Tcl_Interp *interp; /* Determines the context for + name resolution */ + register Tcl_Obj *objPtr; /* The object to convert */ +{ + int length; + char *name; + Tcl_Obj *argObj; + + /* + * Get objPtr's string representation. + * Make it up-to-date if necessary. + * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS NULLS. + */ + name = Tcl_GetStringFromObj(objPtr, &length); + + /* + * Make an argument object to contain the string, and + * set the ensemble part definition to NULL. At this point, + * we don't know anything about an ensemble, so we'll just + * keep the string around as if it were the command line + * invocation. + */ + argObj = Tcl_NewStringObj(name, -1); + + /* + * Free the old representation and install a new one. + */ + if (objPtr->typePtr && objPtr->typePtr->freeIntRepProc != NULL) { + (*objPtr->typePtr->freeIntRepProc)(objPtr); + } + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) NULL; + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) argObj; + objPtr->typePtr = &itclEnsInvocType; + + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfEnsInvoc -- + * + * Updates the string representation for an ensembleInvoc object. + * This is called when an error occurs in an ensemble part, when + * the code tries to print objv[0] as the command name. This + * code automatically chains together all of the names leading + * to the ensemble part, so the error message references the + * entire command, not just the part name. + * + * Note: This procedure does not free an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to the full command name for + * the ensemble part. + * + *---------------------------------------------------------------------- + */ +static void +UpdateStringOfEnsInvoc(objPtr) + register Tcl_Obj *objPtr; /* NamespName obj to update string rep. */ +{ + EnsemblePart *ensPart = (EnsemblePart*)objPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *prevArgObj = (Tcl_Obj*)objPtr->internalRep.twoPtrValue.ptr2; + + Tcl_DString buffer; + int length; + char *name; + + Tcl_DStringInit(&buffer); + + /* + * Get the string representation for the previous argument. + * This will force each ensembleInvoc argument up the line + * to get its string representation. So we will get the + * original command name, followed by the sub-ensemble, and + * the next sub-ensemble, and so on. Then add the part + * name from the ensPart argument. + */ + if (prevArgObj) { + name = Tcl_GetStringFromObj(prevArgObj, &length); + Tcl_DStringAppend(&buffer, name, length); + } + + if (ensPart) { + Tcl_DStringAppendElement(&buffer, ensPart->name); + } + + /* + * The following allocates an empty string on the heap if name is "" + * (e.g., if the internal rep is NULL). + */ + name = Tcl_DStringValue(&buffer); + length = strlen(name); + objPtr->bytes = (char *) ckalloc((unsigned) (length + 1)); + memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length); + objPtr->bytes[length] = '\0'; + objPtr->length = length; +}

itcl_ensemble.c Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: itcl_linkage.c =================================================================== --- itcl_linkage.c (nonexistent) +++ itcl_linkage.c (revision 1765) @@ -0,0 +1,327 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * This part adds a mechanism for integrating C procedures into + * [incr Tcl] classes as methods and procs. Each C procedure must + * either be declared via Itcl_RegisterC() or dynamically loaded. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * RCS: $Id: itcl_linkage.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $ + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +/* + * These records store the pointers for all "RegisterC" functions. + */ +typedef struct ItclCfunc { + Tcl_CmdProc *argCmdProc; /* old-style (argc,argv) command handler */ + Tcl_ObjCmdProc *objCmdProc; /* new (objc,objv) command handler */ + ClientData clientData; /* client data passed into this function */ + Tcl_CmdDeleteProc *deleteProc; /* proc called to free clientData */ +} ItclCfunc; + +static Tcl_HashTable* ItclGetRegisteredProcs _ANSI_ARGS_((Tcl_Interp *interp)); +static void ItclFreeC _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); + + +/* + * ------------------------------------------------------------------------ + * Itcl_RegisterC() + * + * Used to associate a symbolic name with an (argc,argv) C procedure + * that handles a Tcl command. Procedures that are registered in this + * manner can be referenced in the body of an [incr Tcl] class + * definition to specify C procedures to acting as methods/procs. + * Usually invoked in an initialization routine for an extension, + * called out in Tcl_AppInit() at the start of an application. + * + * Each symbolic procedure can have an arbitrary client data value + * associated with it. This value is passed into the command + * handler whenever it is invoked. + * + * A symbolic procedure name can be used only once for a given style + * (arg/obj) handler. If the name is defined with an arg-style + * handler, it can be redefined with an obj-style handler; or if + * the name is defined with an obj-style handler, it can be redefined + * with an arg-style handler. In either case, any previous client + * data is discarded and the new client data is remembered. However, + * if a name is redefined to a different handler of the same style, + * this procedure returns an error. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error message + * in interp->result) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +int +Itcl_RegisterC(interp, name, proc, clientData, deleteProc) + Tcl_Interp *interp; /* interpreter handling this registration */ + char *name; /* symbolic name for procedure */ + Tcl_CmdProc *proc; /* procedure handling Tcl command */ + ClientData clientData; /* client data associated with proc */ + Tcl_CmdDeleteProc *deleteProc; /* proc called to free up client data */ +{ + int newEntry; + Tcl_HashEntry *entry; + Tcl_HashTable *procTable; + ItclCfunc *cfunc; + + /* + * Make sure that a proc was specified. + */ + if (!proc) { + Tcl_AppendResult(interp, "initialization error: null pointer for ", + "C procedure \"", name, "\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Add a new entry for the given procedure. If an entry with + * this name already exists, then make sure that it was defined + * with the same proc. + */ + procTable = ItclGetRegisteredProcs(interp); + entry = Tcl_CreateHashEntry(procTable, name, &newEntry); + if (!newEntry) { + cfunc = (ItclCfunc*)Tcl_GetHashValue(entry); + if (cfunc->argCmdProc != NULL && cfunc->argCmdProc != proc) { + Tcl_AppendResult(interp, "initialization error: C procedure ", + "with name \"", name, "\" already defined", + (char*)NULL); + return TCL_ERROR; + } + + if (cfunc->deleteProc != NULL) { + (*cfunc->deleteProc)(cfunc->clientData); + } + } + else { + cfunc = (ItclCfunc*)ckalloc(sizeof(ItclCfunc)); + cfunc->objCmdProc = NULL; + } + + cfunc->argCmdProc = proc; + cfunc->clientData = clientData; + cfunc->deleteProc = deleteProc; + + Tcl_SetHashValue(entry, (ClientData)cfunc); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_RegisterObjC() + * + * Used to associate a symbolic name with an (objc,objv) C procedure + * that handles a Tcl command. Procedures that are registered in this + * manner can be referenced in the body of an [incr Tcl] class + * definition to specify C procedures to acting as methods/procs. + * Usually invoked in an initialization routine for an extension, + * called out in Tcl_AppInit() at the start of an application. + * + * Each symbolic procedure can have an arbitrary client data value + * associated with it. This value is passed into the command + * handler whenever it is invoked. + * + * A symbolic procedure name can be used only once for a given style + * (arg/obj) handler. If the name is defined with an arg-style + * handler, it can be redefined with an obj-style handler; or if + * the name is defined with an obj-style handler, it can be redefined + * with an arg-style handler. In either case, any previous client + * data is discarded and the new client data is remembered. However, + * if a name is redefined to a different handler of the same style, + * this procedure returns an error. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error message + * in interp->result) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +int +Itcl_RegisterObjC(interp, name, proc, clientData, deleteProc) + Tcl_Interp *interp; /* interpreter handling this registration */ + char *name; /* symbolic name for procedure */ + Tcl_ObjCmdProc *proc; /* procedure handling Tcl command */ + ClientData clientData; /* client data associated with proc */ + Tcl_CmdDeleteProc *deleteProc; /* proc called to free up client data */ +{ + int newEntry; + Tcl_HashEntry *entry; + Tcl_HashTable *procTable; + ItclCfunc *cfunc; + + /* + * Make sure that a proc was specified. + */ + if (!proc) { + Tcl_AppendResult(interp, "initialization error: null pointer for ", + "C procedure \"", name, "\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Add a new entry for the given procedure. If an entry with + * this name already exists, then make sure that it was defined + * with the same proc. + */ + procTable = ItclGetRegisteredProcs(interp); + entry = Tcl_CreateHashEntry(procTable, name, &newEntry); + if (!newEntry) { + cfunc = (ItclCfunc*)Tcl_GetHashValue(entry); + if (cfunc->objCmdProc != NULL && cfunc->objCmdProc != proc) { + Tcl_AppendResult(interp, "initialization error: C procedure ", + "with name \"", name, "\" already defined", + (char*)NULL); + return TCL_ERROR; + } + + if (cfunc->deleteProc != NULL) { + (*cfunc->deleteProc)(cfunc->clientData); + } + } + else { + cfunc = (ItclCfunc*)ckalloc(sizeof(ItclCfunc)); + cfunc->argCmdProc = NULL; + } + + cfunc->objCmdProc = proc; + cfunc->clientData = clientData; + cfunc->deleteProc = deleteProc; + + Tcl_SetHashValue(entry, (ClientData)cfunc); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_FindC() + * + * Used to query a C procedure via its symbolic name. Looks at the + * list of procedures registered previously by either Itcl_RegisterC + * or Itcl_RegisterObjC and returns pointers to the appropriate + * (argc,argv) or (objc,objv) handlers. Returns non-zero if the + * name is recognized and pointers are returned; returns zero + * otherwise. + * ------------------------------------------------------------------------ + */ +int +Itcl_FindC(interp, name, argProcPtr, objProcPtr, cDataPtr) + Tcl_Interp *interp; /* interpreter handling this registration */ + char *name; /* symbolic name for procedure */ + Tcl_CmdProc **argProcPtr; /* returns (argc,argv) command handler */ + Tcl_ObjCmdProc **objProcPtr; /* returns (objc,objv) command handler */ + ClientData *cDataPtr; /* returns client data */ +{ + Tcl_HashEntry *entry; + Tcl_HashTable *procTable; + ItclCfunc *cfunc; + + *argProcPtr = NULL; /* assume info won't be found */ + *objProcPtr = NULL; + *cDataPtr = NULL; + + if (interp) { + procTable = (Tcl_HashTable*)Tcl_GetAssocData(interp, + "itcl_RegC", (Tcl_InterpDeleteProc**)NULL); + + if (procTable) { + entry = Tcl_FindHashEntry(procTable, name); + if (entry) { + cfunc = (ItclCfunc*)Tcl_GetHashValue(entry); + *argProcPtr = cfunc->argCmdProc; + *objProcPtr = cfunc->objCmdProc; + *cDataPtr = cfunc->clientData; + } + } + } + return (*argProcPtr != NULL || *objProcPtr != NULL); +} + + +/* + * ------------------------------------------------------------------------ + * ItclGetRegisteredProcs() + * + * Returns a pointer to a hash table containing the list of registered + * procs in the specified interpreter. If the hash table does not + * already exist, it is created. + * ------------------------------------------------------------------------ + */ +static Tcl_HashTable* +ItclGetRegisteredProcs(interp) + Tcl_Interp *interp; /* interpreter handling this registration */ +{ + Tcl_HashTable* procTable; + + /* + * If the registration table does not yet exist, then create it. + */ + procTable = (Tcl_HashTable*)Tcl_GetAssocData(interp, "itcl_RegC", + (Tcl_InterpDeleteProc**)NULL); + + if (!procTable) { + procTable = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(procTable, TCL_STRING_KEYS); + Tcl_SetAssocData(interp, "itcl_RegC", ItclFreeC, + (ClientData)procTable); + } + return procTable; +} + + +/* + * ------------------------------------------------------------------------ + * ItclFreeC() + * + * When an interpreter is deleted, this procedure is called to + * free up the associated data created by Itcl_RegisterC and + * Itcl_RegisterObjC. + * ------------------------------------------------------------------------ + */ +static void +ItclFreeC(clientData, interp) + ClientData clientData; /* associated data */ + Tcl_Interp *interp; /* intepreter being deleted */ +{ + Tcl_HashTable *tablePtr = (Tcl_HashTable*)clientData; + Tcl_HashSearch place; + Tcl_HashEntry *entry; + ItclCfunc *cfunc; + + entry = Tcl_FirstHashEntry(tablePtr, &place); + while (entry) { + cfunc = (ItclCfunc*)Tcl_GetHashValue(entry); + + if (cfunc->deleteProc != NULL) { + (*cfunc->deleteProc)(cfunc->clientData); + } + ckfree ( (char*)cfunc ); + entry = Tcl_NextHashEntry(&place); + } + + Tcl_DeleteHashTable(tablePtr); + ckfree((char*)tablePtr); +}

itcl_linkage.c Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: itcl_parse.c =================================================================== --- itcl_parse.c (nonexistent) +++ itcl_parse.c (revision 1765) @@ -0,0 +1,1086 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * Procedures in this file support the new syntax for [incr Tcl] + * class definitions: + * + * itcl_class { + * inherit ... + * + * constructor {} ?{}? {} + * destructor {} + * + * method {} {} + * proc {} {} + * variable ?? ?? + * common ?? + * + * public ?...? + * protected ?...? + * private ?...? + * } + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * RCS: $Id: itcl_parse.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $ + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +/* + * Info needed for public/protected/private commands: + */ +typedef struct ProtectionCmdInfo { + int pLevel; /* protection level */ + ItclObjectInfo *info; /* info regarding all known objects */ +} ProtectionCmdInfo; + +/* + * FORWARD DECLARATIONS + */ +static void ItclFreeParserCommandData _ANSI_ARGS_((char* cdata)); + + +/* + * ------------------------------------------------------------------------ + * Itcl_ParseInit() + * + * Invoked by Itcl_Init() whenever a new interpeter is created to add + * [incr Tcl] facilities. Adds the commands needed to parse class + * definitions. + * ------------------------------------------------------------------------ + */ +int +Itcl_ParseInit(interp, info) + Tcl_Interp *interp; /* interpreter to be updated */ + ItclObjectInfo *info; /* info regarding all known objects */ +{ + Tcl_Namespace *parserNs; + ProtectionCmdInfo *pInfo; + + /* + * Create the "itcl::parser" namespace used to parse class + * definitions. + */ + parserNs = Tcl_CreateNamespace(interp, "::itcl::parser", + (ClientData)info, Itcl_ReleaseData); + + if (!parserNs) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + " (cannot initialize itcl parser)", + (char*)NULL); + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)info); + + /* + * Add commands for parsing class definitions. + */ + Tcl_CreateObjCommand(interp, "::itcl::parser::inherit", + Itcl_ClassInheritCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::parser::constructor", + Itcl_ClassConstructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::parser::destructor", + Itcl_ClassDestructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::parser::method", + Itcl_ClassMethodCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::parser::proc", + Itcl_ClassProcCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::parser::common", + Itcl_ClassCommonCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::parser::variable", + Itcl_ClassVariableCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); + + pInfo = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo)); + pInfo->pLevel = ITCL_PUBLIC; + pInfo->info = info; + + Tcl_CreateObjCommand(interp, "::itcl::parser::public", + Itcl_ClassProtectionCmd, (ClientData)pInfo, + (Tcl_CmdDeleteProc*) ItclFreeParserCommandData); + + pInfo = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo)); + pInfo->pLevel = ITCL_PROTECTED; + pInfo->info = info; + + Tcl_CreateObjCommand(interp, "::itcl::parser::protected", + Itcl_ClassProtectionCmd, (ClientData)pInfo, + (Tcl_CmdDeleteProc*) ItclFreeParserCommandData); + + pInfo = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo)); + pInfo->pLevel = ITCL_PRIVATE; + pInfo->info = info; + + Tcl_CreateObjCommand(interp, "::itcl::parser::private", + Itcl_ClassProtectionCmd, (ClientData)pInfo, + (Tcl_CmdDeleteProc*) ItclFreeParserCommandData); + + /* + * Set the runtime variable resolver for the parser namespace, + * to control access to "common" data members while parsing + * the class definition. + */ + Tcl_SetNamespaceResolvers(parserNs, (Tcl_ResolveCmdProc*)NULL, + Itcl_ParseVarResolver, (Tcl_ResolveCompiledVarProc*)NULL); + + /* + * Install the "class" command for defining new classes. + */ + Tcl_CreateObjCommand(interp, "::itcl::class", Itcl_ClassCmd, + (ClientData)info, Itcl_ReleaseData); + Itcl_PreserveData((ClientData)info); + + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassCmd() + * + * Invoked by Tcl whenever the user issues an "itcl::class" command to + * specify a class definition. Handles the following syntax: + * + * itcl::class { + * inherit ... + * + * constructor {} ?{}? {} + * destructor {} + * + * method {} {} + * proc {} {} + * variable ?? ?? + * common ?? + * + * public ... + * protected ... + * private ... + * } + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassCmd(clientData, interp, objc, objv) + ClientData clientData; /* info for all known objects */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclObjectInfo* info = (ItclObjectInfo*)clientData; + + int result; + char *className; + Tcl_Namespace *parserNs; + ItclClass *cdefnPtr; + Tcl_CallFrame frame; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name { definition }"); + return TCL_ERROR; + } + className = Tcl_GetStringFromObj(objv[1], (int*)NULL); + + /* + * Find the namespace to use as a parser for the class definition. + * If for some reason it is destroyed, bail out here. + */ + parserNs = Tcl_FindNamespace(interp, "::itcl::parser", + (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); + + if (parserNs == NULL) { + char msg[256]; + sprintf(msg, "\n (while parsing class definition for \"%.100s\")", + className); + Tcl_AddErrorInfo(interp, msg); + return TCL_ERROR; + } + + /* + * Try to create the specified class and its namespace. + */ + if (Itcl_CreateClass(interp, className, info, &cdefnPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Import the built-in commands from the itcl::builtin namespace. + * Do this before parsing the class definition, so methods/procs + * can override the built-in commands. + */ + result = Tcl_Import(interp, cdefnPtr->namesp, "::itcl::builtin::*", + /* allowOverwrite */ 1); + + if (result != TCL_OK) { + char msg[256]; + sprintf(msg, "\n (while installing built-in commands for class \"%.100s\")", className); + Tcl_AddErrorInfo(interp, msg); + + Tcl_DeleteNamespace(cdefnPtr->namesp); + return TCL_ERROR; + } + + /* + * Push this class onto the class definition stack so that it + * becomes the current context for all commands in the parser. + * Activate the parser and evaluate the class definition. + */ + Itcl_PushStack((ClientData)cdefnPtr, &info->cdefnStack); + + result = Tcl_PushCallFrame(interp, &frame, parserNs, + /* isProcCallFrame */ 0); + + if (result == TCL_OK) { + /* CYGNUS LOCAL - Fix for Tcl8.1 */ +#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + result = Tcl_EvalObj(interp, objv[2]); +#else + result = Tcl_EvalObj(interp, objv[2], 0); +#endif + /* END CYGNUS LOCAL */ + Tcl_PopCallFrame(interp); + } + Itcl_PopStack(&info->cdefnStack); + + if (result != TCL_OK) { + char msg[256]; + sprintf(msg, "\n (class \"%.200s\" body line %d)", + className, interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + + Tcl_DeleteNamespace(cdefnPtr->namesp); + return TCL_ERROR; + } + + /* + * At this point, parsing of the class definition has succeeded. + * Add built-in methods such as "configure" and "cget"--as long + * as they don't conflict with those defined in the class. + */ + if (Itcl_InstallBiMethods(interp, cdefnPtr) != TCL_OK) { + Tcl_DeleteNamespace(cdefnPtr->namesp); + return TCL_ERROR; + } + + /* + * Build the name resolution tables for all data members. + */ + Itcl_BuildVirtualTables(cdefnPtr); + + Tcl_ResetResult(interp); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassInheritCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "inherit" command is invoked to define one or more base classes. + * Handles the following syntax: + * + * inherit ?...? + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassInheritCmd(clientData, interp, objc, objv) + ClientData clientData; /* info for all known objects */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclObjectInfo *info = (ItclObjectInfo*)clientData; + ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); + + int result, i, newEntry; + char *token; + Itcl_ListElem *elem, *elem2; + ItclClass *cdPtr, *baseCdefnPtr, *badCdPtr; + ItclHierIter hier; + Itcl_Stack stack; + Tcl_CallFrame frame; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "class ?class...?"); + return TCL_ERROR; + } + + /* + * In "inherit" statement can only be included once in a + * class definition. + */ + elem = Itcl_FirstListElem(&cdefnPtr->bases); + if (elem != NULL) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), "inheritance \"", -1); + + while (elem) { + cdPtr = (ItclClass*)Itcl_GetListValue(elem); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + cdPtr->name, " ", (char*)NULL); + + elem = Itcl_NextListElem(elem); + } + + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\" already defined for class \"", cdefnPtr->fullname, "\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Validate each base class and add it to the "bases" list. + */ + result = Tcl_PushCallFrame(interp, &frame, cdefnPtr->namesp->parentPtr, + /* isProcCallFrame */ 0); + + if (result != TCL_OK) { + return TCL_ERROR; + } + + for (objc--,objv++; objc > 0; objc--,objv++) { + + /* + * Make sure that the base class name is known in the + * parent namespace (currently active). If not, try + * to autoload its definition. + */ + token = Tcl_GetStringFromObj(*objv, (int*)NULL); + baseCdefnPtr = Itcl_FindClass(interp, token, /* autoload */ 1); + if (!baseCdefnPtr) { + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + int errlen; + char *errmsg; + + Tcl_IncrRefCount(resultPtr); + errmsg = Tcl_GetStringFromObj(resultPtr, &errlen); + + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot inherit from \"", token, "\"", + (char*)NULL); + + if (errlen > 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + " (", errmsg, ")", (char*)NULL); + } + Tcl_DecrRefCount(resultPtr); + goto inheritError; + } + + /* + * Make sure that the base class is not the same as the + * class that is being built. + */ + if (baseCdefnPtr == cdefnPtr) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "class \"", cdefnPtr->name, "\" cannot inherit from itself", + (char*)NULL); + goto inheritError; + } + + Itcl_AppendList(&cdefnPtr->bases, (ClientData)baseCdefnPtr); + Itcl_PreserveData((ClientData)baseCdefnPtr); + } + + /* + * Scan through the inheritance list to make sure that no + * class appears twice. + */ + elem = Itcl_FirstListElem(&cdefnPtr->bases); + while (elem) { + elem2 = Itcl_NextListElem(elem); + while (elem2) { + if (Itcl_GetListValue(elem) == Itcl_GetListValue(elem2)) { + cdPtr = (ItclClass*)Itcl_GetListValue(elem); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "class \"", cdefnPtr->fullname, + "\" cannot inherit base class \"", + cdPtr->fullname, "\" more than once", + (char*)NULL); + goto inheritError; + } + elem2 = Itcl_NextListElem(elem2); + } + elem = Itcl_NextListElem(elem); + } + + /* + * Add each base class and all of its base classes into + * the heritage for the current class. Along the way, make + * sure that no class appears twice in the heritage. + */ + Itcl_InitHierIter(&hier, cdefnPtr); + cdPtr = Itcl_AdvanceHierIter(&hier); /* skip the class itself */ + cdPtr = Itcl_AdvanceHierIter(&hier); + while (cdPtr != NULL) { + (void) Tcl_CreateHashEntry(&cdefnPtr->heritage, + (char*)cdPtr, &newEntry); + + if (!newEntry) { + break; + } + cdPtr = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + /* + * Same base class found twice in the hierarchy? + * Then flag error. Show the list of multiple paths + * leading to the same base class. + */ + if (!newEntry) { + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + + badCdPtr = cdPtr; + Tcl_AppendStringsToObj(resultPtr, + "class \"", cdefnPtr->fullname, "\" inherits base class \"", + badCdPtr->fullname, "\" more than once:", + (char*)NULL); + + cdPtr = cdefnPtr; + Itcl_InitStack(&stack); + Itcl_PushStack((ClientData)cdPtr, &stack); + + /* + * Show paths leading to bad base class + */ + while (Itcl_GetStackSize(&stack) > 0) { + cdPtr = (ItclClass*)Itcl_PopStack(&stack); + + if (cdPtr == badCdPtr) { + Tcl_AppendToObj(resultPtr, "\n ", -1); + for (i=0; i < Itcl_GetStackSize(&stack); i++) { + if (Itcl_GetStackValue(&stack, i) == NULL) { + cdPtr = (ItclClass*)Itcl_GetStackValue(&stack, i-1); + Tcl_AppendStringsToObj(resultPtr, + cdPtr->name, "->", + (char*)NULL); + } + } + Tcl_AppendToObj(resultPtr, badCdPtr->name, -1); + } + else if (!cdPtr) { + (void)Itcl_PopStack(&stack); + } + else { + elem = Itcl_LastListElem(&cdPtr->bases); + if (elem) { + Itcl_PushStack((ClientData)cdPtr, &stack); + Itcl_PushStack((ClientData)NULL, &stack); + while (elem) { + Itcl_PushStack(Itcl_GetListValue(elem), &stack); + elem = Itcl_PrevListElem(elem); + } + } + } + } + Itcl_DeleteStack(&stack); + goto inheritError; + } + + /* + * At this point, everything looks good. + * Finish the installation of the base classes. Update + * each base class to recognize the current class as a + * derived class. + */ + elem = Itcl_FirstListElem(&cdefnPtr->bases); + while (elem) { + baseCdefnPtr = (ItclClass*)Itcl_GetListValue(elem); + + Itcl_AppendList(&baseCdefnPtr->derived, (ClientData)cdefnPtr); + Itcl_PreserveData((ClientData)cdefnPtr); + + elem = Itcl_NextListElem(elem); + } + + Tcl_PopCallFrame(interp); + return TCL_OK; + + + /* + * If the "inherit" list cannot be built properly, tear it + * down and return an error. + */ +inheritError: + Tcl_PopCallFrame(interp); + + elem = Itcl_FirstListElem(&cdefnPtr->bases); + while (elem) { + Itcl_ReleaseData( Itcl_GetListValue(elem) ); + elem = Itcl_DeleteListElem(elem); + } + return TCL_ERROR; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassProtectionCmd() + * + * Invoked by Tcl whenever the user issues a protection setting + * command like "public" or "private". Creates commands and + * variables, and assigns a protection level to them. Protection + * levels are defined as follows: + * + * public => accessible from any namespace + * protected => accessible from selected namespaces + * private => accessible only in the namespace where it was defined + * + * Handles the following syntax: + * + * public ? ...? + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassProtectionCmd(clientData, interp, objc, objv) + ClientData clientData; /* protection level (public/protected/private) */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ProtectionCmdInfo *pInfo = (ProtectionCmdInfo*)clientData; + + int result; + int oldLevel; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "command ?arg arg...?"); + return TCL_ERROR; + } + + oldLevel = Itcl_Protection(interp, pInfo->pLevel); + + if (objc == 2) { + /* CYGNUS LOCAL - Fix for Tcl8.1 */ +#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + result = Tcl_EvalObj(interp, objv[1]); +#else + result = Tcl_EvalObj(interp, objv[1], 0); +#endif + /* END CYGNUS LOCAL */ + } else { + result = Itcl_EvalArgs(interp, objc-1, objv+1); + } + + if (result == TCL_BREAK) { + Tcl_SetResult(interp, "invoked \"break\" outside of a loop", + TCL_STATIC); + result = TCL_ERROR; + } + else if (result == TCL_CONTINUE) { + Tcl_SetResult(interp, "invoked \"continue\" outside of a loop", + TCL_STATIC); + result = TCL_ERROR; + } + else if (result != TCL_OK) { + char mesg[256], *token; + token = Tcl_GetStringFromObj(objv[0], (int*)NULL); + sprintf(mesg, "\n (%.100s body line %d)", token, interp->errorLine); + Tcl_AddErrorInfo(interp, mesg); + } + + Itcl_Protection(interp, oldLevel); + return result; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassConstructorCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "constructor" command is invoked to define the constructor + * for an object. Handles the following syntax: + * + * constructor ?? + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassConstructorCmd(clientData, interp, objc, objv) + ClientData clientData; /* info for all known objects */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclObjectInfo *info = (ItclObjectInfo*)clientData; + ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); + + char *name, *arglist, *body; + + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "args ?init? body"); + return TCL_ERROR; + } + + name = Tcl_GetStringFromObj(objv[0], (int*)NULL); + if (Tcl_FindHashEntry(&cdefnPtr->functions, name)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", name, "\" already defined in class \"", + cdefnPtr->fullname, "\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * If there is an object initialization statement, pick this + * out and take the last argument as the constructor body. + */ + arglist = Tcl_GetStringFromObj(objv[1], (int*)NULL); + if (objc == 3) { + body = Tcl_GetStringFromObj(objv[2], (int*)NULL); + } else { + cdefnPtr->initCode = objv[2]; + Tcl_IncrRefCount(cdefnPtr->initCode); + body = Tcl_GetStringFromObj(objv[3], (int*)NULL); + } + + if (Itcl_CreateMethod(interp, cdefnPtr, name, arglist, body) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassDestructorCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "destructor" command is invoked to define the destructor + * for an object. Handles the following syntax: + * + * destructor + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassDestructorCmd(clientData, interp, objc, objv) + ClientData clientData; /* info for all known objects */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclObjectInfo *info = (ItclObjectInfo*)clientData; + ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); + + char *name, *body; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "body"); + return TCL_ERROR; + } + + name = Tcl_GetStringFromObj(objv[0], (int*)NULL); + body = Tcl_GetStringFromObj(objv[1], (int*)NULL); + + if (Tcl_FindHashEntry(&cdefnPtr->functions, name)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", name, "\" already defined in class \"", + cdefnPtr->fullname, "\"", + (char*)NULL); + return TCL_ERROR; + } + + if (Itcl_CreateMethod(interp, cdefnPtr, name, (char*)NULL, body) + != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassMethodCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "method" command is invoked to define an object method. + * Handles the following syntax: + * + * method ?? ?? + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassMethodCmd(clientData, interp, objc, objv) + ClientData clientData; /* info for all known objects */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclObjectInfo *info = (ItclObjectInfo*)clientData; + ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); + + char *name, *arglist, *body; + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?"); + return TCL_ERROR; + } + + name = Tcl_GetStringFromObj(objv[1], (int*)NULL); + + arglist = NULL; + body = NULL; + if (objc >= 3) { + arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL); + } + if (objc >= 4) { + body = Tcl_GetStringFromObj(objv[3], (int*)NULL); + } + + if (Itcl_CreateMethod(interp, cdefnPtr, name, arglist, body) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassProcCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "proc" command is invoked to define a common class proc. + * A "proc" is like a "method", but only has access to "common" + * class variables. Handles the following syntax: + * + * proc ?? ?? + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassProcCmd(clientData, interp, objc, objv) + ClientData clientData; /* info for all known objects */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclObjectInfo *info = (ItclObjectInfo*)clientData; + ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); + char *name, *arglist, *body; + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?"); + return TCL_ERROR; + } + + name = Tcl_GetStringFromObj(objv[1], (int*)NULL); + + arglist = NULL; + body = NULL; + if (objc >= 3) { + arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL); + } + if (objc >= 4) { + body = Tcl_GetStringFromObj(objv[3], (int*)NULL); + } + + if (Itcl_CreateProc(interp, cdefnPtr, name, arglist, body) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassVariableCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "variable" command is invoked to define an instance variable. + * Handles the following syntax: + * + * variable ?? ?? + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassVariableCmd(clientData, interp, objc, objv) + ClientData clientData; /* info for all known objects */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclObjectInfo *info = (ItclObjectInfo*)clientData; + ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); + + int pLevel; + ItclVarDefn *vdefn; + char *name, *init, *config; + + pLevel = Itcl_Protection(interp, 0); + + if (pLevel == ITCL_PUBLIC) { + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?init? ?config?"); + return TCL_ERROR; + } + } + else if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?init?"); + return TCL_ERROR; + } + + /* + * Make sure that the variable name does not contain anything + * goofy like a "::" scope qualifier. + */ + name = Tcl_GetStringFromObj(objv[1], (int*)NULL); + if (strstr(name, "::")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad variable name \"", name, "\"", + (char*)NULL); + return TCL_ERROR; + } + + init = NULL; + config = NULL; + if (objc >= 3) { + init = Tcl_GetStringFromObj(objv[2], (int*)NULL); + } + if (objc >= 4) { + config = Tcl_GetStringFromObj(objv[3], (int*)NULL); + } + + if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, config, + &vdefn) != TCL_OK) { + + return TCL_ERROR; + } + + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ClassCommonCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "common" command is invoked to define a variable that is + * common to all objects in the class. Handles the following syntax: + * + * common ?? + * + * ------------------------------------------------------------------------ + */ +int +Itcl_ClassCommonCmd(clientData, interp, objc, objv) + ClientData clientData; /* info for all known objects */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclObjectInfo *info = (ItclObjectInfo*)clientData; + ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); + + int newEntry; + char *name, *init; + ItclVarDefn *vdefn; + Tcl_HashEntry *entry; + Namespace *nsPtr; + Var *varPtr; + + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "varname ?init?"); + return TCL_ERROR; + } + + /* + * Make sure that the variable name does not contain anything + * goofy like a "::" scope qualifier. + */ + name = Tcl_GetStringFromObj(objv[1], (int*)NULL); + if (strstr(name, "::")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad variable name \"", name, "\"", + (char*)NULL); + return TCL_ERROR; + } + + init = NULL; + if (objc >= 3) { + init = Tcl_GetStringFromObj(objv[2], (int*)NULL); + } + + if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, (char*)NULL, + &vdefn) != TCL_OK) { + + return TCL_ERROR; + } + vdefn->member->flags |= ITCL_COMMON; + + /* + * Create the variable in the namespace associated with the + * class. Do this the hard way, to avoid the variable resolver + * procedures. These procedures won't work until we rebuild + * the virtual tables below. + */ + nsPtr = (Namespace*)cdefnPtr->namesp; + entry = Tcl_CreateHashEntry(&nsPtr->varTable, + vdefn->member->name, &newEntry); + + varPtr = _TclNewVar(); + varPtr->hPtr = entry; + varPtr->nsPtr = nsPtr; + varPtr->flags |= VAR_NAMESPACE_VAR; + varPtr->refCount++; /* one use by namespace */ + varPtr->refCount++; /* another use by class */ + + Tcl_SetHashValue(entry, varPtr); + + /* + * TRICKY NOTE: Make sure to rebuild the virtual tables for this + * class so that this variable is ready to access. The variable + * resolver for the parser namespace needs this info to find the + * variable if the developer tries to set it within the class + * definition. + * + * If an initialization value was specified, then initialize + * the variable now. + */ + Itcl_BuildVirtualTables(cdefnPtr); + + if (init) { + init = Tcl_SetVar(interp, vdefn->member->name, init, + TCL_NAMESPACE_ONLY); + + if (!init) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot initialize common variable \"", + vdefn->member->name, "\"", + (char*)NULL); + return TCL_ERROR; + } + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ParseVarResolver() + * + * Used by the "parser" namespace to resolve variable accesses to + * common variables. The runtime resolver procedure is consulted + * whenever a variable is accessed within the namespace. It can + * deny access to certain variables, or perform special lookups itself. + * + * This procedure allows access only to "common" class variables that + * have been declared within the class or inherited from another class. + * A "set" command can be used to initialized common data members within + * the body of the class definition itself: + * + * itcl::class Foo { + * common colors + * set colors(red) #ff0000 + * set colors(green) #00ff00 + * set colors(blue) #0000ff + * ... + * } + * + * itcl::class Bar { + * inherit Foo + * set colors(gray) #a0a0a0 + * set colors(white) #ffffff + * + * common numbers + * set numbers(0) zero + * set numbers(1) one + * } + * + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_ParseVarResolver(interp, name, contextNs, flags, rPtr) + Tcl_Interp *interp; /* current interpreter */ + char* name; /* name of the variable being accessed */ + Tcl_Namespace *contextNs; /* namespace context */ + int flags; /* TCL_GLOBAL_ONLY => global variable + * TCL_NAMESPACE_ONLY => namespace variable */ + Tcl_Var* rPtr; /* returns: Tcl_Var for desired variable */ +{ + ItclObjectInfo *info = (ItclObjectInfo*)contextNs->clientData; + ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); + + Tcl_HashEntry *entry; + ItclVarLookup *vlookup; + + /* + * See if the requested variable is a recognized "common" member. + * If it is, make sure that access is allowed. + */ + entry = Tcl_FindHashEntry(&cdefnPtr->resolveVars, name); + if (entry) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + + if ((vlookup->vdefn->member->flags & ITCL_COMMON) != 0) { + if (!vlookup->accessible) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't access \"", name, "\": ", + Itcl_ProtectionStr(vlookup->vdefn->member->protection), + " variable", + (char*)NULL); + return TCL_ERROR; + } + *rPtr = vlookup->var.common; + return TCL_OK; + } + } + + /* + * If the variable is not recognized, return TCL_CONTINUE and + * let lookup continue via the normal name resolution rules. + * This is important for variables like "errorInfo" + * that might get set while the parser namespace is active. + */ + return TCL_CONTINUE; +} + +/* + * ------------------------------------------------------------------------ + * ItclFreeParserCommandData() + * + * This callback will free() up memory dynamically allocated + * and passed as the ClientData argument to Tcl_CreateObjCommand. + * This callback is required because one can not simply pass + * a pointer to the free() or ckfree() to Tcl_CreateObjCommand. + * ------------------------------------------------------------------------ + */ +static void +ItclFreeParserCommandData(cdata) + char* cdata; /* client data to be destroyed */ +{ + ckfree(cdata); +}

itcl_parse.c Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: itcl_obsolete.c =================================================================== --- itcl_obsolete.c (nonexistent) +++ itcl_obsolete.c (revision 1765) @@ -0,0 +1,1959 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * Procedures in this file support the old-style syntax for [incr Tcl] + * class definitions: + * + * itcl_class { + * inherit ... + * + * constructor {} { } + * destructor { } + * + * method {} { } + * proc {} { } + * + * public ?? ?? + * protected ?? + * common ?? + * } + * + * This capability will be removed in a future release, after users + * have had a chance to switch over to the new syntax. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * RCS: $Id: itcl_obsolete.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $ + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +/* + * FORWARD DECLARATIONS + */ +static int ItclOldClassCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[])); + +static int ItclOldMethodCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[])); +static int ItclOldPublicCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[])); +static int ItclOldProtectedCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[])); +static int ItclOldCommonCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[])); + +static int ItclOldBiDeleteCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[])); +static int ItclOldBiVirtualCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[])); +static int ItclOldBiPreviousCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[])); + +static int ItclOldBiInfoMethodsCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[])); +static int ItclOldBiInfoProcsCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[])); +static int ItclOldBiInfoPublicsCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[])); +static int ItclOldBiInfoProtectedsCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[])); +static int ItclOldBiInfoCommonsCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[])); + + +/* + * Standard list of built-in methods for old-style objects. + */ +typedef struct BiMethod { + char* name; /* method name */ + char* usage; /* string describing usage */ + char* registration; /* registration name for C proc */ + Tcl_ObjCmdProc *proc; /* implementation C proc */ +} BiMethod; + +static BiMethod BiMethodList[] = { + { "cget", "-option", + "@itcl-oldstyle-cget", Itcl_BiCgetCmd }, + { "configure", "?-option? ?value -option value...?", + "@itcl-oldstyle-configure", Itcl_BiConfigureCmd }, + { "delete", "", + "@itcl-oldstyle-delete", ItclOldBiDeleteCmd }, + { "isa", "className", + "@itcl-oldstyle-isa", Itcl_BiIsaCmd }, +}; +static int BiMethodListLen = sizeof(BiMethodList)/sizeof(BiMethod); + + +/* + * ------------------------------------------------------------------------ + * Itcl_OldInit() + * + * Invoked by Itcl_Init() whenever a new interpeter is created to add + * [incr Tcl] facilities. Adds the commands needed for backward + * compatibility with previous releases of [incr Tcl]. + * ------------------------------------------------------------------------ + */ +int +Itcl_OldInit(interp,info) + Tcl_Interp *interp; /* interpreter to be updated */ + ItclObjectInfo *info; /* info regarding all known objects */ +{ + int i; + Tcl_Namespace *parserNs, *oldBiNs; + + /* + * Declare all of the old-style built-in methods as C procedures. + */ + for (i=0; i < BiMethodListLen; i++) { + if (Itcl_RegisterObjC(interp, + BiMethodList[i].registration+1, BiMethodList[i].proc, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) { + + return TCL_ERROR; + } + } + + /* + * Create the "itcl::old-parser" namespace for backward + * compatibility, to handle the old-style class definitions. + */ + parserNs = Tcl_CreateNamespace(interp, "::itcl::old-parser", + (ClientData)info, Itcl_ReleaseData); + + if (!parserNs) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + " (cannot initialize itcl old-style parser)", + (char*)NULL); + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)info); + + /* + * Add commands for parsing old-style class definitions. + */ + Tcl_CreateObjCommand(interp, "::itcl::old-parser::inherit", + Itcl_ClassInheritCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::old-parser::constructor", + Itcl_ClassConstructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::old-parser::destructor", + Itcl_ClassDestructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::old-parser::method", + ItclOldMethodCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::old-parser::proc", + Itcl_ClassProcCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::old-parser::public", + ItclOldPublicCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::old-parser::protected", + ItclOldProtectedCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::old-parser::common", + ItclOldCommonCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); + + /* + * Set the runtime variable resolver for the parser namespace, + * to control access to "common" data members while parsing + * the class definition. + */ + Tcl_SetNamespaceResolvers(parserNs, (Tcl_ResolveCmdProc*)NULL, + Itcl_ParseVarResolver, (Tcl_ResolveCompiledVarProc*)NULL); + + /* + * Create the "itcl::old-builtin" namespace for backward + * compatibility with the old-style built-in commands. + */ + Tcl_CreateObjCommand(interp, "::itcl::old-builtin::virtual", + ItclOldBiVirtualCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(interp, "::itcl::old-builtin::previous", + ItclOldBiPreviousCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + + if (Itcl_CreateEnsemble(interp, "::itcl::old-builtin::info") != TCL_OK) { + return TCL_ERROR; + } + + if (Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", + "class", "", Itcl_BiInfoClassCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK || + + Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", + "inherit", "", Itcl_BiInfoInheritCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK || + + Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", + "heritage", "", Itcl_BiInfoHeritageCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK || + + Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", + "method", "?methodName? ?-args? ?-body?", + ItclOldBiInfoMethodsCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK || + + Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", + "proc", "?procName? ?-args? ?-body?", + ItclOldBiInfoProcsCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK || + + Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", + "public", "?varName? ?-init? ?-value? ?-config?", + ItclOldBiInfoPublicsCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK || + + Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", + "protected", "?varName? ?-init? ?-value?", + ItclOldBiInfoProtectedsCmd, + (ClientData)NULL,(Tcl_CmdDeleteProc*)NULL) + != TCL_OK || + + Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", + "common", "?varName? ?-init? ?-value?", + ItclOldBiInfoCommonsCmd, + (ClientData)NULL,(Tcl_CmdDeleteProc*)NULL) + != TCL_OK || + + Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", + "args", "procname", Itcl_BiInfoArgsCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK || + + Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", + "body", "procname", Itcl_BiInfoBodyCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK + ) { + return TCL_ERROR; + } + + /* + * Plug in an "@error" handler to handle other options from + * the usual info command. + */ + if (Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", + "@error", (char*)NULL, Itcl_DefaultInfoCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK + ) { + return TCL_ERROR; + } + + oldBiNs = Tcl_FindNamespace(interp, "::itcl::old-builtin", + (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); + + if (!oldBiNs || + Tcl_Export(interp, oldBiNs, "*", /* resetListFirst */ 1) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Install the "itcl_class" and "itcl_info" commands into + * the global scope. This supports the old syntax for + * backward compatibility. + */ + Tcl_CreateObjCommand(interp, "::itcl_class", ItclOldClassCmd, + (ClientData)info, Itcl_ReleaseData); + Itcl_PreserveData((ClientData)info); + + + if (Itcl_CreateEnsemble(interp, "::itcl_info") != TCL_OK) { + return TCL_ERROR; + } + + if (Itcl_AddEnsemblePart(interp, "::itcl_info", + "classes", "?pattern?", + Itcl_FindClassesCmd, (ClientData)info, Itcl_ReleaseData) + != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)info); + + if (Itcl_AddEnsemblePart(interp, "::itcl_info", + "objects", "?-class className? ?-isa className? ?pattern?", + Itcl_FindObjectsCmd, (ClientData)info, Itcl_ReleaseData) + != TCL_OK) { + return TCL_ERROR; + } + Itcl_PreserveData((ClientData)info); + + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_InstallOldBiMethods() + * + * Invoked when a class is first created, just after the class + * definition has been parsed, to add definitions for built-in + * methods to the class. If a method already exists in the class + * with the same name as the built-in, then the built-in is skipped. + * Otherwise, a method definition for the built-in method is added. + * + * Returns TCL_OK if successful, or TCL_ERROR (along with an error + * message in the interpreter) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +int +Itcl_InstallOldBiMethods(interp, cdefn) + Tcl_Interp *interp; /* current interpreter */ + ItclClass *cdefn; /* class definition to be updated */ +{ + int result = TCL_OK; + + int i; + ItclHierIter hier; + ItclClass *cdPtr; + Tcl_HashEntry *entry; + + /* + * Scan through all of the built-in methods and see if + * that method already exists in the class. If not, add + * it in. + * + * TRICKY NOTE: The virtual tables haven't been built yet, + * so look for existing methods the hard way--by scanning + * through all classes. + */ + for (i=0; i < BiMethodListLen; i++) { + Itcl_InitHierIter(&hier, cdefn); + cdPtr = Itcl_AdvanceHierIter(&hier); + + entry = NULL; + while (cdPtr) { + entry = Tcl_FindHashEntry(&cdPtr->functions, BiMethodList[i].name); + if (entry) { + break; + } + cdPtr = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + if (!entry) { + result = Itcl_CreateMethod(interp, cdefn, BiMethodList[i].name, + BiMethodList[i].usage, BiMethodList[i].registration); + + if (result != TCL_OK) { + break; + } + } + } + return result; +} + + +/* + * ------------------------------------------------------------------------ + * ItclOldClassCmd() + * + * Invoked by Tcl whenever the user issues a "itcl_class" command to + * specify a class definition. Handles the following syntax: + * + * itcl_class { + * inherit ... + * + * constructor {} { } + * destructor { } + * + * method {} { } + * proc {} { } + * + * public ?? ?? + * protected ?? + * common ?? + * } + * + * NOTE: This command is will only be provided for a limited time, + * to support backward compatibility with the old-style + * [incr Tcl] syntax. Users should convert their scripts + * to use the newer syntax (Itcl_ClassCmd()) as soon as possible. + * + * ------------------------------------------------------------------------ + */ +static int +ItclOldClassCmd(clientData, interp, objc, objv) + ClientData clientData; /* info for all known objects */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclObjectInfo* info = (ItclObjectInfo*)clientData; + + int result; + char *className; + Tcl_Namespace *parserNs; + ItclClass *cdefnPtr; + Tcl_HashEntry* entry; + ItclMemberFunc *mfunc; + Tcl_CallFrame frame; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name { definition }"); + return TCL_ERROR; + } + className = Tcl_GetStringFromObj(objv[1], (int*)NULL); + + /* + * Find the namespace to use as a parser for the class definition. + * If for some reason it is destroyed, bail out here. + */ + parserNs = Tcl_FindNamespace(interp, "::itcl::old-parser", + (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); + + if (parserNs == NULL) { + char msg[256]; + sprintf(msg, "\n (while parsing class definition for \"%.100s\")", + className); + Tcl_AddErrorInfo(interp, msg); + return TCL_ERROR; + } + + /* + * Try to create the specified class and its namespace. + */ + if (Itcl_CreateClass(interp, className, info, &cdefnPtr) != TCL_OK) { + return TCL_ERROR; + } + cdefnPtr->flags |= ITCL_OLD_STYLE; + + /* + * Import the built-in commands from the itcl::old-builtin + * and itcl::builtin namespaces. Do this before parsing the + * class definition, so methods/procs can override the built-in + * commands. + */ + result = Tcl_Import(interp, cdefnPtr->namesp, "::itcl::builtin::*", + /* allowOverwrite */ 1); + + if (result == TCL_OK) { + result = Tcl_Import(interp, cdefnPtr->namesp, "::itcl::old-builtin::*", + /* allowOverwrite */ 1); + } + + if (result != TCL_OK) { + char msg[256]; + sprintf(msg, "\n (while installing built-in commands for class \"%.100s\")", className); + Tcl_AddErrorInfo(interp, msg); + + Tcl_DeleteNamespace(cdefnPtr->namesp); + return TCL_ERROR; + } + + /* + * Push this class onto the class definition stack so that it + * becomes the current context for all commands in the parser. + * Activate the parser and evaluate the class definition. + */ + Itcl_PushStack((ClientData)cdefnPtr, &info->cdefnStack); + + result = Tcl_PushCallFrame(interp, &frame, parserNs, + /* isProcCallFrame */ 0); + + if (result == TCL_OK) { + /* CYGNUS LOCAL - Fix for Tcl8.1 */ +#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + result = Tcl_EvalObj(interp, objv[2]); +#else + result = Tcl_EvalObj(interp, objv[2], 0); +#endif + /* END CYGNUS LOCAL */ + Tcl_PopCallFrame(interp); + } + Itcl_PopStack(&info->cdefnStack); + + if (result != TCL_OK) { + char msg[256]; + sprintf(msg, "\n (class \"%.200s\" body line %d)", + className, interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + + Tcl_DeleteNamespace(cdefnPtr->namesp); + return TCL_ERROR; + } + + /* + * At this point, parsing of the class definition has succeeded. + * Add built-in methods such as "configure" and "cget"--as long + * as they don't conflict with those defined in the class. + */ + if (Itcl_InstallOldBiMethods(interp, cdefnPtr) != TCL_OK) { + Tcl_DeleteNamespace(cdefnPtr->namesp); + return TCL_ERROR; + } + + /* + * See if this class has a "constructor", and if it does, mark + * it as "old-style". This will allow the "config" argument + * to work. + */ + entry = Tcl_FindHashEntry(&cdefnPtr->functions, "constructor"); + if (entry) { + mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); + mfunc->member->flags |= ITCL_OLD_STYLE; + } + + /* + * Build the virtual tables for this class. + */ + Itcl_BuildVirtualTables(cdefnPtr); + + Tcl_ResetResult(interp); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * ItclOldMethodCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "method" command is invoked to define an object method. + * Handles the following syntax: + * + * method {} {} + * + * ------------------------------------------------------------------------ + */ +static int +ItclOldMethodCmd(clientData, interp, objc, objv) + ClientData clientData; /* info for all known objects */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclObjectInfo *info = (ItclObjectInfo*)clientData; + ItclClass *cdefn = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); + + char *name, *arglist, *body; + Tcl_HashEntry *entry; + ItclMemberFunc *mfunc; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name args body"); + return TCL_ERROR; + } + + name = Tcl_GetStringFromObj(objv[1], (int*)NULL); + if (Tcl_FindHashEntry(&cdefn->functions, name)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", name, "\" already defined in class \"", cdefn->name, "\"", + (char*)NULL); + return TCL_ERROR; + } + + arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL); + body = Tcl_GetStringFromObj(objv[3], (int*)NULL); + + if (Itcl_CreateMethod(interp, cdefn, name, arglist, body) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Find the method that was just created and mark it as an + * "old-style" method, so that the magic "config" argument + * will be allowed to work. This is done for backward- + * compatibility with earlier releases. In the latest version, + * use of the "config" argument is discouraged. + */ + entry = Tcl_FindHashEntry(&cdefn->functions, name); + if (entry) { + mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); + mfunc->member->flags |= ITCL_OLD_STYLE; + } + + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * ItclOldPublicCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "public" command is invoked to define a public variable. + * Handles the following syntax: + * + * public ?? ?? + * + * ------------------------------------------------------------------------ + */ +static int +ItclOldPublicCmd(clientData, interp, objc, objv) + ClientData clientData; /* info for all known objects */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclObjectInfo *info = (ItclObjectInfo*)clientData; + ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); + + char *name, *init, *config; + ItclVarDefn *vdefn; + + if ((objc < 2) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 1, objv, "varname ?init? ?config?"); + return TCL_ERROR; + } + + /* + * Make sure that the variable name does not contain anything + * goofy like a "::" scope qualifier. + */ + name = Tcl_GetStringFromObj(objv[1], (int*)NULL); + if (strstr(name, "::")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad variable name \"", name, "\"", + (char*)NULL); + return TCL_ERROR; + } + + init = NULL; + config = NULL; + if (objc >= 3) { + init = Tcl_GetStringFromObj(objv[2], (int*)NULL); + } + if (objc >= 4) { + config = Tcl_GetStringFromObj(objv[3], (int*)NULL); + } + + if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, config, + &vdefn) != TCL_OK) { + + return TCL_ERROR; + } + + vdefn->member->protection = ITCL_PUBLIC; + + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclOldProtectedCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "protected" command is invoked to define a protected variable. + * Handles the following syntax: + * + * protected ?? + * + * ------------------------------------------------------------------------ + */ +static int +ItclOldProtectedCmd(clientData, interp, objc, objv) + ClientData clientData; /* info for all known objects */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclObjectInfo *info = (ItclObjectInfo*)clientData; + ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); + + char *name, *init; + ItclVarDefn *vdefn; + + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "varname ?init?"); + return TCL_ERROR; + } + + /* + * Make sure that the variable name does not contain anything + * goofy like a "::" scope qualifier. + */ + name = Tcl_GetStringFromObj(objv[1], (int*)NULL); + if (strstr(name, "::")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad variable name \"", name, "\"", + (char*)NULL); + return TCL_ERROR; + } + + if (objc == 3) { + init = Tcl_GetStringFromObj(objv[2], (int*)NULL); + } else { + init = NULL; + } + + if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, (char*)NULL, + &vdefn) != TCL_OK) { + + return TCL_ERROR; + } + + vdefn->member->protection = ITCL_PROTECTED; + + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclOldCommonCmd() + * + * Invoked by Tcl during the parsing of a class definition whenever + * the "common" command is invoked to define a variable that is + * common to all objects in the class. Handles the following syntax: + * + * common ?? + * + * ------------------------------------------------------------------------ + */ +static int +ItclOldCommonCmd(clientData, interp, objc, objv) + ClientData clientData; /* info for all known objects */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclObjectInfo *info = (ItclObjectInfo*)clientData; + ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); + + int newEntry; + char *name, *init; + ItclVarDefn *vdefn; + Tcl_HashEntry *entry; + Namespace *nsPtr; + Var *varPtr; + + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "varname ?init?"); + return TCL_ERROR; + } + + /* + * Make sure that the variable name does not contain anything + * goofy like a "::" scope qualifier. + */ + name = Tcl_GetStringFromObj(objv[1], (int*)NULL); + if (strstr(name, "::")) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad variable name \"", name, "\"", + (char*)NULL); + return TCL_ERROR; + } + + if (objc == 3) { + init = Tcl_GetStringFromObj(objv[2], (int*)NULL); + } else { + init = NULL; + } + + if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, (char*)NULL, + &vdefn) != TCL_OK) { + + return TCL_ERROR; + } + + vdefn->member->protection = ITCL_PROTECTED; + vdefn->member->flags |= ITCL_COMMON; + + /* + * Create the variable in the namespace associated with the + * class. Do this the hard way, to avoid the variable resolver + * procedures. These procedures won't work until we rebuild + * the virtual tables below. + */ + nsPtr = (Namespace*)cdefnPtr->namesp; + entry = Tcl_CreateHashEntry(&nsPtr->varTable, + vdefn->member->name, &newEntry); + + varPtr = _TclNewVar(); + varPtr->hPtr = entry; + varPtr->nsPtr = nsPtr; + varPtr->refCount++; /* protect from being deleted */ + + Tcl_SetHashValue(entry, varPtr); + + /* + * TRICKY NOTE: Make sure to rebuild the virtual tables for this + * class so that this variable is ready to access. The variable + * resolver for the parser namespace needs this info to find the + * variable if the developer tries to set it within the class + * definition. + * + * If an initialization value was specified, then initialize + * the variable now. + */ + Itcl_BuildVirtualTables(cdefnPtr); + + if (init) { + init = Tcl_SetVar(interp, vdefn->member->name, init, + TCL_NAMESPACE_ONLY); + + if (!init) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot initialize common variable \"", + vdefn->member->name, "\"", + (char*)NULL); + return TCL_ERROR; + } + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * ItclOldDeleteCmd() + * + * Invokes the destructors, and deletes the object that invoked this + * operation. If an error is encountered during destruction, the + * delete operation is aborted. Handles the following syntax: + * + * delete + * + * When an object is successfully deleted, it is removed from the + * list of known objects, and its access command is deleted. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +ItclOldBiDeleteCmd(dummy, interp, objc, objv) + ClientData dummy; /* not used */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclClass *contextClass; + ItclObject *contextObj; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + + /* + * If there is an object context, then destruct the object + * and delete it. + */ + if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) { + return TCL_ERROR; + } + + if (!contextObj) { + Tcl_SetResult(interp, "improper usage: should be \"object delete\"", + TCL_STATIC); + return TCL_ERROR; + } + + if (Itcl_DeleteObject(interp, contextObj) != TCL_OK) { + return TCL_ERROR; + } + + Tcl_ResetResult(interp); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * ItclOldVirtualCmd() + * + * Executes the remainder of its command line arguments in the + * most-specific class scope for the current object. If there is + * no object context, this fails. + * + * NOTE: All methods are now implicitly virtual, and there are + * much better ways to manipulate scope. This command is only + * provided for backward-compatibility, and should be avoided. + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +ItclOldBiVirtualCmd(dummy, interp, objc, objv) + ClientData dummy; /* not used */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + int result; + ItclClass *contextClass; + ItclObject *contextObj; + ItclContext context; + + if (objc == 1) { + Tcl_WrongNumArgs(interp, 1, objv, "command ?args...?"); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\n This command will be removed soon.", + "\n Commands are now virtual by default.", + (char*)NULL); + return TCL_ERROR; + } + + /* + * If there is no object context, then return an error. + */ + if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) { + return TCL_ERROR; + } + if (!contextObj) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot use \"virtual\" without an object context\n", + " This command will be removed soon.\n", + " Commands are now virtual by default.", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Install the most-specific namespace for this object, with + * the object context as clientData. Invoke the rest of the + * args as a command in that namespace. + */ + if (Itcl_PushContext(interp, (ItclMember*)NULL, contextObj->classDefn, + contextObj, &context) != TCL_OK) { + + return TCL_ERROR; + } + + result = Itcl_EvalArgs(interp, objc-1, objv+1); + Itcl_PopContext(interp, &context); + + return result; +} + + +/* + * ------------------------------------------------------------------------ + * ItclOldPreviousCmd() + * + * Executes the remainder of its command line arguments in the + * previous class scope (i.e., the next scope up in the heritage + * list). + * + * NOTE: There are much better ways to manipulate scope. This + * command is only provided for backward-compatibility, and should + * be avoided. + * + * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +ItclOldBiPreviousCmd(dummy, interp, objc, objv) + ClientData dummy; /* not used */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + int result; + char *name; + ItclClass *contextClass, *base; + ItclObject *contextObj; + ItclMember *member; + ItclMemberFunc *mfunc; + Itcl_ListElem *elem; + Tcl_HashEntry *entry; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "command ?args...?"); + return TCL_ERROR; + } + + /* + * If the current context is not a class namespace, + * return an error. + */ + if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Get the heritage information for this class and move one + * level up in the hierarchy. If there is no base class, + * return an error. + */ + elem = Itcl_FirstListElem(&contextClass->bases); + if (!elem) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "no previous class in inheritance hierarchy for \"", + contextClass->name, "\"", + (char*)NULL); + return TCL_ERROR; + } + base = (ItclClass*)Itcl_GetListValue(elem); + + /* + * Look in the command resolution table for the base class + * to find the desired method. + */ + name = Tcl_GetStringFromObj(objv[1], (int*)NULL); + entry = Tcl_FindHashEntry(&base->resolveCmds, name); + if (!entry) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", base->name, "::", name, "\"", + (char*)NULL); + return TCL_ERROR; + } + + mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); + member = mfunc->member; + + /* + * Make sure that this method is accessible. + */ + if (mfunc->member->protection != ITCL_PUBLIC) { + Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp, + member->classDefn->info); + + if (!Itcl_CanAccessFunc(mfunc, contextNs)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't access \"", member->fullname, "\": ", + Itcl_ProtectionStr(member->protection), " function", + (char*)NULL); + return TCL_ERROR; + } + } + + /* + * Invoke the desired method by calling Itcl_EvalMemberCode. + * directly. This bypasses the virtual behavior built into + * the usual Itcl_ExecMethod handler. + */ + result = Itcl_EvalMemberCode(interp, mfunc, member, contextObj, + objc-1, objv+1); + + result = Itcl_ReportFuncErrors(interp, mfunc, contextObj, result); + + return result; +} + + +/* + * ------------------------------------------------------------------------ + * ItclOldBiInfoMethodsCmd() + * + * Returns information regarding methods for an object. This command + * can be invoked with or without an object context: + * + * info... <= returns info for most-specific class + * info... <= returns info for active namespace + * + * Handles the following syntax: + * + * info method ?methodName? ?-args? ?-body? + * + * If the ?methodName? is not specified, then a list of all known + * methods is returned. Otherwise, the information (args/body) for + * a specific method is returned. Returns a status TCL_OK/TCL_ERROR + * to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +ItclOldBiInfoMethodsCmd(dummy, interp, objc, objv) + ClientData dummy; /* not used */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + char *methodName = NULL; + int methodArgs = 0; + int methodBody = 0; + + char *token; + ItclClass *contextClass, *cdefn; + ItclObject *contextObj; + ItclHierIter hier; + Tcl_HashSearch place; + Tcl_HashEntry *entry; + ItclMemberFunc *mfunc; + ItclMemberCode *mcode; + Tcl_Obj *objPtr, *listPtr; + + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) { + return TCL_ERROR; + } + + /* + * If there is an object context, then use the most-specific + * class for the object. Otherwise, use the current class + * namespace. + */ + if (contextObj) { + contextClass = contextObj->classDefn; + } + + /* + * Process args: ?methodName? ?-args? ?-body? + */ + objv++; /* skip over command name */ + objc--; + + if (objc > 0) { + methodName = Tcl_GetStringFromObj(*objv, (int*)NULL); + objc--; objv++; + } + for ( ; objc > 0; objc--, objv++) { + token = Tcl_GetStringFromObj(*objv, (int*)NULL); + if (strcmp(token, "-args") == 0) + methodArgs = ~0; + else if (strcmp(token, "-body") == 0) + methodBody = ~0; + else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option \"", token, "\": should be -args or -body", + (char*)NULL); + return TCL_ERROR; + } + } + + /* + * Return info for a specific method. + */ + if (methodName) { + entry = Tcl_FindHashEntry(&contextClass->resolveCmds, methodName); + if (entry) { + int i, valc = 0; + Tcl_Obj *valv[5]; + + mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); + if ((mfunc->member->flags & ITCL_COMMON) != 0) { + return TCL_OK; + } + + /* + * If the implementation has not yet been defined, + * autoload it now. + */ + if (Itcl_GetMemberCode(interp, mfunc->member) != TCL_OK) { + return TCL_ERROR; + } + mcode = mfunc->member->code; + + if (!methodArgs && !methodBody) { + objPtr = Tcl_NewStringObj(mfunc->member->classDefn->name, -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, mfunc->member->name, -1); + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + methodArgs = methodBody = ~0; + } + if (methodArgs) { + if (mcode->arglist) { + objPtr = Itcl_ArgList(mcode->argcount, mcode->arglist); + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + } + else { + objPtr = Tcl_NewStringObj("", -1); + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + } + } + if (methodBody) { + objPtr = mcode->procPtr->bodyPtr; + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + } + + /* + * If the result list has a single element, then + * return it using Tcl_SetResult() so that it will + * look like a string and not a list with one element. + */ + if (valc == 1) { + objPtr = valv[0]; + } else { + objPtr = Tcl_NewListObj(valc, valv); + } + Tcl_SetObjResult(interp, objPtr); + + for (i=0; i < valc; i++) { + Tcl_DecrRefCount(valv[i]); + } + } + } + + /* + * Return the list of available methods. + */ + else { + listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL); + + Itcl_InitHierIter(&hier, contextClass); + while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) { + entry = Tcl_FirstHashEntry(&cdefn->functions, &place); + while (entry) { + mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); + + if ((mfunc->member->flags & ITCL_COMMON) == 0) { + objPtr = Tcl_NewStringObj(mfunc->member->classDefn->name, -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, mfunc->member->name, -1); + + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + objPtr); + } + entry = Tcl_NextHashEntry(&place); + } + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, listPtr); + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * ItclOldBiInfoProcsCmd() + * + * Returns information regarding procs for a class. This command + * can be invoked with or without an object context: + * + * info... <= returns info for most-specific class + * info... <= returns info for active namespace + * + * Handles the following syntax: + * + * info proc ?procName? ?-args? ?-body? + * + * If the ?procName? is not specified, then a list of all known + * procs is returned. Otherwise, the information (args/body) for + * a specific proc is returned. Returns a status TCL_OK/TCL_ERROR + * to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +ItclOldBiInfoProcsCmd(dummy, interp, objc, objv) + ClientData dummy; /* not used */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + char *procName = NULL; + int procArgs = 0; + int procBody = 0; + + char *token; + ItclClass *contextClass, *cdefn; + ItclObject *contextObj; + ItclHierIter hier; + Tcl_HashSearch place; + Tcl_HashEntry *entry; + ItclMemberFunc *mfunc; + ItclMemberCode *mcode; + Tcl_Obj *objPtr, *listPtr; + + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) { + return TCL_ERROR; + } + + /* + * If there is an object context, then use the most-specific + * class for the object. Otherwise, use the current class + * namespace. + */ + if (contextObj) { + contextClass = contextObj->classDefn; + } + + /* + * Process args: ?procName? ?-args? ?-body? + */ + objv++; /* skip over command name */ + objc--; + + if (objc > 0) { + procName = Tcl_GetStringFromObj(*objv, (int*)NULL); + objc--; objv++; + } + for ( ; objc > 0; objc--, objv++) { + token = Tcl_GetStringFromObj(*objv, (int*)NULL); + if (strcmp(token, "-args") == 0) + procArgs = ~0; + else if (strcmp(token, "-body") == 0) + procBody = ~0; + else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option \"", token, "\": should be -args or -body", + (char*)NULL); + return TCL_ERROR; + } + } + + /* + * Return info for a specific proc. + */ + if (procName) { + entry = Tcl_FindHashEntry(&contextClass->resolveCmds, procName); + if (entry) { + int i, valc = 0; + Tcl_Obj *valv[5]; + + mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); + if ((mfunc->member->flags & ITCL_COMMON) == 0) { + return TCL_OK; + } + + /* + * If the implementation has not yet been defined, + * autoload it now. + */ + if (Itcl_GetMemberCode(interp, mfunc->member) != TCL_OK) { + return TCL_ERROR; + } + mcode = mfunc->member->code; + + if (!procArgs && !procBody) { + objPtr = Tcl_NewStringObj(mfunc->member->fullname, -1); + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + procArgs = procBody = ~0; + } + if (procArgs) { + if (mcode->arglist) { + objPtr = Itcl_ArgList(mcode->argcount, mcode->arglist); + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + } + else { + objPtr = Tcl_NewStringObj("", -1); + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + } + } + if (procBody) { + objPtr = mcode->procPtr->bodyPtr; + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + } + + /* + * If the result list has a single element, then + * return it using Tcl_SetResult() so that it will + * look like a string and not a list with one element. + */ + if (valc == 1) { + objPtr = valv[0]; + } else { + objPtr = Tcl_NewListObj(valc, valv); + } + Tcl_SetObjResult(interp, objPtr); + + for (i=0; i < valc; i++) { + Tcl_DecrRefCount(valv[i]); + } + } + } + + /* + * Return the list of available procs. + */ + else { + listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL); + + Itcl_InitHierIter(&hier, contextClass); + while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) { + entry = Tcl_FirstHashEntry(&cdefn->functions, &place); + while (entry) { + mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); + + if ((mfunc->member->flags & ITCL_COMMON) != 0) { + objPtr = Tcl_NewStringObj(mfunc->member->classDefn->name, -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, mfunc->member->name, -1); + + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + objPtr); + } + entry = Tcl_NextHashEntry(&place); + } + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, listPtr); + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * ItclOldBiInfoPublicsCmd() + * + * Sets the interpreter result to contain information for public + * variables in the class. Handles the following syntax: + * + * info public ?varName? ?-init? ?-value? ?-config? + * + * If the ?varName? is not specified, then a list of all known public + * variables is returned. Otherwise, the information (init/value/config) + * for a specific variable is returned. Returns a status + * TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +ItclOldBiInfoPublicsCmd(dummy, interp, objc, objv) + ClientData dummy; /* not used */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + char *varName = NULL; + int varInit = 0; + int varCheck = 0; + int varValue = 0; + + char *token, *val; + ItclClass *contextClass; + ItclObject *contextObj; + + ItclClass *cdPtr; + ItclVarLookup *vlookup; + ItclVarDefn *vdefn; + ItclMember *member; + ItclHierIter hier; + Tcl_HashEntry *entry; + Tcl_HashSearch place; + Tcl_Obj *objPtr, *listPtr; + + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Process args: ?varName? ?-init? ?-value? ?-config? + */ + objv++; /* skip over command name */ + objc--; + + if (objc > 0) { + varName = Tcl_GetStringFromObj(*objv, (int*)NULL); + objc--; objv++; + } + for ( ; objc > 0; objc--, objv++) { + token = Tcl_GetStringFromObj(*objv, (int*)NULL); + if (strcmp(token, "-init") == 0) + varInit = ~0; + else if (strcmp(token, "-value") == 0) + varValue = ~0; + else if (strcmp(token, "-config") == 0) + varCheck = ~0; + else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option \"", token, + "\": should be -init, -value or -config", + (char*)NULL); + return TCL_ERROR; + } + } + + /* + * Return info for a specific variable. + */ + if (varName) { + vlookup = NULL; + entry = Tcl_FindHashEntry(&contextClass->resolveVars, varName); + if (entry) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + if (vlookup->vdefn->member->protection != ITCL_PUBLIC) { + vlookup = NULL; + } + } + + if (vlookup) { + int i, valc = 0; + Tcl_Obj *valv[5]; + + member = vlookup->vdefn->member; + + if (!varInit && !varCheck && !varValue) { + objPtr = Tcl_NewStringObj(member->classDefn->name, -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, member->name, -1); + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + varInit = varCheck = varValue = ~0; + } + if (varInit) { + val = (vlookup->vdefn->init) ? vlookup->vdefn->init : ""; + objPtr = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + } + if (varValue) { + val = Itcl_GetInstanceVar(interp, member->fullname, + contextObj, contextObj->classDefn); + + if (!val) { + val = ""; + } + objPtr = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + } + + if (varCheck) { + if (member->code && member->code->procPtr->bodyPtr) { + objPtr = member->code->procPtr->bodyPtr; + } else { + objPtr = Tcl_NewStringObj("", -1); + } + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + } + + /* + * If the result list has a single element, then + * return it using Tcl_SetResult() so that it will + * look like a string and not a list with one element. + */ + if (valc == 1) { + objPtr = valv[0]; + } else { + objPtr = Tcl_NewListObj(valc, valv); + } + Tcl_SetObjResult(interp, objPtr); + + for (i=0; i < valc; i++) { + Tcl_DecrRefCount(valv[i]); + } + } + } + + /* + * Return the list of public variables. + */ + else { + listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL); + + Itcl_InitHierIter(&hier, contextClass); + cdPtr = Itcl_AdvanceHierIter(&hier); + while (cdPtr != NULL) { + entry = Tcl_FirstHashEntry(&cdPtr->variables, &place); + while (entry) { + vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry); + member = vdefn->member; + + if ((member->flags & ITCL_COMMON) == 0 && + member->protection == ITCL_PUBLIC) { + + objPtr = Tcl_NewStringObj(member->classDefn->name, -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, member->name, -1); + + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + objPtr); + } + entry = Tcl_NextHashEntry(&place); + } + cdPtr = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, listPtr); + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclOldBiInfoProtectedsCmd() + * + * Sets the interpreter result to contain information for protected + * variables in the class. Handles the following syntax: + * + * info protected ?varName? ?-init? ?-value? + * + * If the ?varName? is not specified, then a list of all known public + * variables is returned. Otherwise, the information (init/value) + * for a specific variable is returned. Returns a status + * TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +ItclOldBiInfoProtectedsCmd(dummy, interp, objc, objv) + ClientData dummy; /* not used */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + char *varName = NULL; + int varInit = 0; + int varValue = 0; + + char *token, *val; + ItclClass *contextClass; + ItclObject *contextObj; + + ItclClass *cdPtr; + ItclVarLookup *vlookup; + ItclVarDefn *vdefn; + ItclMember *member; + ItclHierIter hier; + Tcl_HashEntry *entry; + Tcl_HashSearch place; + Tcl_Obj *objPtr, *listPtr; + + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Process args: ?varName? ?-init? ?-value? + */ + objv++; /* skip over command name */ + objc--; + + if (objc > 0) { + varName = Tcl_GetStringFromObj(*objv, (int*)NULL); + objc--; objv++; + } + for ( ; objc > 0; objc--, objv++) { + token = Tcl_GetStringFromObj(*objv, (int*)NULL); + if (strcmp(token, "-init") == 0) + varInit = ~0; + else if (strcmp(token, "-value") == 0) + varValue = ~0; + else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option \"", token, "\": should be -init or -value", + (char*)NULL); + return TCL_ERROR; + } + } + + /* + * Return info for a specific variable. + */ + if (varName) { + vlookup = NULL; + entry = Tcl_FindHashEntry(&contextClass->resolveVars, varName); + if (entry) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + if (vlookup->vdefn->member->protection != ITCL_PROTECTED) { + vlookup = NULL; + } + } + + if (vlookup) { + int i, valc = 0; + Tcl_Obj *valv[5]; + + member = vlookup->vdefn->member; + + if (!varInit && !varValue) { + objPtr = Tcl_NewStringObj(member->classDefn->name, -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, member->name, -1); + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + varInit = varValue = ~0; + } + + /* + * If this is the built-in "this" variable, then + * report the object name as its initialization string. + */ + if (varInit) { + if ((member->flags & ITCL_THIS_VAR) != 0) { + if (contextObj && contextObj->accessCmd) { + objPtr = Tcl_NewStringObj("", -1); + Tcl_IncrRefCount(objPtr); + Tcl_GetCommandFullName(contextObj->classDefn->interp, + contextObj->accessCmd, objPtr); + valv[valc++] = objPtr; + } + else { + objPtr = Tcl_NewStringObj("", -1); + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + } + } + else { + val = (vlookup->vdefn->init) ? vlookup->vdefn->init : ""; + objPtr = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + } + } + + if (varValue) { + val = Itcl_GetInstanceVar(interp, member->fullname, + contextObj, contextObj->classDefn); + + if (!val) { + val = ""; + } + objPtr = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + } + + /* + * If the result list has a single element, then + * return it using Tcl_SetResult() so that it will + * look like a string and not a list with one element. + */ + if (valc == 1) { + objPtr = valv[0]; + } else { + objPtr = Tcl_NewListObj(valc, valv); + } + Tcl_SetObjResult(interp, objPtr); + + for (i=0; i < valc; i++) { + Tcl_DecrRefCount(valv[i]); + } + } + } + + /* + * Return the list of public variables. + */ + else { + listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL); + + Itcl_InitHierIter(&hier, contextClass); + cdPtr = Itcl_AdvanceHierIter(&hier); + while (cdPtr != NULL) { + entry = Tcl_FirstHashEntry(&cdPtr->variables, &place); + while (entry) { + vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry); + member = vdefn->member; + + if ((member->flags & ITCL_COMMON) == 0 && + member->protection == ITCL_PROTECTED) { + + objPtr = Tcl_NewStringObj(member->classDefn->name, -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, member->name, -1); + + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + objPtr); + } + entry = Tcl_NextHashEntry(&place); + } + cdPtr = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, listPtr); + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * ItclOldBiInfoCommonsCmd() + * + * Sets the interpreter result to contain information for common + * variables in the class. Handles the following syntax: + * + * info common ?varName? ?-init? ?-value? + * + * If the ?varName? is not specified, then a list of all known common + * variables is returned. Otherwise, the information (init/value) + * for a specific variable is returned. Returns a status + * TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +static int +ItclOldBiInfoCommonsCmd(dummy, interp, objc, objv) + ClientData dummy; /* not used */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + char *varName = NULL; + int varInit = 0; + int varValue = 0; + + char *token, *val; + ItclClass *contextClass; + ItclObject *contextObj; + + ItclClass *cdPtr; + ItclVarDefn *vdefn; + ItclVarLookup *vlookup; + ItclMember *member; + ItclHierIter hier; + Tcl_HashEntry *entry; + Tcl_HashSearch place; + Tcl_Obj *objPtr, *listPtr; + + /* + * If this command is not invoked within a class namespace, + * signal an error. + */ + if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Process args: ?varName? ?-init? ?-value? + */ + objv++; /* skip over command name */ + objc--; + + if (objc > 0) { + varName = Tcl_GetStringFromObj(*objv, (int*)NULL); + objc--; objv++; + } + for ( ; objc > 0; objc--, objv++) { + token = Tcl_GetStringFromObj(*objv, (int*)NULL); + if (strcmp(token, "-init") == 0) + varInit = ~0; + else if (strcmp(token, "-value") == 0) + varValue = ~0; + else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad option \"", token, "\": should be -init or -value", + (char*)NULL); + return TCL_ERROR; + } + } + + /* + * Return info for a specific variable. + */ + if (varName) { + vlookup = NULL; + entry = Tcl_FindHashEntry(&contextClass->resolveVars, varName); + if (entry) { + vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); + if (vlookup->vdefn->member->protection != ITCL_PROTECTED) { + vlookup = NULL; + } + } + + if (vlookup) { + int i, valc = 0; + Tcl_Obj *valv[5]; + + member = vlookup->vdefn->member; + + if (!varInit && !varValue) { + objPtr = Tcl_NewStringObj(member->classDefn->name, -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, member->name, -1); + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + varInit = varValue = ~0; + } + if (varInit) { + val = (vlookup->vdefn->init) ? vlookup->vdefn->init : ""; + objPtr = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + } + + if (varValue) { + val = Itcl_GetCommonVar(interp, member->fullname, + contextObj->classDefn); + + if (!val) { + val = ""; + } + objPtr = Tcl_NewStringObj(val, -1); + Tcl_IncrRefCount(objPtr); + valv[valc++] = objPtr; + } + + /* + * If the result list has a single element, then + * return it using Tcl_SetResult() so that it will + * look like a string and not a list with one element. + */ + if (valc == 1) { + objPtr = valv[0]; + } else { + objPtr = Tcl_NewListObj(valc, valv); + } + Tcl_SetObjResult(interp, objPtr); + + for (i=0; i < valc; i++) { + Tcl_DecrRefCount(valv[i]); + } + } + } + + /* + * Return the list of public variables. + */ + else { + listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL); + + Itcl_InitHierIter(&hier, contextClass); + cdPtr = Itcl_AdvanceHierIter(&hier); + while (cdPtr != NULL) { + entry = Tcl_FirstHashEntry(&cdPtr->variables, &place); + while (entry) { + vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry); + member = vdefn->member; + + if ((member->flags & ITCL_COMMON) && + member->protection == ITCL_PROTECTED) { + + objPtr = Tcl_NewStringObj(member->classDefn->name, -1); + Tcl_AppendToObj(objPtr, "::", -1); + Tcl_AppendToObj(objPtr, member->name, -1); + + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + objPtr); + } + entry = Tcl_NextHashEntry(&place); + } + cdPtr = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + Tcl_SetObjResult(interp, listPtr); + } + return TCL_OK; +}

itcl_obsolete.c Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: itcl_util.c =================================================================== --- itcl_util.c (nonexistent) +++ itcl_util.c (revision 1765) @@ -0,0 +1,1383 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * This segment provides common utility functions used throughout + * the other [incr Tcl] source files. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * RCS: $Id: itcl_util.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $ + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" +#include "tclCompile.h" + +/* + * POOL OF LIST ELEMENTS FOR LINKED LIST + */ +static Itcl_ListElem *listPool = NULL; +static int listPoolLen = 0; + +#define ITCL_VALID_LIST 0x01face10 /* magic bit pattern for validation */ +#define ITCL_LIST_POOL_SIZE 200 /* max number of elements in listPool */ + + +/* + * These records are used to keep track of reference-counted data + * for Itcl_PreserveData and Itcl_ReleaseData. + */ +typedef struct ItclPreservedData { + ClientData data; /* reference to data */ + int usage; /* number of active uses */ + Tcl_FreeProc *fproc; /* procedure used to free data */ +} ItclPreservedData; + +static Tcl_HashTable *ItclPreservedList = NULL; + + +/* + * This structure is used to take a snapshot of the interpreter + * state in Itcl_SaveInterpState. You can snapshot the state, + * execute a command, and then back up to the result or the + * error that was previously in progress. + */ +typedef struct InterpState { + int validate; /* validation stamp */ + int status; /* return code status */ + Tcl_Obj *objResult; /* result object */ + char *errorInfo; /* contents of errorInfo variable */ + char *errorCode; /* contents of errorCode variable */ +} InterpState; + +#define TCL_STATE_VALID 0x01233210 /* magic bit pattern for validation */ + + + +/* + * ------------------------------------------------------------------------ + * Itcl_Assert() + * + * Called whenever an assert() test fails. Prints a diagnostic + * message and abruptly exits. + * ------------------------------------------------------------------------ + */ +#ifndef NDEBUG + +void +Itcl_Assert(testExpr, fileName, lineNumber) + char *testExpr; /* string representing test expression */ + char *fileName; /* file name containing this call */ + int lineNumber; /* line number containing this call */ +{ + fprintf(stderr, "Assertion failed: \"%s\" (line %d of %s)", + testExpr, lineNumber, fileName); + abort(); +} + +#endif + + +/* + * ------------------------------------------------------------------------ + * Itcl_InitStack() + * + * Initializes a stack structure, allocating a certain amount of memory + * for the stack and setting the stack length to zero. + * ------------------------------------------------------------------------ + */ +void +Itcl_InitStack(stack) + Itcl_Stack *stack; /* stack to be initialized */ +{ + stack->values = stack->space; + stack->max = sizeof(stack->space)/sizeof(ClientData); + stack->len = 0; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteStack() + * + * Destroys a stack structure, freeing any memory that may have been + * allocated to represent it. + * ------------------------------------------------------------------------ + */ +void +Itcl_DeleteStack(stack) + Itcl_Stack *stack; /* stack to be deleted */ +{ + /* + * If memory was explicitly allocated (instead of using the + * built-in buffer) then free it. + */ + if (stack->values != stack->space) { + ckfree((char*)stack->values); + } + stack->values = NULL; + stack->len = stack->max = 0; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_PushStack() + * + * Pushes a piece of client data onto the top of the given stack. + * If the stack is not large enough, it is automatically resized. + * ------------------------------------------------------------------------ + */ +void +Itcl_PushStack(cdata,stack) + ClientData cdata; /* data to be pushed onto stack */ + Itcl_Stack *stack; /* stack */ +{ + ClientData *newStack; + + if (stack->len+1 >= stack->max) { + stack->max = 2*stack->max; + newStack = (ClientData*) + ckalloc((unsigned)(stack->max*sizeof(ClientData))); + + if (stack->values) { + memcpy((char*)newStack, (char*)stack->values, + (size_t)(stack->len*sizeof(ClientData))); + + if (stack->values != stack->space) + ckfree((char*)stack->values); + } + stack->values = newStack; + } + stack->values[stack->len++] = cdata; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_PopStack() + * + * Pops a bit of client data from the top of the given stack. + * ------------------------------------------------------------------------ + */ +ClientData +Itcl_PopStack(stack) + Itcl_Stack *stack; /* stack to be manipulated */ +{ + if (stack->values && (stack->len > 0)) { + stack->len--; + return stack->values[stack->len]; + } + return (ClientData)NULL; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_PeekStack() + * + * Gets the current value from the top of the given stack. + * ------------------------------------------------------------------------ + */ +ClientData +Itcl_PeekStack(stack) + Itcl_Stack *stack; /* stack to be examined */ +{ + if (stack->values && (stack->len > 0)) { + return stack->values[stack->len-1]; + } + return (ClientData)NULL; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_GetStackValue() + * + * Gets a value at some index within the stack. Index "0" is the + * first value pushed onto the stack. + * ------------------------------------------------------------------------ + */ +ClientData +Itcl_GetStackValue(stack,pos) + Itcl_Stack *stack; /* stack to be examined */ + int pos; /* get value at this index */ +{ + if (stack->values && (stack->len > 0)) { + assert(pos < stack->len); + return stack->values[pos]; + } + return (ClientData)NULL; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_InitList() + * + * Initializes a linked list structure, setting the list to the empty + * state. + * ------------------------------------------------------------------------ + */ +void +Itcl_InitList(listPtr) + Itcl_List *listPtr; /* list to be initialized */ +{ + listPtr->validate = ITCL_VALID_LIST; + listPtr->num = 0; + listPtr->head = NULL; + listPtr->tail = NULL; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteList() + * + * Destroys a linked list structure, deleting all of its elements and + * setting it to an empty state. If the elements have memory associated + * with them, this memory must be freed before deleting the list or it + * will be lost. + * ------------------------------------------------------------------------ + */ +void +Itcl_DeleteList(listPtr) + Itcl_List *listPtr; /* list to be deleted */ +{ + Itcl_ListElem *elemPtr; + + assert(listPtr->validate == ITCL_VALID_LIST); + + elemPtr = listPtr->head; + while (elemPtr) { + elemPtr = Itcl_DeleteListElem(elemPtr); + } + listPtr->validate = 0; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_CreateListElem() + * + * Low-level routined used by procedures like Itcl_InsertList() and + * Itcl_AppendList() to create new list elements. If elements are + * available, one is taken from the list element pool. Otherwise, + * a new one is allocated. + * ------------------------------------------------------------------------ + */ +Itcl_ListElem* +Itcl_CreateListElem(listPtr) + Itcl_List *listPtr; /* list that will contain this new element */ +{ + Itcl_ListElem *elemPtr; + + if (listPoolLen > 0) { + elemPtr = listPool; + listPool = elemPtr->next; + --listPoolLen; + } + else { + elemPtr = (Itcl_ListElem*)ckalloc((unsigned)sizeof(Itcl_ListElem)); + } + elemPtr->owner = listPtr; + elemPtr->value = NULL; + elemPtr->next = NULL; + elemPtr->prev = NULL; + + return elemPtr; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_DeleteListElem() + * + * Destroys a single element in a linked list, returning it to a pool of + * elements that can be later reused. Returns a pointer to the next + * element in the list. + * ------------------------------------------------------------------------ + */ +Itcl_ListElem* +Itcl_DeleteListElem(elemPtr) + Itcl_ListElem *elemPtr; /* list element to be deleted */ +{ + Itcl_List *listPtr; + Itcl_ListElem *nextPtr; + + nextPtr = elemPtr->next; + + if (elemPtr->prev) { + elemPtr->prev->next = elemPtr->next; + } + if (elemPtr->next) { + elemPtr->next->prev = elemPtr->prev; + } + + listPtr = elemPtr->owner; + if (elemPtr == listPtr->head) + listPtr->head = elemPtr->next; + if (elemPtr == listPtr->tail) + listPtr->tail = elemPtr->prev; + --listPtr->num; + + if (listPoolLen < ITCL_LIST_POOL_SIZE) { + elemPtr->next = listPool; + listPool = elemPtr; + ++listPoolLen; + } + else { + ckfree((char*)elemPtr); + } + return nextPtr; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_InsertList() + * + * Creates a new list element containing the given value and returns + * a pointer to it. The element is inserted at the beginning of the + * specified list. + * ------------------------------------------------------------------------ + */ +Itcl_ListElem* +Itcl_InsertList(listPtr,val) + Itcl_List *listPtr; /* list being modified */ + ClientData val; /* value associated with new element */ +{ + Itcl_ListElem *elemPtr; + assert(listPtr->validate == ITCL_VALID_LIST); + + elemPtr = Itcl_CreateListElem(listPtr); + + elemPtr->value = val; + elemPtr->next = listPtr->head; + elemPtr->prev = NULL; + if (listPtr->head) { + listPtr->head->prev = elemPtr; + } + listPtr->head = elemPtr; + if (listPtr->tail == NULL) { + listPtr->tail = elemPtr; + } + ++listPtr->num; + + return elemPtr; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_InsertListElem() + * + * Creates a new list element containing the given value and returns + * a pointer to it. The element is inserted in the list just before + * the specified element. + * ------------------------------------------------------------------------ + */ +Itcl_ListElem* +Itcl_InsertListElem(pos,val) + Itcl_ListElem *pos; /* insert just before this element */ + ClientData val; /* value associated with new element */ +{ + Itcl_List *listPtr; + Itcl_ListElem *elemPtr; + + listPtr = pos->owner; + assert(listPtr->validate == ITCL_VALID_LIST); + assert(pos != NULL); + + elemPtr = Itcl_CreateListElem(listPtr); + elemPtr->value = val; + + elemPtr->prev = pos->prev; + if (elemPtr->prev) { + elemPtr->prev->next = elemPtr; + } + elemPtr->next = pos; + pos->prev = elemPtr; + + if (listPtr->head == pos) { + listPtr->head = elemPtr; + } + if (listPtr->tail == NULL) { + listPtr->tail = elemPtr; + } + ++listPtr->num; + + return elemPtr; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_AppendList() + * + * Creates a new list element containing the given value and returns + * a pointer to it. The element is appended at the end of the + * specified list. + * ------------------------------------------------------------------------ + */ +Itcl_ListElem* +Itcl_AppendList(listPtr,val) + Itcl_List *listPtr; /* list being modified */ + ClientData val; /* value associated with new element */ +{ + Itcl_ListElem *elemPtr; + assert(listPtr->validate == ITCL_VALID_LIST); + + elemPtr = Itcl_CreateListElem(listPtr); + + elemPtr->value = val; + elemPtr->prev = listPtr->tail; + elemPtr->next = NULL; + if (listPtr->tail) { + listPtr->tail->next = elemPtr; + } + listPtr->tail = elemPtr; + if (listPtr->head == NULL) { + listPtr->head = elemPtr; + } + ++listPtr->num; + + return elemPtr; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_AppendListElem() + * + * Creates a new list element containing the given value and returns + * a pointer to it. The element is inserted in the list just after + * the specified element. + * ------------------------------------------------------------------------ + */ +Itcl_ListElem* +Itcl_AppendListElem(pos,val) + Itcl_ListElem *pos; /* insert just after this element */ + ClientData val; /* value associated with new element */ +{ + Itcl_List *listPtr; + Itcl_ListElem *elemPtr; + + listPtr = pos->owner; + assert(listPtr->validate == ITCL_VALID_LIST); + assert(pos != NULL); + + elemPtr = Itcl_CreateListElem(listPtr); + elemPtr->value = val; + + elemPtr->next = pos->next; + if (elemPtr->next) { + elemPtr->next->prev = elemPtr; + } + elemPtr->prev = pos; + pos->next = elemPtr; + + if (listPtr->tail == pos) { + listPtr->tail = elemPtr; + } + if (listPtr->head == NULL) { + listPtr->head = elemPtr; + } + ++listPtr->num; + + return elemPtr; +} + +/* + * ------------------------------------------------------------------------ + * Itcl_SetListValue() + * + * Modifies the value associated with a list element. + * ------------------------------------------------------------------------ + */ +void +Itcl_SetListValue(elemPtr,val) + Itcl_ListElem *elemPtr; /* list element being modified */ + ClientData val; /* new value associated with element */ +{ + Itcl_List *listPtr = elemPtr->owner; + assert(listPtr->validate == ITCL_VALID_LIST); + assert(elemPtr != NULL); + + elemPtr->value = val; +} + + +/* + * ======================================================================== + * REFERENCE-COUNTED DATA + * + * The following procedures manage generic reference-counted data. + * They are similar in spirit to the Tcl_Preserve/Tcl_Release + * procedures defined in the Tcl/Tk core. But these procedures use + * a hash table instead of a linked list to maintain the references, + * so they scale better. Also, the Tcl procedures have a bad behavior + * during the "exit" command. Their exit handler shuts them down + * when other data is still being reference-counted and cleaned up. + * + * ------------------------------------------------------------------------ + * Itcl_EventuallyFree() + * + * Registers a piece of data so that it will be freed when no longer + * in use. The data is registered with an initial usage count of "0". + * Future calls to Itcl_PreserveData() increase this usage count, and + * calls to Itcl_ReleaseData() decrease the count until it reaches + * zero and the data is freed. + * ------------------------------------------------------------------------ + */ +void +Itcl_EventuallyFree(cdata, fproc) + ClientData cdata; /* data to be freed when not in use */ + Tcl_FreeProc *fproc; /* procedure called to free data */ +{ + int newEntry; + Tcl_HashEntry *entry; + ItclPreservedData *chunk; + + /* + * If the clientData value is NULL, do nothing. + */ + if (cdata == NULL) { + return; + } + + /* + * If a list has not yet been created to manage bits of + * preserved data, then create it. + */ + if (!ItclPreservedList) { + ItclPreservedList = (Tcl_HashTable*)ckalloc( + (unsigned)sizeof(Tcl_HashTable) + ); + Tcl_InitHashTable(ItclPreservedList, TCL_ONE_WORD_KEYS); + } + + /* + * Find or create the data in the global list. + */ + entry = Tcl_CreateHashEntry(ItclPreservedList,(char*)cdata, &newEntry); + if (newEntry) { + chunk = (ItclPreservedData*)ckalloc( + (unsigned)sizeof(ItclPreservedData) + ); + chunk->data = cdata; + chunk->usage = 0; + chunk->fproc = fproc; + Tcl_SetHashValue(entry, (ClientData)chunk); + } + else { + chunk = (ItclPreservedData*)Tcl_GetHashValue(entry); + chunk->fproc = fproc; + } + + /* + * If the usage count is zero, then delete the data now. + */ + if (chunk->usage == 0) { + chunk->usage = -1; /* cannot preserve/release anymore */ + + (*chunk->fproc)((char*)chunk->data); + Tcl_DeleteHashEntry(entry); + ckfree((char*)chunk); + } +} + +/* + * ------------------------------------------------------------------------ + * Itcl_PreserveData() + * + * Increases the usage count for a piece of data that will be freed + * later when no longer needed. Each call to Itcl_PreserveData() + * puts one claim on a piece of data, and subsequent calls to + * Itcl_ReleaseData() remove those claims. When Itcl_EventuallyFree() + * is called, and when the usage count reaches zero, the data is + * freed. + * ------------------------------------------------------------------------ + */ +void +Itcl_PreserveData(cdata) + ClientData cdata; /* data to be preserved */ +{ + Tcl_HashEntry *entry; + ItclPreservedData *chunk; + int newEntry; + + /* + * If the clientData value is NULL, do nothing. + */ + if (cdata == NULL) { + return; + } + + /* + * If a list has not yet been created to manage bits of + * preserved data, then create it. + */ + if (!ItclPreservedList) { + ItclPreservedList = (Tcl_HashTable*)ckalloc( + (unsigned)sizeof(Tcl_HashTable) + ); + Tcl_InitHashTable(ItclPreservedList,TCL_ONE_WORD_KEYS); + } + + /* + * Find the data in the global list and bump its usage count. + */ + entry = Tcl_CreateHashEntry(ItclPreservedList,(char*)cdata, &newEntry); + if (newEntry) { + chunk = (ItclPreservedData*)ckalloc( + (unsigned)sizeof(ItclPreservedData) + ); + chunk->data = cdata; + chunk->usage = 0; + chunk->fproc = NULL; + Tcl_SetHashValue(entry, (ClientData)chunk); + } + else { + chunk = (ItclPreservedData*)Tcl_GetHashValue(entry); + } + + /* + * Only increment the usage if it is non-negative. + * Negative numbers mean that the data is in the process + * of being destroyed by Itcl_ReleaseData(), and should + * not be further preserved. + */ + if (chunk->usage >= 0) { + chunk->usage++; + } +} + +/* + * ------------------------------------------------------------------------ + * Itcl_ReleaseData() + * + * Decreases the usage count for a piece of data that was registered + * previously via Itcl_PreserveData(). After Itcl_EventuallyFree() + * is called and the usage count reaches zero, the data is + * automatically freed. + * ------------------------------------------------------------------------ + */ +void +Itcl_ReleaseData(cdata) + ClientData cdata; /* data to be released */ +{ + Tcl_HashEntry *entry; + ItclPreservedData *chunk; + + /* + * If the clientData value is NULL, do nothing. + */ + if (cdata == NULL) { + return; + } + + /* + * Otherwise, find the data in the global list and + * decrement its usage count. + */ + entry = NULL; + if (ItclPreservedList) { + entry = Tcl_FindHashEntry(ItclPreservedList,(char*)cdata); + } + if (!entry) { + panic("Itcl_ReleaseData can't find reference for 0x%x", cdata); + } + + /* + * Only decrement the usage if it is non-negative. + * When the usage reaches zero, set it to a negative number + * to indicate that data is being destroyed, and then + * invoke the client delete proc. When the data is deleted, + * remove the entry from the preservation list. + */ + chunk = (ItclPreservedData*)Tcl_GetHashValue(entry); + if (chunk->usage > 0 && --chunk->usage == 0) { + + if (chunk->fproc) { + chunk->usage = -1; /* cannot preserve/release anymore */ + (*chunk->fproc)((char*)chunk->data); + } + + Tcl_DeleteHashEntry(entry); + ckfree((char*)chunk); + } +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_SaveInterpState() + * + * Takes a snapshot of the current result state of the interpreter. + * The snapshot can be restored at any point by Itcl_RestoreInterpState. + * So if you are in the middle of building a return result, you can + * snapshot the interpreter, execute a command that might generate an + * error, restore the snapshot, and continue building the result string. + * + * Once a snapshot is saved, it must be restored by calling + * Itcl_RestoreInterpState, or discarded by calling + * Itcl_DiscardInterpState. Otherwise, memory will be leaked. + * + * Returns a token representing the state of the interpreter. + * ------------------------------------------------------------------------ + */ +Itcl_InterpState +Itcl_SaveInterpState(interp, status) + Tcl_Interp* interp; /* interpreter being modified */ + int status; /* integer status code for current operation */ +{ + Interp *iPtr = (Interp*)interp; + + InterpState *info; + char *val; + + info = (InterpState*)ckalloc(sizeof(InterpState)); + info->validate = TCL_STATE_VALID; + info->status = status; + info->errorInfo = NULL; + info->errorCode = NULL; + + /* + * Get the result object from the interpreter. This synchronizes + * the old-style result, so we don't have to worry about it. + * Keeping the object result is enough. + */ + info->objResult = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(info->objResult); + + /* + * If an error is in progress, preserve its state. + */ + if ((iPtr->flags & ERR_IN_PROGRESS) != 0) { + val = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); + if (val) { + info->errorInfo = ckalloc((unsigned)(strlen(val)+1)); + strcpy(info->errorInfo, val); + } + + val = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); + if (val) { + info->errorCode = ckalloc((unsigned)(strlen(val)+1)); + strcpy(info->errorCode, val); + } + } + + /* + * Now, reset the interpreter to a clean state. + */ + Tcl_ResetResult(interp); + + return (Itcl_InterpState)info; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_RestoreInterpState() + * + * Restores the state of the interpreter to a snapshot taken by + * Itcl_SaveInterpState. This affects variables such as "errorInfo" + * and "errorCode". After this call, the token for the interpreter + * state is no longer valid. + * + * Returns the status code that was pending at the time the state was + * captured. + * ------------------------------------------------------------------------ + */ +int +Itcl_RestoreInterpState(interp, state) + Tcl_Interp* interp; /* interpreter being modified */ + Itcl_InterpState state; /* token representing interpreter state */ +{ + Interp *iPtr = (Interp*)interp; + InterpState *info = (InterpState*)state; + int status; + + if (info->validate != TCL_STATE_VALID) { + panic("bad token in Itcl_RestoreInterpState"); + } + Tcl_ResetResult(interp); + + /* + * If an error is in progress, restore its state. + * Set the error code the hard way--set the variable directly + * and fix the interpreter flags. Otherwise, if the error code + * string is really a list, it will get wrapped in extra {}'s. + */ + if (info->errorInfo) { + Tcl_AddErrorInfo(interp, info->errorInfo); + ckfree(info->errorInfo); + } + + if (info->errorCode) { + (void) Tcl_SetVar2(interp, "errorCode", (char*)NULL, + info->errorCode, TCL_GLOBAL_ONLY); + iPtr->flags |= ERROR_CODE_SET; + + ckfree(info->errorCode); + } + + /* + * Assign the object result back to the interpreter, then + * release our hold on it. + */ + Tcl_SetObjResult(interp, info->objResult); + Tcl_DecrRefCount(info->objResult); + + status = info->status; + info->validate = 0; + ckfree((char*)info); + + return status; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_DiscardInterpState() + * + * Frees the memory associated with an interpreter snapshot taken by + * Itcl_SaveInterpState. If the snapshot is not restored, this + * procedure must be called to discard it, or the memory will be lost. + * After this call, the token for the interpreter state is no longer + * valid. + * ------------------------------------------------------------------------ + */ +void +Itcl_DiscardInterpState(state) + Itcl_InterpState state; /* token representing interpreter state */ +{ + InterpState *info = (InterpState*)state; + + if (info->validate != TCL_STATE_VALID) { + panic("bad token in Itcl_DiscardInterpState"); + } + + if (info->errorInfo) { + ckfree(info->errorInfo); + } + if (info->errorCode) { + ckfree(info->errorCode); + } + Tcl_DecrRefCount(info->objResult); + + info->validate = 0; + ckfree((char*)info); +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_Protection() + * + * Used to query/set the protection level used when commands/variables + * are defined within a class. The default protection level (when + * no public/protected/private command is active) is ITCL_DEFAULT_PROTECT. + * In the default case, new commands are treated as public, while new + * variables are treated as protected. + * + * If the specified level is 0, then this procedure returns the + * current value without changing it. Otherwise, it sets the current + * value to the specified protection level, and returns the previous + * value. + * ------------------------------------------------------------------------ + */ +int +Itcl_Protection(interp, newLevel) + Tcl_Interp *interp; /* interpreter being queried */ + int newLevel; /* new protection level or 0 */ +{ + int oldVal; + ItclObjectInfo *info; + + /* + * If a new level was specified, then set the protection level. + * In any case, return the protection level as it stands right now. + */ + info = (ItclObjectInfo*) Tcl_GetAssocData(interp, ITCL_INTERP_DATA, + (Tcl_InterpDeleteProc**)NULL); + + assert(info != NULL); + oldVal = info->protection; + + if (newLevel != 0) { + assert(newLevel == ITCL_PUBLIC || + newLevel == ITCL_PROTECTED || + newLevel == ITCL_PRIVATE || + newLevel == ITCL_DEFAULT_PROTECT); + info->protection = newLevel; + } + return oldVal; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ProtectionStr() + * + * Converts an integer protection code (ITCL_PUBLIC, ITCL_PROTECTED, + * or ITCL_PRIVATE) into a human-readable character string. Returns + * a pointer to this string. + * ------------------------------------------------------------------------ + */ +char* +Itcl_ProtectionStr(pLevel) + int pLevel; /* protection level */ +{ + switch (pLevel) { + case ITCL_PUBLIC: + return "public"; + case ITCL_PROTECTED: + return "protected"; + case ITCL_PRIVATE: + return "private"; + } + return ""; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_CanAccess() + * + * Checks to see if a class member can be accessed from a particular + * namespace context. Public things can always be accessed. Protected + * things can be accessed if the "from" namespace appears in the + * inheritance hierarchy of the class namespace. Private things + * can be accessed only if the "from" namespace is the same as the + * class that contains them. + * + * Returns 1/0 indicating true/false. + * ------------------------------------------------------------------------ + */ +int +Itcl_CanAccess(memberPtr, fromNsPtr) + ItclMember* memberPtr; /* class member being tested */ + Tcl_Namespace* fromNsPtr; /* namespace requesting access */ +{ + ItclClass* fromCdPtr; + Tcl_HashEntry *entry; + + /* + * If the protection level is "public" or "private", then the + * answer is known immediately. + */ + if (memberPtr->protection == ITCL_PUBLIC) { + return 1; + } + else if (memberPtr->protection == ITCL_PRIVATE) { + return (memberPtr->classDefn->namesp == fromNsPtr); + } + + /* + * If the protection level is "protected", then check the + * heritage of the namespace requesting access. If cdefnPtr + * is in the heritage, then access is allowed. + */ + assert (memberPtr->protection == ITCL_PROTECTED); + + if (Itcl_IsClassNamespace(fromNsPtr)) { + fromCdPtr = (ItclClass*)fromNsPtr->clientData; + + entry = Tcl_FindHashEntry(&fromCdPtr->heritage, + (char*)memberPtr->classDefn); + + if (entry) { + return 1; + } + } + return 0; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_CanAccessFunc() + * + * Checks to see if a member function with the specified protection + * level can be accessed from a particular namespace context. This + * follows the same rules enforced by Itcl_CanAccess, but adds one + * special case: If the function is a protected method, and if the + * current context is a base class that has the same method, then + * access is allowed. + * + * Returns 1/0 indicating true/false. + * ------------------------------------------------------------------------ + */ +int +Itcl_CanAccessFunc(mfunc, fromNsPtr) + ItclMemberFunc* mfunc; /* member function being tested */ + Tcl_Namespace* fromNsPtr; /* namespace requesting access */ +{ + ItclClass *cdPtr, *fromCdPtr; + ItclMemberFunc *ovlfunc; + Tcl_HashEntry *entry; + + /* + * Apply the usual rules first. + */ + if (Itcl_CanAccess(mfunc->member, fromNsPtr)) { + return 1; + } + + /* + * As a last resort, see if the namespace is really a base + * class of the class containing the method. Look for a + * method with the same name in the base class. If there + * is one, then this method overrides it, and the base class + * has access. + */ + if ((mfunc->member->flags & ITCL_COMMON) == 0 && + Itcl_IsClassNamespace(fromNsPtr)) { + + cdPtr = mfunc->member->classDefn; + fromCdPtr = (ItclClass*)fromNsPtr->clientData; + + if (Tcl_FindHashEntry(&cdPtr->heritage, (char*)fromCdPtr)) { + entry = Tcl_FindHashEntry(&fromCdPtr->resolveCmds, + mfunc->member->name); + + if (entry) { + ovlfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); + if ((ovlfunc->member->flags & ITCL_COMMON) == 0 && + ovlfunc->member->protection < ITCL_PRIVATE) { + return 1; + } + } + } + } + return 0; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_GetTrueNamespace() + * + * Returns the current namespace context. This procedure is similar + * to Tcl_GetCurrentNamespace, but it supports the notion of + * "transparent" call frames installed by Itcl_HandleInstance. + * + * Returns a pointer to the current namespace calling context. + * ------------------------------------------------------------------------ + */ +Tcl_Namespace* +Itcl_GetTrueNamespace(interp, info) + Tcl_Interp *interp; /* interpreter being queried */ + ItclObjectInfo *info; /* object info associated with interp */ +{ + int i, transparent; + Tcl_CallFrame *framePtr, *transFramePtr; + Tcl_Namespace *contextNs; + + /* + * See if the current call frame is on the list of transparent + * call frames. + */ + transparent = 0; + + framePtr = _Tcl_GetCallFrame(interp, 0); + for (i = Itcl_GetStackSize(&info->transparentFrames)-1; i >= 0; i--) { + transFramePtr = (Tcl_CallFrame*) + Itcl_GetStackValue(&info->transparentFrames, i); + + if (framePtr == transFramePtr) { + transparent = 1; + break; + } + } + + /* + * If this is a transparent call frame, return the namespace + * context one level up. + */ + if (transparent) { + framePtr = _Tcl_GetCallFrame(interp, 1); + if (framePtr) { + contextNs = framePtr->nsPtr; + } else { + contextNs = Tcl_GetGlobalNamespace(interp); + } + } + else { + contextNs = Tcl_GetCurrentNamespace(interp); + } + return contextNs; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_ParseNamespPath() + * + * Parses a reference to a namespace element of the form: + * + * namesp::namesp::namesp::element + * + * Returns pointers to the head part ("namesp::namesp::namesp") + * and the tail part ("element"). If the head part is missing, + * a NULL pointer is returned and the rest of the string is taken + * as the tail. + * + * Both head and tail point to locations within the given dynamic + * string buffer. This buffer must be uninitialized when passed + * into this procedure, and it must be freed later on, when the + * strings are no longer needed. + * ------------------------------------------------------------------------ + */ +void +Itcl_ParseNamespPath(name, buffer, head, tail) + char *name; /* path name to class member */ + Tcl_DString *buffer; /* dynamic string buffer (uninitialized) */ + char **head; /* returns "namesp::namesp::namesp" part */ + char **tail; /* returns "element" part */ +{ + register char *sep; + + Tcl_DStringInit(buffer); + + /* + * Copy the name into the buffer and parse it. Look + * backward from the end of the string to the first '::' + * scope qualifier. + */ + Tcl_DStringAppend(buffer, name, -1); + name = Tcl_DStringValue(buffer); + + for (sep=name; *sep != '\0'; sep++) + ; + + while (--sep > name) { + if (*sep == ':' && *(sep-1) == ':') { + break; + } + } + + /* + * Found head/tail parts. If there are extra :'s, keep backing + * up until the head is found. This supports the Tcl namespace + * behavior, which allows names like "foo:::bar". + */ + if (sep > name) { + *tail = sep+1; + while (sep > name && *(sep-1) == ':') { + sep--; + } + *sep = '\0'; + *head = name; + } + + /* + * No :: separators--the whole name is treated as a tail. + */ + else { + *tail = name; + *head = NULL; + } +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_DecodeScopedCommand() + * + * Decodes a scoped command of the form: + * + * namespace inscope + * + * If the given string is not a scoped value, this procedure does + * nothing and returns TCL_OK. If the string is a scoped value, + * then it is decoded, and the namespace, and the simple command + * string are returned as arguments; the simple command should + * be freed when no longer in use. If anything goes wrong, this + * procedure returns TCL_ERROR, along with an error message in + * the interpreter. + * ------------------------------------------------------------------------ + */ +int +Itcl_DecodeScopedCommand(interp, name, rNsPtr, rCmdPtr) + Tcl_Interp *interp; /* current interpreter */ + char *name; /* string to be decoded */ + Tcl_Namespace **rNsPtr; /* returns: namespace for scoped value */ + char **rCmdPtr; /* returns: simple command word */ +{ + Tcl_Namespace *nsPtr = NULL; + char *cmdName = name; + int len = strlen(name); + + char *pos; + int listc, result; + char **listv; + + if ((*name == 'n') && (len > 17) && (strncmp(name, "namespace", 9) == 0)) { + for (pos = (name + 9); (*pos == ' '); pos++) { + /* empty body: skip over spaces */ + } + if ((*pos == 'i') && ((pos + 7) <= (name + len)) + && (strncmp(pos, "inscope", 7) == 0)) { + + result = Tcl_SplitList(interp, name, &listc, &listv); + if (result == TCL_OK) { + if (listc != 4) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "malformed command \"", name, "\": should be \"", + "namespace inscope namesp command\"", + (char*)NULL); + result = TCL_ERROR; + } + else { + nsPtr = Tcl_FindNamespace(interp, listv[2], + (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); + + if (!nsPtr) { + result = TCL_ERROR; + } + else { + cmdName = ckalloc((unsigned)(strlen(listv[3])+1)); + strcpy(cmdName, listv[3]); + } + } + } + ckfree((char*)listv); + + if (result != TCL_OK) { + char msg[512]; + sprintf(msg, "\n (while decoding scoped command \"%.400s\")", name); + Tcl_AddObjErrorInfo(interp, msg, -1); + return TCL_ERROR; + } + } + } + + *rNsPtr = nsPtr; + *rCmdPtr = cmdName; + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_EvalArgs() + * + * This procedure invokes a list of (objc,objv) arguments as a + * single command. It is similar to Tcl_EvalObj, but it doesn't + * do any parsing or compilation. It simply treats the first + * argument as a command and invokes that command in the current + * context. + * + * Returns TCL_OK if successful. Otherwise, this procedure returns + * TCL_ERROR along with an error message in the interpreter. + * ------------------------------------------------------------------------ + */ +int +Itcl_EvalArgs(interp, objc, objv) + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + int result; + Tcl_Command cmd; + Command *cmdPtr; + int cmdlinec; + Tcl_Obj **cmdlinev; + Tcl_Obj *cmdlinePtr = NULL; + + /* + * Resolve the command by converting it to a CmdName object. + * This caches a pointer to the Command structure for the + * command, so if we need it again, it's ready to use. + */ + cmd = Tcl_GetCommandFromObj(interp, objv[0]); + cmdPtr = (Command*)cmd; + + cmdlinec = objc; + cmdlinev = (Tcl_Obj**)objv; + + /* + * If the command is still not found, handle it with the + * "unknown" proc. + */ + if (cmdPtr == NULL) { + cmd = Tcl_FindCommand(interp, "unknown", + (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); + + if (cmd == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", + Tcl_GetStringFromObj(objv[0], (int*)NULL), "\"", + (char*)NULL); + return TCL_ERROR; + } + cmdPtr = (Command*)cmd; + + cmdlinePtr = Itcl_CreateArgs(interp, "unknown", objc, objv); + + (void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr, + &cmdlinec, &cmdlinev); + } + + /* + * Finally, invoke the command's Tcl_ObjCmdProc. Be careful + * to pass in the proper client data. + */ + Tcl_ResetResult(interp); + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, + cmdlinec, cmdlinev); + + if (cmdlinePtr) { + Tcl_DecrRefCount(cmdlinePtr); + } + return result; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_CreateArgs() + * + * This procedure takes a string and a list of (objc,objv) arguments, + * and glues them together in a single list. This is useful when + * a command word needs to be prepended or substituted into a command + * line before it is executed. The arguments are returned in a single + * list object, and they can be retrieved by calling + * Tcl_ListObjGetElements. When the arguments are no longer needed, + * they should be discarded by decrementing the reference count for + * the list object. + * + * Returns a pointer to the list object containing the arguments. + * ------------------------------------------------------------------------ + */ +Tcl_Obj* +Itcl_CreateArgs(interp, string, objc, objv) + Tcl_Interp *interp; /* current interpreter */ + char *string; /* first command word */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + int i; + Tcl_Obj *listPtr; + + listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, + Tcl_NewStringObj(string, -1)); + + for (i=0; i < objc; i++) { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objv[i]); + } + + Tcl_IncrRefCount(listPtr); + return listPtr; +}

itcl_util.c Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: itclInt.h =================================================================== --- itclInt.h (nonexistent) +++ itclInt.h (revision 1765) @@ -0,0 +1,535 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * ADDING [incr Tcl] TO A Tcl-BASED APPLICATION: + * + * To add [incr Tcl] facilities to a Tcl application, modify the + * Tcl_AppInit() routine as follows: + * + * 1) Include this header file near the top of the file containing + * Tcl_AppInit(): + * + * #include "itcl.h" + * + * 2) Within the body of Tcl_AppInit(), add the following lines: + * + * if (Itcl_Init(interp) == TCL_ERROR) { + * return TCL_ERROR; + * } + * + * 3) Link your application with libitcl.a + * + * NOTE: An example file "tclAppInit.c" containing the changes shown + * above is included in this distribution. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * RCS: $Id: itclInt.h,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $ + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#ifndef ITCLINT_H +#define ITCLINT_H + +#include "itcl.h" +#include "tclInt.h" + +#ifdef BUILD_itcl +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLEXPORT +#endif + +/* + * Since the Tcl/Tk distribution doesn't perform any asserts, + * dynamic loading can fail to find the __assert function. + * As a workaround, we'll include our own. + */ +#undef assert +#ifdef NDEBUG +#define assert(EX) ((void)0) +#else +EXTERN void Itcl_Assert _ANSI_ARGS_((char *testExpr, char *fileName, int lineNum) +); +#if defined(__STDC__) +#define assert(EX) (void)((EX) || (Itcl_Assert(#EX, __FILE__, __LINE__), 0)) +#else +#define assert(EX) (void)((EX) || (Itcl_Assert("EX", __FILE__, __LINE__), 0)) +#endif /* __STDC__ */ +#endif /* NDEBUG */ + + +/* + * Common info for managing all known objects. + * Each interpreter has one of these data structures stored as + * clientData in the "itcl" namespace. It is also accessible + * as associated data via the key ITCL_INTERP_DATA. + */ +struct ItclObject; +typedef struct ItclObjectInfo { + Tcl_Interp *interp; /* interpreter that manages this info */ + Tcl_HashTable objects; /* list of all known objects */ + + Itcl_Stack transparentFrames; /* stack of call frames that should be + * treated transparently. When + * Itcl_EvalMemberCode is invoked in + * one of these contexts, it does an + * "uplevel" to get past the transparent + * frame and back to the calling context. */ + Tcl_HashTable contextFrames; /* object contexts for active call frames */ + + int protection; /* protection level currently in effect */ + + Itcl_Stack cdefnStack; /* stack of class definitions currently + * being parsed */ +} ItclObjectInfo; + +#define ITCL_INTERP_DATA "itcl_data" + +/* + * Representation for each [incr Tcl] class. + */ +typedef struct ItclClass { + char *name; /* class name */ + char *fullname; /* fully qualified class name */ + Tcl_Interp *interp; /* interpreter that manages this info */ + Tcl_Namespace *namesp; /* namespace representing class scope */ + Tcl_Command accessCmd; /* access command for creating instances */ + + struct ItclObjectInfo *info; /* info about all known objects */ + Itcl_List bases; /* list of base classes */ + Itcl_List derived; /* list of all derived classes */ + Tcl_HashTable heritage; /* table of all base classes. Look up + * by pointer to class definition. This + * provides fast lookup for inheritance + * tests. */ + Tcl_Obj *initCode; /* initialization code for new objs */ + Tcl_HashTable variables; /* definitions for all data members + in this class. Look up simple string + names and get back ItclVarDefn* ptrs */ + Tcl_HashTable functions; /* definitions for all member functions + in this class. Look up simple string + names and get back ItclMemberFunc* ptrs */ + int numInstanceVars; /* number of instance vars in variables + table */ + Tcl_HashTable resolveVars; /* all possible names for variables in + * this class (e.g., x, foo::x, etc.) */ + Tcl_HashTable resolveCmds; /* all possible names for functions in + * this class (e.g., x, foo::x, etc.) */ + int unique; /* unique number for #auto generation */ + int flags; /* maintains class status */ +} ItclClass; + +typedef struct ItclHierIter { + ItclClass *current; /* current position in hierarchy */ + Itcl_Stack stack; /* stack used for traversal */ +} ItclHierIter; + +/* + * Representation for each [incr Tcl] object. + */ +typedef struct ItclObject { + ItclClass *classDefn; /* most-specific class */ + Tcl_Command accessCmd; /* object access command */ + + int dataSize; /* number of elements in data array */ + Var** data; /* all object-specific data members */ + Tcl_HashTable* constructed; /* temp storage used during construction */ + Tcl_HashTable* destructed; /* temp storage used during destruction */ +} ItclObject; + +#define ITCL_IGNORE_ERRS 0x002 /* useful for construction/destruction */ + +/* + * Implementation for any code body in an [incr Tcl] class. + */ +typedef struct ItclMemberCode { + int flags; /* flags describing implementation */ + CompiledLocal *arglist; /* list of arg names and initial values */ + int argcount; /* number of args in arglist */ + Proc *procPtr; /* Tcl proc representation (needed to + * handle compiled locals) */ + union { + Tcl_CmdProc *argCmd; /* (argc,argv) C implementation */ + Tcl_ObjCmdProc *objCmd; /* (objc,objv) C implementation */ + } cfunc; + + ClientData clientData; /* client data for C implementations */ + +} ItclMemberCode; + +/* + * Basic representation for class members (commands/variables) + */ +typedef struct ItclMember { + Tcl_Interp* interp; /* interpreter containing the class */ + ItclClass* classDefn; /* class containing this member */ + char* name; /* member name */ + char* fullname; /* member name with "class::" qualifier */ + int protection; /* protection level */ + int flags; /* flags describing member (see below) */ + ItclMemberCode *code; /* code associated with member */ +} ItclMember; + +/* + * Flag bits for ItclMemberCode and ItclMember: + */ +#define ITCL_IMPLEMENT_NONE 0x001 /* no implementation */ +#define ITCL_IMPLEMENT_TCL 0x002 /* Tcl implementation */ +#define ITCL_IMPLEMENT_ARGCMD 0x004 /* (argc,argv) C implementation */ +#define ITCL_IMPLEMENT_OBJCMD 0x008 /* (objc,objv) C implementation */ +#define ITCL_IMPLEMENT_C 0x00c /* either kind of C implementation */ +#define ITCL_CONSTRUCTOR 0x010 /* non-zero => is a constructor */ +#define ITCL_DESTRUCTOR 0x020 /* non-zero => is a destructor */ +#define ITCL_COMMON 0x040 /* non-zero => is a "proc" */ +#define ITCL_ARG_SPEC 0x080 /* non-zero => has an argument spec */ + +#define ITCL_OLD_STYLE 0x100 /* non-zero => old-style method + * (process "config" argument) */ + +#define ITCL_THIS_VAR 0x200 /* non-zero => built-in "this" variable */ + +/* + * Representation of member functions in an [incr Tcl] class. + */ +typedef struct ItclMemberFunc { + ItclMember *member; /* basic member info */ + Tcl_Command accessCmd; /* Tcl command installed for this function */ + CompiledLocal *arglist; /* list of arg names and initial values */ + int argcount; /* number of args in arglist */ +} ItclMemberFunc; + +/* + * Instance variables. + */ +typedef struct ItclVarDefn { + ItclMember *member; /* basic member info */ + char* init; /* initial value */ +} ItclVarDefn; + +/* + * Instance variable lookup entry. + */ +typedef struct ItclVarLookup { + ItclVarDefn* vdefn; /* variable definition */ + int usage; /* number of uses for this record */ + int accessible; /* non-zero => accessible from class with + * this lookup record in its resolveVars */ + char *leastQualName; /* simplist name for this variable, with + * the fewest qualifiers. This string is + * taken from the resolveVars table, so + * it shouldn't be freed. */ + union { + int index; /* index into virtual table (instance data) */ + Tcl_Var common; /* variable (common data) */ + } var; +} ItclVarLookup; + +/* + * Representation for the context in which a body of [incr Tcl] + * code executes. In ordinary Tcl, this is a CallFrame. But for + * [incr Tcl] code bodies, we must be careful to set up the + * CallFrame properly, to plug in instance variables before + * executing the code body. + */ +typedef struct ItclContext { + ItclClass *classDefn; /* class definition */ + CallFrame frame; /* call frame for object context */ + Var *compiledLocals; /* points to storage for compiled locals */ + Var localStorage[20]; /* default storage for compiled locals */ +} ItclContext; + + +/* + * Functions used within the package, but not considered "public" + */ + +EXTERN int Itcl_IsClassNamespace _ANSI_ARGS_((Tcl_Namespace *namesp)); +EXTERN int Itcl_IsClass _ANSI_ARGS_((Tcl_Command cmd)); +EXTERN ItclClass* Itcl_FindClass _ANSI_ARGS_((Tcl_Interp* interp, + char* path, int autoload)); + +EXTERN int Itcl_FindObject _ANSI_ARGS_((Tcl_Interp *interp, + char *name, ItclObject **roPtr)); +EXTERN int Itcl_IsObject _ANSI_ARGS_((Tcl_Command cmd)); +EXTERN int Itcl_ObjectIsa _ANSI_ARGS_((ItclObject *contextObj, + ItclClass *cdefn)); + + +EXTERN int Itcl_Protection _ANSI_ARGS_((Tcl_Interp *interp, + int newLevel)); +EXTERN char* Itcl_ProtectionStr _ANSI_ARGS_((int pLevel)); +EXTERN int Itcl_CanAccess _ANSI_ARGS_((ItclMember* memberPtr, + Tcl_Namespace* fromNsPtr)); +EXTERN int Itcl_CanAccessFunc _ANSI_ARGS_((ItclMemberFunc* mfunc, + Tcl_Namespace* fromNsPtr)); +EXTERN Tcl_Namespace* Itcl_GetTrueNamespace _ANSI_ARGS_((Tcl_Interp *interp, + ItclObjectInfo *info)); + +EXTERN void Itcl_ParseNamespPath _ANSI_ARGS_((char *name, + Tcl_DString *buffer, char **head, char **tail)); +EXTERN int Itcl_DecodeScopedCommand _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_Namespace **rNsPtr, char **rCmdPtr)); +EXTERN int Itcl_EvalArgs _ANSI_ARGS_((Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +EXTERN Tcl_Obj* Itcl_CreateArgs _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int objc, Tcl_Obj *CONST objv[])); + +EXTERN int Itcl_PushContext _ANSI_ARGS_((Tcl_Interp *interp, + ItclMember *member, ItclClass *contextClass, ItclObject *contextObj, + ItclContext *contextPtr)); +EXTERN void Itcl_PopContext _ANSI_ARGS_((Tcl_Interp *interp, + ItclContext *contextPtr)); +EXTERN int Itcl_GetContext _ANSI_ARGS_((Tcl_Interp *interp, + ItclClass **cdefnPtr, ItclObject **odefnPtr)); + +EXTERN void Itcl_InitHierIter _ANSI_ARGS_((ItclHierIter *iter, + ItclClass *cdefn)); +EXTERN void Itcl_DeleteHierIter _ANSI_ARGS_((ItclHierIter *iter)); +EXTERN ItclClass* Itcl_AdvanceHierIter _ANSI_ARGS_((ItclHierIter *iter)); + +EXTERN int Itcl_FindClassesCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_FindObjectsCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_ProtectionCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_DelClassCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_DelObjectCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_ScopeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_CodeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_StubCreateCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_StubExistsCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_IsStub _ANSI_ARGS_((Tcl_Command cmd)); + + +/* + * Functions for manipulating classes + */ +EXTERN int Itcl_CreateClass _ANSI_ARGS_((Tcl_Interp* interp, char* path, + ItclObjectInfo *info, ItclClass **rPtr)); +EXTERN int Itcl_DeleteClass _ANSI_ARGS_((Tcl_Interp *interp, + ItclClass *cdefnPtr)); +EXTERN Tcl_Namespace* Itcl_FindClassNamespace _ANSI_ARGS_((Tcl_Interp* interp, + char* path)); +EXTERN int Itcl_HandleClass _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_ClassCmdResolver _ANSI_ARGS_((Tcl_Interp *interp, + char* name, Tcl_Namespace *context, int flags, Tcl_Command *rPtr)); +EXTERN int Itcl_ClassVarResolver _ANSI_ARGS_((Tcl_Interp *interp, + char* name, Tcl_Namespace *context, int flags, Tcl_Var *rPtr)); +EXTERN int Itcl_ClassCompiledVarResolver _ANSI_ARGS_((Tcl_Interp *interp, + char* name, int length, Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr)); +EXTERN void Itcl_BuildVirtualTables _ANSI_ARGS_((ItclClass* cdefnPtr)); +EXTERN int Itcl_CreateVarDefn _ANSI_ARGS_((Tcl_Interp *interp, + ItclClass* cdefn, char* name, char* init, char* config, + ItclVarDefn** vdefnPtr)); +EXTERN void Itcl_DeleteVarDefn _ANSI_ARGS_((ItclVarDefn *vdefn)); +EXTERN char* Itcl_GetCommonVar _ANSI_ARGS_((Tcl_Interp *interp, + char *name, ItclClass *contextClass)); +EXTERN ItclMember* Itcl_CreateMember _ANSI_ARGS_((Tcl_Interp* interp, + ItclClass *cdefn, char* name)); +EXTERN void Itcl_DeleteMember _ANSI_ARGS_((ItclMember *memPtr)); + + +/* + * Functions for manipulating objects + */ +EXTERN int Itcl_CreateObject _ANSI_ARGS_((Tcl_Interp *interp, + char* name, ItclClass *cdefn, int objc, Tcl_Obj *CONST objv[], + ItclObject **roPtr)); +EXTERN int Itcl_DeleteObject _ANSI_ARGS_((Tcl_Interp *interp, + ItclObject *contextObj)); +EXTERN int Itcl_DestructObject _ANSI_ARGS_((Tcl_Interp *interp, + ItclObject *contextObj, int flags)); +EXTERN int Itcl_HandleInstance _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN char* Itcl_GetInstanceVar _ANSI_ARGS_((Tcl_Interp *interp, + char *name, ItclObject *contextObj, ItclClass *contextClass)); +EXTERN int Itcl_ScopedVarResolver _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_Namespace *contextNs, int flags, Tcl_Var *rPtr)); + + +/* + * Functions for manipulating methods and procs + */ +EXTERN int Itcl_BodyCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_ConfigBodyCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_CreateMethod _ANSI_ARGS_((Tcl_Interp* interp, + ItclClass *cdefn, char* name, char* arglist, char* body)); +EXTERN int Itcl_CreateProc _ANSI_ARGS_((Tcl_Interp* interp, + ItclClass *cdefn, char* name, char* arglist, char* body)); +EXTERN int Itcl_CreateMemberFunc _ANSI_ARGS_((Tcl_Interp* interp, + ItclClass *cdefn, char* name, char* arglist, char* body, + ItclMemberFunc** mfuncPtr)); +EXTERN int Itcl_ChangeMemberFunc _ANSI_ARGS_((Tcl_Interp* interp, + ItclMemberFunc* mfunc, char* arglist, char* body)); +EXTERN void Itcl_DeleteMemberFunc _ANSI_ARGS_((char* cdata)); +EXTERN int Itcl_CreateMemberCode _ANSI_ARGS_((Tcl_Interp* interp, + ItclClass *cdefn, char* arglist, char* body, ItclMemberCode** mcodePtr)); +EXTERN void Itcl_DeleteMemberCode _ANSI_ARGS_((char* cdata)); +EXTERN int Itcl_GetMemberCode _ANSI_ARGS_((Tcl_Interp* interp, + ItclMember* member)); +EXTERN int Itcl_CompileMemberCodeBody _ANSI_ARGS_((Tcl_Interp *interp, + ItclMember *member, char *desc, Tcl_Obj *bodyPtr)); +EXTERN int Itcl_EvalMemberCode _ANSI_ARGS_((Tcl_Interp *interp, + ItclMemberFunc *mfunc, ItclMember *member, ItclObject *contextObj, + int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_CreateArgList _ANSI_ARGS_((Tcl_Interp* interp, + char* decl, int* argcPtr, CompiledLocal** argPtr)); +EXTERN CompiledLocal* Itcl_CreateArg _ANSI_ARGS_((char* name, + char* init)); +EXTERN void Itcl_DeleteArgList _ANSI_ARGS_((CompiledLocal *arglist)); +EXTERN Tcl_Obj* Itcl_ArgList _ANSI_ARGS_((int argc, CompiledLocal* arglist)); +EXTERN int Itcl_EquivArgLists _ANSI_ARGS_((CompiledLocal* arg1, int arg1c, + CompiledLocal* arg2, int arg2c)); +EXTERN void Itcl_GetMemberFuncUsage _ANSI_ARGS_((ItclMemberFunc *mfunc, + ItclObject *contextObj, Tcl_Obj *objPtr)); +EXTERN int Itcl_ExecMethod _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_ExecProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_AssignArgs _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], ItclMemberFunc *mfunc)); +EXTERN int Itcl_ConstructBase _ANSI_ARGS_((Tcl_Interp *interp, + ItclObject *contextObj, ItclClass *contextClass)); +EXTERN int Itcl_InvokeMethodIfExists _ANSI_ARGS_((Tcl_Interp *interp, + char *name, ItclClass *contextClass, ItclObject *contextObj, + int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_EvalBody _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *bodyPtr)); +EXTERN int Itcl_ReportFuncErrors _ANSI_ARGS_((Tcl_Interp* interp, + ItclMemberFunc *mfunc, ItclObject *contextObj, int result)); + + +/* + * Commands for parsing class definitions + */ +EXTERN int Itcl_ParseInit _ANSI_ARGS_((Tcl_Interp *interp, + ItclObjectInfo *info)); +EXTERN int Itcl_ClassCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_ClassInheritCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_ClassProtectionCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_ClassConstructorCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_ClassDestructorCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_ClassMethodCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_ClassProcCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_ClassVariableCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_ClassCommonCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_ParseVarResolver _ANSI_ARGS_((Tcl_Interp *interp, + char* name, Tcl_Namespace *contextNs, int flags, Tcl_Var* rPtr)); + + +/* + * Commands in the "builtin" namespace + */ +EXTERN int Itcl_BiInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Itcl_InstallBiMethods _ANSI_ARGS_((Tcl_Interp *interp, + ItclClass *cdefn)); +EXTERN int Itcl_BiIsaCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_BiConfigureCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_BiCgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_BiChainCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_BiInfoClassCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_BiInfoInheritCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_BiInfoHeritageCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_BiInfoFunctionCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_BiInfoVariableCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_BiInfoBodyCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_BiInfoArgsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_DefaultInfoCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); + + +/* + * Ensembles + */ +EXTERN int Itcl_EnsembleInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Itcl_CreateEnsemble _ANSI_ARGS_((Tcl_Interp *interp, + char* ensName)); +EXTERN int Itcl_AddEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp, + char* ensName, char* partName, char* usageInfo, + Tcl_ObjCmdProc *objProc, ClientData clientData, + Tcl_CmdDeleteProc *deleteProc)); +EXTERN int Itcl_GetEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp, + char *ensName, char *partName, Tcl_CmdInfo *infoPtr)); +EXTERN int Itcl_IsEnsemble _ANSI_ARGS_((Tcl_CmdInfo* infoPtr)); +EXTERN int Itcl_GetEnsembleUsage _ANSI_ARGS_((Tcl_Interp *interp, + char *ensName, Tcl_Obj *objPtr)); +EXTERN int Itcl_GetEnsembleUsageForObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *ensObjPtr, Tcl_Obj *objPtr)); +EXTERN int Itcl_EnsembleCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_EnsPartCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itcl_EnsembleErrorCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); + + +/* + * Commands provided for backward compatibility + */ +EXTERN int Itcl_OldInit _ANSI_ARGS_((Tcl_Interp* interp, + ItclObjectInfo* info)); +EXTERN int Itcl_InstallOldBiMethods _ANSI_ARGS_((Tcl_Interp *interp, + ItclClass *cdefn)); + + +/* + * Things that should be in the Tcl core. + */ +EXTERN Tcl_CallFrame* _Tcl_GetCallFrame _ANSI_ARGS_((Tcl_Interp *interp, + int level)); +EXTERN Tcl_CallFrame* _Tcl_ActivateCallFrame _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_CallFrame *framePtr)); +EXTERN Var* _TclNewVar _ANSI_ARGS_((void)); + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT + +#endif /* ITCLINT_H */

itclInt.h Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: itcl_bicmds.c =================================================================== --- itcl_bicmds.c (nonexistent) +++ itcl_bicmds.c (revision 1765) @@ -0,0 +1,1695 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * These procedures handle built-in class methods, including the + * "isa" method (to query hierarchy info) and the "info" method + * (to query class/object data). + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * RCS: $Id: itcl_bicmds.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $ + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +/* + * Standard list of built-in methods for all objects. + */ +typedef struct BiMethod { + char* name; /* method name */ + char* usage; /* string describing usage */ + char* registration; /* registration name for C proc */ + Tcl_ObjCmdProc *proc; /* implementation C proc */ +} BiMethod; + +static BiMethod BiMethodList[] = { + { "cget", "-option", + "@itcl-builtin-cget", Itcl_BiCgetCmd }, + { "configure", "?-option? ?value -option value...?", + "@itcl-builtin-configure", Itcl_BiConfigureCmd }, + { "isa", "className", + "@itcl-builtin-isa", Itcl_BiIsaCmd }, +}; +static int BiMethodListLen = sizeof(BiMethodList)/sizeof(BiMethod); + + +/* + * FORWARD DECLARATIONS + */ +static Tcl_Obj* ItclReportPublicOpt _ANSI_ARGS_((Tcl_Interp *interp, + ItclVarDefn *vdefn, ItclObject *contextObj)); + + +/* + * ------------------------------------------------------------------------ + * Itcl_BiInit() + * + * Creates a namespace full of built-in methods/procs for [incr Tcl] + * classes. This includes things like the "isa" method and "info" + * for querying class info. Usually invoked by Itcl_Init() when + * [incr Tcl] is first installed into an interpreter. + * + * Returns TCL_OK/TCL_ERROR to indicate success/failure. + * ------------------------------------------------------------------------ + */ +int +Itcl_BiInit(interp) + Tcl_Interp *interp; /* current interpreter */ +{ + int i; + Tcl_Namespace *itclBiNs; + + /* + * Declare all of the built-in methods as C procedures. + */ + for (i=0; i < BiMethodListLen; i++) { + if (Itcl_RegisterObjC(interp, + BiMethodList[i].registration+1, BiMethodList[i].proc, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) { + + return TCL_ERROR; + } + } + + /* + * Create the "::itcl::builtin" namespace for built-in class + * commands. These commands are imported into each class + * just before the class definition is parsed. + */ + Tcl_CreateObjCommand(interp, "::itcl::builtin::chain", Itcl_BiChainCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + + if (Itcl_CreateEnsemble(interp, "::itcl::builtin::info") != TCL_OK) { + return TCL_ERROR; + } + + if (Itcl_AddEnsemblePart(interp, "::itcl::builtin::info", + "class", "", + Itcl_BiInfoClassCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK || + Itcl_AddEnsemblePart(interp, "::itcl::builtin::info", + "inherit", "", + Itcl_BiInfoInheritCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK || + Itcl_AddEnsemblePart(interp, "::itcl::builtin::info", + "heritage", "", + Itcl_BiInfoHeritageCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK || + Itcl_AddEnsemblePart(interp, "::itcl::builtin::info", + "function", "?name? ?-protection? ?-type? ?-name? ?-args? ?-body?", + Itcl_BiInfoFunctionCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK || + Itcl_AddEnsemblePart(interp, "::itcl::builtin::info", + "variable", "?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config?", + Itcl_BiInfoVariableCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK || + Itcl_AddEnsemblePart(interp, "::itcl::builtin::info", + "args", "procname", + Itcl_BiInfoArgsCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK || + Itcl_AddEnsemblePart(interp, "::itcl::builtin::info", + "body", "procname", + Itcl_BiInfoBodyCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK + ) { + return TCL_ERROR; + } + + /* + * Add an error handler to support all of the usual inquiries + * for the "info" command in the global namespace. + */ + if (Itcl_AddEnsemblePart(interp, "::itcl::builtin::info", + "@error", "", + Itcl_DefaultInfoCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) + != TCL_OK + ) { + return TCL_ERROR; + } + + /* + * Export all commands in the built-in namespace so we can + * import them later on. + */ + itclBiNs = Tcl_FindNamespace(interp, "::itcl::builtin", + (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); + + if (!itclBiNs || + Tcl_Export(interp, itclBiNs, "*", /* resetListFirst */ 1) != TCL_OK) { + return TCL_ERROR; + } + + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_InstallBiMethods() + * + * Invoked when a class is first created, just after the class + * definition has been parsed, to add definitions for built-in + * methods to the class. If a method already exists in the class + * with the same name as the built-in, then the built-in is skipped. + * Otherwise, a method definition for the built-in method is added. + * + * Returns TCL_OK if successful, or TCL_ERROR (along with an error + * message in the interpreter) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +int +Itcl_InstallBiMethods(interp, cdefn) + Tcl_Interp *interp; /* current interpreter */ + ItclClass *cdefn; /* class definition to be updated */ +{ + int result = TCL_OK; + Tcl_HashEntry *entry = NULL; + + int i; + ItclHierIter hier; + ItclClass *cdPtr; + + /* + * Scan through all of the built-in methods and see if + * that method already exists in the class. If not, add + * it in. + * + * TRICKY NOTE: The virtual tables haven't been built yet, + * so look for existing methods the hard way--by scanning + * through all classes. + */ + for (i=0; i < BiMethodListLen; i++) { + Itcl_InitHierIter(&hier, cdefn); + cdPtr = Itcl_AdvanceHierIter(&hier); + while (cdPtr) { + entry = Tcl_FindHashEntry(&cdPtr->functions, BiMethodList[i].name); + if (entry) { + break; + } + cdPtr = Itcl_AdvanceHierIter(&hier); + } + Itcl_DeleteHierIter(&hier); + + if (!entry) { + result = Itcl_CreateMethod(interp, cdefn, BiMethodList[i].name, + BiMethodList[i].usage, BiMethodList[i].registration); + + if (result != TCL_OK) { + break; + } + } + } + return result; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_BiIsaCmd() + * + * Invoked whenever the user issues the "isa" method for an object. + * Handles the following syntax: + * + * isa + * + * Checks to see if the object has the given anywhere + * in its heritage. Returns 1 if so, and 0 otherwise. + * ------------------------------------------------------------------------ + */ +/* ARGSUSED */ +int +Itcl_BiIsaCmd(clientData, interp, objc, objv) + ClientData clientData; /* class definition */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + ItclClass *contextClass, *cdefn; + ItclObject *contextObj; + char *token; + + /* + * Make sure that this command is being invoked in the proper + * context. + */ + if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) { + return TCL_ERROR; + } + + if (!contextObj) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "improper usage: should be \"object isa className\"", + (char*)NULL); + return TCL_ERROR; + } + if (objc != 2) { + token = Tcl_GetStringFromObj(objv[0], (int*)NULL); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"object ", token, " className\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Look for the requested class. If it is not found, then + * try to autoload it. If it absolutely cannot be found, + * signal an error. + */ + token = Tcl_GetStringFromObj(objv[1], (int*)NULL); + cdefn = Itcl_FindClass(interp, token, /* autoload */ 1); + if (cdefn == NULL) { + return TCL_ERROR; + } + + if (Itcl_ObjectIsa(contextObj, cdefn)) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itcl_BiConfigureCmd() + * + * Invoked whenever the user issues the "configure" method for an object. + * Handles the following syntax: + * + * configure ?-

itcl_bicmds.c Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property

Browse

Tools

Subversion Repositories or1k

Compare Revisions

Rev 578 → Rev 1765