itcl3.4.1/0000755003604700454610000000000011610104703010764 5ustar dgp891divitcl3.4.1/generic/0000755003604700454610000000000011610104703012400 5ustar dgp891divitcl3.4.1/generic/itcl.h0000644003604700454610000001461411610103534013513 0ustar dgp891div/* * ------------------------------------------------------------------------ * 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 * ======================================================================== * 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" #ifndef TCL_ALPHA_RELEASE # define TCL_ALPHA_RELEASE 0 #endif #ifndef TCL_BETA_RELEASE # define TCL_BETA_RELEASE 1 #endif #ifndef TCL_FINAL_RELEASE # define TCL_FINAL_RELEASE 2 #endif #define ITCL_MAJOR_VERSION 3 #define ITCL_MINOR_VERSION 4 #define ITCL_RELEASE_LEVEL TCL_FINAL_RELEASE #define ITCL_RELEASE_SERIAL 1 #define ITCL_VERSION "3.4" #define ITCL_PATCH_LEVEL "3.4.1" /* * 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 RC_INVOKED #undef TCL_STORAGE_CLASS #ifdef BUILD_itcl # define TCL_STORAGE_CLASS DLLEXPORT #else # ifdef USE_ITCL_STUBS # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif /* * Fix the Borland bug that's in the EXTERN macro from tcl.h. */ #ifndef TCL_EXTERN # undef DLLIMPORT # undef DLLEXPORT # ifdef __cplusplus # define TCL_EXTERNC extern "C" # else # define TCL_EXTERNC extern # endif # if defined(STATIC_BUILD) # define DLLIMPORT # define DLLEXPORT # define TCL_EXTERN(RTYPE) TCL_EXTERNC RTYPE # elif (defined(__WIN32__) && ( \ defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || \ defined(__LCC__) || defined(__WATCOMC__) || \ (defined(__GNUC__) && defined(__declspec)) \ )) || (defined(MAC_TCL) && FUNCTION_DECLSPEC) # define DLLIMPORT __declspec(dllimport) # define DLLEXPORT __declspec(dllexport) # define TCL_EXTERN(RTYPE) TCL_EXTERNC TCL_STORAGE_CLASS RTYPE # elif defined(__BORLANDC__) # define DLLIMPORT __import # define DLLEXPORT __export /* Pre-5.5 Borland requires the attributes be placed after the */ /* return type instead. */ # define TCL_EXTERN(RTYPE) TCL_EXTERNC RTYPE TCL_STORAGE_CLASS # else # define DLLIMPORT # define DLLEXPORT # define TCL_EXTERN(RTYPE) TCL_EXTERNC TCL_STORAGE_CLASS RTYPE # endif #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; /* * Include the public function declarations that are accessible via * the stubs table. */ #include "itclDecls.h" /* * Itcl_InitStubs is used by extensions like Itk that can be linked * against the itcl stubs library. If we are not using stubs * then this reduces to package require. */ #ifdef USE_ITCL_STUBS TCL_EXTERNC CONST char * Itcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp, CONST char *version, int exact)); #else #define Itcl_InitStubs(interp, version, exact) \ Tcl_PkgRequire(interp, "Itcl", version, exact) #endif /* * Public functions that are not accessible via the stubs table. */ #endif /* RC_INVOKED */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* ITCL_H */ itcl3.4.1/generic/itclStubLib.c0000644003604700454610000000361711610103534014774 0ustar dgp891div/* * itclStubLib.c -- * * Stub object that will be statically linked into extensions that wish * to access Itcl. * * Copyright (c) 1998 Paul Duffin. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * We need to ensure that we use the stub macros so that this file contains * no references to any of the stub functions. This will make it possible * to build an extension that references Tcl_InitStubs but doesn't end up * including the rest of the stub functions. */ #ifndef USE_TCL_STUBS #define USE_TCL_STUBS #endif #undef USE_TCL_STUB_PROCS /* * This ensures that the Itcl_InitStubs has a prototype in * itcl.h and is not the macro that turns it into Tcl_PkgRequire */ #ifndef USE_ITCL_STUBS #define USE_ITCL_STUBS #endif #include "itclInt.h" ItclStubs *itclStubsPtr; ItclIntStubs *itclIntStubsPtr; /* *---------------------------------------------------------------------- * * Itcl_InitStubs -- * * Tries to initialize the stub table pointers and ensures that * the correct version of Itcl is loaded. * * Results: * The actual version of Itcl that satisfies the request, or * NULL to indicate that an error occurred. * * Side effects: * Sets the stub table pointers. * *---------------------------------------------------------------------- */ #ifdef Itcl_InitStubs #undef Itcl_InitStubs #endif CONST char * Itcl_InitStubs (interp, version, exact) Tcl_Interp *interp; CONST char *version; int exact; { CONST char *actualVersion; actualVersion = Tcl_PkgRequireEx(interp, "Itcl", version, exact, (ClientData *) &itclStubsPtr); if (actualVersion == NULL) { itclStubsPtr = NULL; return NULL; } if (itclStubsPtr->hooks) { itclIntStubsPtr = itclStubsPtr->hooks->itclIntStubs; } else { itclIntStubsPtr = NULL; } return actualVersion; } itcl3.4.1/generic/itcl_linkage.c0000644003604700454610000002762211610066043015206 0ustar dgp891div/* * ------------------------------------------------------------------------ * 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 * ======================================================================== * 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 */ CONST 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 */ CONST 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 */ CONST 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); } itcl3.4.1/generic/itcl_parse.c0000644003604700454610000010251611610066043014702 0ustar dgp891div/* * ------------------------------------------------------------------------ * 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 * ======================================================================== * 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_AppendResult(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, len; char *className; Tcl_Namespace *parserNs; ItclClass *cdefnPtr; Itcl_CallFrame frame; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "name { definition }"); return TCL_ERROR; } className = Tcl_GetStringFromObj(objv[1], &len); if (len == 0) { Tcl_AppendResult(interp, "invalid class name \"\"", (char *) NULL); return TCL_ERROR; } /* * 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, (Tcl_CallFrame *) &frame, parserNs, /* isProcCallFrame */ 0); if (result == TCL_OK) { result = Tcl_EvalObj(interp, objv[2]); Tcl_PopCallFrame(interp); } Itcl_PopStack(&info->cdefnStack); if (result != TCL_OK) { char msg[256]; sprintf(msg, "\n (class \"%.200s\" body line %d)", className, Tcl_GetErrorLine(interp)); 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 = 1; char *token; Itcl_ListElem *elem, *elem2; ItclClass *cdPtr, *baseCdefnPtr, *badCdPtr; ItclHierIter hier; Itcl_Stack stack; Itcl_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_AppendResult(interp, cdPtr->name, " ", (char*)NULL); elem = Itcl_NextListElem(elem); } Tcl_AppendResult(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, (Tcl_CallFrame *) &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_GetString(*objv); 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_AppendResult(interp, "cannot inherit from \"", token, "\"", (char*)NULL); if (errlen > 0) { Tcl_AppendResult(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_AppendResult(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_AppendResult(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) { badCdPtr = cdPtr; Tcl_AppendResult(interp, "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_AppendResult(interp, "\n ", (char *) NULL); for (i=0; i < Itcl_GetStackSize(&stack); i++) { if (Itcl_GetStackValue(&stack, i) == NULL) { cdPtr = (ItclClass*)Itcl_GetStackValue(&stack, i-1); Tcl_AppendResult(interp, cdPtr->name, "->", (char*)NULL); } } Tcl_AppendResult(interp, badCdPtr->name, (char *) NULL); } 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) { result = Tcl_EvalObj(interp, objv[1]); } 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, Tcl_GetErrorLine(interp)); 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_AppendResult(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_GetString(objv[1]); if (objc == 3) { body = Tcl_GetString(objv[2]); } else { cdefnPtr->initCode = Tcl_DuplicateObj(objv[2]); Tcl_IncrRefCount(cdefnPtr->initCode); body = Tcl_GetString(objv[3]); } 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_AppendResult(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_AppendResult(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; 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_AppendResult(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; varPtr = ItclVarHashCreateVar(&nsPtr->varTable, vdefn->member->name, &newEntry); #if ITCL_TCL_PRE_8_5 if (newEntry && itclOldRuntime) { varPtr->nsPtr = nsPtr; } #endif TclSetVarNamespaceVar(varPtr); ItclVarRefCount(varPtr)++; /* another use by class */ /* * 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) { CONST char *val = Tcl_SetVar(interp, vdefn->member->name, init, TCL_NAMESPACE_ONLY); if (!val) { Tcl_AppendResult(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 */ CONST 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_AppendResult(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); } itcl3.4.1/generic/itcl_util.c0000644003604700454610000012664311610103534014551 0ustar dgp891div/* * ------------------------------------------------------------------------ * 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 * ======================================================================== * 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" /* * 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; TCL_DECLARE_MUTEX(ItclPreservedListLock) /* * 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. * ------------------------------------------------------------------------ */ void Itcl_Assert(testExpr, fileName, lineNumber) CONST char *testExpr; /* string representing test expression */ CONST char *fileName; /* file name containing this call */ int lineNumber; /* line number containing this call */ { Tcl_Panic("Itcl Assertion failed: \"%s\" (line %d of %s)", testExpr, lineNumber, fileName); } /* * ------------------------------------------------------------------------ * 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 */ { assert(elemPtr != NULL); assert(elemPtr->owner != NULL); assert(elemPtr->owner->validate == ITCL_VALID_LIST); 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. */ Tcl_MutexLock(&ItclPreservedListLock); 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 */ Tcl_MutexUnlock(&ItclPreservedListLock); (*chunk->fproc)((char*)chunk->data); Tcl_MutexLock(&ItclPreservedListLock); Tcl_DeleteHashEntry(entry); ckfree((char*)chunk); } Tcl_MutexUnlock(&ItclPreservedListLock); } /* * ------------------------------------------------------------------------ * 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. */ Tcl_MutexLock(&ItclPreservedListLock); 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++; } Tcl_MutexUnlock(&ItclPreservedListLock); } /* * ------------------------------------------------------------------------ * 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; Tcl_MutexLock(&ItclPreservedListLock); if (ItclPreservedList) { entry = Tcl_FindHashEntry(ItclPreservedList,(char*)cdata); } if (!entry) { Tcl_MutexUnlock(&ItclPreservedListLock); Tcl_Panic("Itcl_ReleaseData can't find reference for 0x%p", 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 */ Tcl_MutexUnlock(&ItclPreservedListLock); (*chunk->fproc)((char*)chunk->data); Tcl_MutexLock(&ItclPreservedListLock); } Tcl_DeleteHashEntry(entry); ckfree((char*)chunk); } Tcl_MutexUnlock(&ItclPreservedListLock); } /* * ------------------------------------------------------------------------ * 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; CONST char *val; /* * ERR_IN_PROGRESS was replaced by new APIs in 8.5a2. Call them if they * are available, or somehow magic them in from the stubs table. * Tcl_ChannelThreadActionProc is a stubs slot higher than the APIs we * need, so its existence indicates slot-y goodness. */ #ifndef ERR_IN_PROGRESS return (Itcl_InterpState) Tcl_SaveInterpState(interp, status); #elif defined(USE_TCL_STUBS) && defined(Tcl_ChannelThreadActionProc) if (itclCompatFlags & ITCL_COMPAT_USE_ISTATE_API) { Itcl_InterpState (*tcl_SaveInterpState)(Tcl_Interp *, int) = (Itcl_InterpState (*)(Tcl_Interp *, int)) tclStubsPtr->reserved535; return (*tcl_SaveInterpState)(interp, status); } #endif 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. */ #ifdef ERR_IN_PROGRESS /* this disappeared in 8.5a2 */ if ((iPtr->flags & ERR_IN_PROGRESS) != 0) { #else if (iPtr->errorInfo != NULL) { #endif 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 */ { InterpState *info = (InterpState*)state; int status; /* * ERR_IN_PROGRESS was replaced by new APIs in 8.5a2. Call them if they * are available, or somehow magic them in from the stubs table. * Tcl_ChannelThreadActionProc is a stubs slot higher than the APIs we * need, so its existence indicates slot-y goodness. */ #ifndef ERR_IN_PROGRESS return Tcl_RestoreInterpState(interp, (Tcl_InterpState)state); #elif defined(USE_TCL_STUBS) && defined(Tcl_ChannelThreadActionProc) if (itclCompatFlags & ITCL_COMPAT_USE_ISTATE_API) { int (*tcl_RestoreInterpState)() = (int (*)()) tclStubsPtr->reserved536; return (*tcl_RestoreInterpState)(interp, state); } #endif if (info->validate != TCL_STATE_VALID) { Tcl_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) { Tcl_SetObjErrorCode(interp, Tcl_NewStringObj(info->errorCode, -1)); 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; /* * ERR_IN_PROGRESS was replaced by new APIs in 8.5a2. Call them if they * are available, or somehow magic them in from the stubs table. * Tcl_ChannelThreadActionProc is a stubs slot higher than the APIs we * need, so its existence indicates slot-y goodness. */ #ifndef ERR_IN_PROGRESS Tcl_DiscardInterpState((Tcl_InterpState)state); return; #elif defined(USE_TCL_STUBS) && defined(Tcl_ChannelThreadActionProc) if (itclCompatFlags & ITCL_COMPAT_USE_ISTATE_API) { void (* tcl_DiscardInterpState)() = (void (*)()) tclStubsPtr->reserved537; (*tcl_DiscardInterpState)(state); return; } #endif if (info->validate != TCL_STATE_VALID) { Tcl_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; Itcl_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 = (Itcl_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) CONST 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, *newname; 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); newname = Tcl_DStringValue(buffer); for (sep=newname; *sep != '\0'; sep++) ; while (--sep > newname) { 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 > newname) { *tail = sep+1; while (sep > newname && *(sep-1) == ':') { sep--; } *sep = '\0'; *head = newname; } /* * No :: separators--the whole name is treated as a tail. */ else { *tail = newname; *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 */ CONST 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; int len = strlen(name); CONST char *pos; int listc, result; CONST char **listv; cmdName = ckalloc((unsigned)strlen(name)+1); strcpy(cmdName, name); 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_AppendResult(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 { ckfree(cmdName); 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_AppendResult(interp, "invalid command name \"", Tcl_GetStringFromObj(objv[0], NULL), "\"", NULL); return TCL_ERROR; } cmdPtr = (Command*)cmd; cmdlinePtr = Itcl_CreateArgs(interp, "unknown", objc, objv); Tcl_ListObjGetElements(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 */ CONST 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; } itcl3.4.1/generic/itcl_objects.c0000644003604700454610000012007411610103534015215 0ustar dgp891div/* * ------------------------------------------------------------------------ * 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 * ======================================================================== * 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, CONST char *name1, CONST 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 */ CONST 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. Be careful to look for the object * only in the current namespace context. Otherwise, we might * find a global command, but that wouldn't be clobbered! */ cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace*)NULL, TCL_NAMESPACE_ONLY); if (cmd != NULL && !Itcl_IsStub(cmd)) { Tcl_AppendResult(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_AppendResult(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", 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); /* Bug 227824. * The constructor may destroy the object, possibly indirectly * through the destruction of the main widget in the iTk * megawidget it tried to construct. If this happens we must * not try to destroy the access command a second time. */ if (newObj->accessCmd != (Tcl_Command) 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_AppendResult(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->fullname)) { 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 */ CONST 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; } 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; ItclCallFrame *framePtr; if (objc < 2) { Tcl_AppendResult(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_AppendResult(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 = (ItclCallFrame *) &context.frame; Itcl_PushStack((ClientData)framePtr, &info->transparentFrames); /* Bug 227824 * The tcl core will blow up in 'TclLookupVar' if we don't reset * the 'isProcCallFrame'. This happens because without the * callframe refered to by 'framePtr' will be inconsistent * ('isProcCallFrame' set, but 'procPtr' not set). */ if (*token == 'i' && strcmp(token,"info") == 0) { framePtr->isProcCallFrame = 0; } 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. * ------------------------------------------------------------------------ */ CONST char* Itcl_GetInstanceVar(interp, name, contextObj, contextClass) Tcl_Interp *interp; /* current interpreter */ CONST char *name; /* name of desired instance variable */ ItclObject *contextObj; /* current object */ ItclClass *contextClass; /* name is interpreted in this scope */ { ItclContext context; CONST char *val; /* * Make sure that the current namespace context includes an * object that is being manipulated. */ if (contextObj == NULL) { Tcl_ResetResult(interp); Tcl_SetResult(interp, "cannot access object-specific info without an object context", TCL_STATIC); 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 */ CONST char *name1; /* variable name */ CONST 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_GetString(objPtr); 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(); #if ITCL_TCL_PRE_8_5 if (itclOldRuntime) { 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; ItclVarRefCount(varPtr) = 1; /* protect from being deleted */ } #endif /* * 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 */ CONST 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; CONST 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_AppendResult(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_AppendResult(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_AppendResult(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; } itcl3.4.1/generic/itcl.decls0000644003604700454610000000622611610066043014361 0ustar dgp891div# itcl.decls -- # # This file contains the declarations for all supported public # functions that are exported by the Itcl library via the stubs table. # This file is used to generate the itclDecls.h, itclPlatDecls.h, # itclStub.c, and itclPlatStub.c files. # # # Copyright (c) 1998-1999 by Scriptics Corporation. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. library itcl # Define the itcl interface with several sub interfaces: # itclPlat - platform specific public # itclInt - generic private # itclPlatInt - platform specific private interface itcl hooks {itclInt} # Declare each of the functions in the public Tcl interface. Note that # the an index should never be reused for a different function in order # to preserve backwards compatibility. declare 0 generic { int Itcl_Init(Tcl_Interp *interp) } declare 1 generic { int Itcl_SafeInit(Tcl_Interp *interp) } declare 2 generic { int Itcl_RegisterC(Tcl_Interp *interp, CONST char *name, \ Tcl_CmdProc *proc, ClientData clientData, \ Tcl_CmdDeleteProc *deleteProc) } declare 3 generic { int Itcl_RegisterObjC (Tcl_Interp *interp, CONST char *name, \ Tcl_ObjCmdProc *proc, ClientData clientData, \ Tcl_CmdDeleteProc *deleteProc) } declare 4 generic { int Itcl_FindC(Tcl_Interp *interp, CONST char *name, \ Tcl_CmdProc **argProcPtr, Tcl_ObjCmdProc **objProcPtr, \ ClientData *cDataPtr) } declare 5 generic { void Itcl_InitStack(Itcl_Stack *stack) } declare 6 generic { void Itcl_DeleteStack(Itcl_Stack *stack) } declare 7 generic { void Itcl_PushStack(ClientData cdata, Itcl_Stack *stack) } declare 8 generic { ClientData Itcl_PopStack(Itcl_Stack *stack) } declare 9 generic { ClientData Itcl_PeekStack(Itcl_Stack *stack) } declare 10 generic { ClientData Itcl_GetStackValue(Itcl_Stack *stack, int pos) } declare 11 generic { void Itcl_InitList(Itcl_List *listPtr) } declare 12 generic { void Itcl_DeleteList(Itcl_List *listPtr) } declare 13 generic { Itcl_ListElem* Itcl_CreateListElem(Itcl_List *listPtr) } declare 14 generic { Itcl_ListElem* Itcl_DeleteListElem(Itcl_ListElem *elemPtr) } declare 15 generic { Itcl_ListElem* Itcl_InsertList(Itcl_List *listPtr, ClientData val) } declare 16 generic { Itcl_ListElem* Itcl_InsertListElem (Itcl_ListElem *pos, ClientData val) } declare 17 generic { Itcl_ListElem* Itcl_AppendList(Itcl_List *listPtr, ClientData val) } declare 18 generic { Itcl_ListElem* Itcl_AppendListElem(Itcl_ListElem *pos, ClientData val) } declare 19 generic { void Itcl_SetListValue(Itcl_ListElem *elemPtr, ClientData val) } declare 20 generic { void Itcl_EventuallyFree(ClientData cdata, Tcl_FreeProc *fproc) } declare 21 generic { void Itcl_PreserveData(ClientData cdata) } declare 22 generic { void Itcl_ReleaseData(ClientData cdata) } declare 23 generic { Itcl_InterpState Itcl_SaveInterpState(Tcl_Interp* interp, int status) } declare 24 generic { int Itcl_RestoreInterpState(Tcl_Interp* interp, Itcl_InterpState state) } declare 25 generic { void Itcl_DiscardInterpState(Itcl_InterpState state) } itcl3.4.1/generic/itcl_migrate.c0000644003604700454610000001174611610066043015224 0ustar dgp891div/* * ------------------------------------------------------------------------ * 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 * ======================================================================== * 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. * *---------------------------------------------------------------------- */ Itcl_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) { Tcl_Panic("itcl: _Tcl_GetCallFrame called with bad number of levels"); } framePtr = iPtr->varFramePtr; while (framePtr && level > 0) { framePtr = framePtr->callerVarPtr; level--; } return (Itcl_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. * *---------------------------------------------------------------------- */ Itcl_CallFrame* _Tcl_ActivateCallFrame(interp, framePtr) Tcl_Interp *interp; /* interpreter being queried */ Itcl_CallFrame *framePtr; /* call frame to be activated */ { Interp *iPtr = (Interp*)interp; CallFrame *oldFramePtr; oldFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = (CallFrame *) framePtr; return (Itcl_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() { Var *varPtr; varPtr = (Var *) ckalloc(itclVarLocalSize); ItclInitVarFlags(varPtr); ItclVarObjValue(varPtr) = NULL; #if ITCL_TCL_PRE_8_5 if (itclOldRuntime) { varPtr->name = NULL; varPtr->nsPtr = NULL; varPtr->hPtr = NULL; varPtr->refCount = 0; varPtr->tracePtr = NULL; varPtr->searchPtr = NULL; } #endif return varPtr; } #if ITCL_TCL_PRE_8_5 Var * ItclVarHashCreateVar( TclVarHashTable *tablePtr, const char *key, int *newPtr) { #if (USE_TCL_STUBS) if (itclOldRuntime) { #endif Tcl_HashEntry *hPtr; if (newPtr) { Var *varPtr = _TclNewVar(); hPtr = Tcl_CreateHashEntry(tablePtr, key, newPtr); varPtr->hPtr = hPtr; Tcl_SetHashValue(hPtr, varPtr); } else { hPtr = Tcl_FindHashEntry(tablePtr, key); } if (hPtr) { return (Var *) Tcl_GetHashValue(hPtr); } else { return NULL; } #if (USE_TCL_STUBS) } else { /* * An 8.5 runtime: TclVarHashCreateVar is at position 234 in the * internal stubs table: call it. */ Var * (*TclVarHashCreateVar)(Tcl_HashTable *, const char *, int *) = (Var * (*)(Tcl_HashTable *, const char *, int *)) *((&tclIntStubsPtr->reserved0)+234); return (*TclVarHashCreateVar)(tablePtr, key, newPtr); } #endif } #endif itcl3.4.1/generic/itcl_class.c0000644003604700454610000016577211610103534014707 0ustar dgp891div/* * ------------------------------------------------------------------------ * 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 * ======================================================================== * 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)); extern int itclCompatFlags; /* * ------------------------------------------------------------------------ * 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 */ CONST 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_AppendResult(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_AppendResult(interp, "command \"", path, "\" already exists", (char*)NULL); if (strstr(path,"::") == NULL) { Tcl_AppendResult(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_AppendResult(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, (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver, (Tcl_ResolveVarProc*)Itcl_ClassVarResolver, (Tcl_ResolveCompiledVarProc*)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; } /* * Fix 227804: Whenever an object to delete was found we * have to reset the search to the beginning as the * current entry in the search was deleted and accessing it * is therefore not allowed anymore. */ entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place); continue; } 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); Tcl_DeleteNamespace(cdPtr->namesp); /* As the first namespace is now destroyed we have to get the * new first element of the hash table. We cannot go to the * next element from the current one, because the current one * is deleted. itcl Patch #593112, for Bug #577719. */ elem = Itcl_FirstListElem(&cdefnPtr->derived); } /* * 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); /* * Fix 227804: Whenever an object to delete was found we * have to reset the search to the beginning as the * current entry in the search was deleted and accessing it * is therefore not allowed anymore. */ entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place); continue; } 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; Itcl_ListElem *elem; Tcl_HashSearch place; Tcl_HashEntry *entry; ItclVarDefn *vdefn; ItclVarLookup *vlookup; VarInHash *varPtr; /* * 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. */ 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 = (VarInHash*)vlookup->var.common; if (--ItclVarRefCount(varPtr) == 0) { /* * This is called after the namespace is already gone: the * variable is already unset and ready to be freed. */ ckfree((char *)varPtr); } } ckfree((char*)vlookup); } entry = Tcl_NextHashEntry(&place); } 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 */ CONST char* path; /* path name for class */ int autoload; /* should class be loaded */ { 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 */ CONST 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; Tcl_DString buffer; /* buffer used to build object names */ char *token, *objName, *match; ItclObject *newObj; Itcl_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, (Tcl_CallFrame *) &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_AppendResult(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 = token; match = strstr(token, "#auto"); if (match != NULL) { int len; char unique[TCL_INTEGER_SPACE]; /* for unique part of object names */ Tcl_CmdInfo dummy; Tcl_UniChar ch; Tcl_DStringAppend(&buffer, token, (match - token)); /* * Only lowercase the first char of $class, per itcl #auto semantics */ len = Tcl_UtfToUniChar(cdefnPtr->name, &ch); ch = Tcl_UniCharToLower(ch); Tcl_UniCharToUtfDString(&ch, 1, &buffer); Tcl_DStringAppend(&buffer, cdefnPtr->name + len, -1); /* * Substitute a unique part in for "#auto", and keep * incrementing a counter until a valid name is found. */ len = Tcl_DStringLength(&buffer); do { sprintf(unique, "%d", cdefnPtr->unique++); Tcl_DStringTrunc(&buffer, len); Tcl_DStringAppend(&buffer, unique, -1); Tcl_DStringAppend(&buffer, match+5, -1); objName = Tcl_DStringValue(&buffer); /* * [Fix 227811] Check for any command with the given name, not * only objects. */ if (Tcl_GetCommandInfo (interp, objName, &dummy) == 0) { break; /* if an error is found, bail out! */ } } while (1); } /* * 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_SetObjResult(interp, Tcl_NewStringObj(objName, -1)); } 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 */ CONST 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_AppendResult(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->flags & CMD_IS_DELETED) { mfunc->accessCmd = NULL; if ((flags & TCL_LEAVE_ERR_MSG) != 0) { Tcl_AppendResult(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 */ CONST 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 */ { Interp *iPtr = (Interp *) interp; ItclCallFrame *varFramePtr = (ItclCallFrame *) iPtr->varFramePtr; ItclClass *cdefn = (ItclClass*)context->clientData; ItclObject *contextObj; Itcl_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 this is a formal parameter in the current proc scope. * If so, that variable has precedence. Look it up and return * it here. This duplicates some of the functionality of * TclLookupVar, but we return it here (instead of returning * TCL_CONTINUE) to avoid looking it up again later. */ if (varFramePtr && varFramePtr->isProcCallFrame && strstr(name,"::") == NULL) { Proc *procPtr = varFramePtr->procPtr; /* * Search through compiled locals first... */ if (procPtr) { int localCt = procPtr->numCompiledLocals; CompiledLocal *localPtr = procPtr->firstLocalPtr; Var *localVarPtr = varFramePtr->compiledLocals; int nameLen = strlen(name); int i; for (i=0; i < localCt; i++) { if (!TclIsVarTemporary(localPtr)) { register char *localName = localPtr->name; if ((name[0] == localName[0]) && (nameLen == localPtr->nameLength) && (strcmp(name, localName) == 0)) { *rPtr = (Tcl_Var)localVarPtr; return TCL_OK; } } ItclNextLocal(localVarPtr); localPtr = localPtr->nextPtr; } } /* * If it's not a compiled local, then look in the frame's * var hash table next. This variable may have been * created on the fly. */ if (varFramePtr->varTablePtr != NULL) { *rPtr = (Tcl_Var) ItclVarHashFindVar(varFramePtr->varTablePtr, name); if (*rPtr) { return TCL_OK; } } } /* * 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 */ CONST 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; Itcl_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; 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; vlookup->var.common = (Tcl_Var) ItclVarHashFindVar(&nsPtr->varTable, vdefn->member->name); assert(vlookup->var.common != NULL); } 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_AppendResult(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, (Tcl_FreeProc*) 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. * ------------------------------------------------------------------------ */ CONST char* Itcl_GetCommonVar(interp, name, contextClass) Tcl_Interp *interp; /* current interpreter */ CONST char *name; /* name of desired instance variable */ ItclClass *contextClass; /* name is interpreted in this scope */ { CONST char *val = NULL; int result; Itcl_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, (Tcl_CallFrame *) &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 */ CONST 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; } itcl3.4.1/generic/itclInt.h0000644003604700454610000003770611610103534014175 0ustar dgp891div/* * ------------------------------------------------------------------------ * 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 * ======================================================================== * 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 "tclInt.h" #include "itcl.h" #ifdef BUILD_itcl # undef TCL_STORAGE_CLASS # define TCL_STORAGE_CLASS DLLEXPORT #endif /* * Handle hiding of errorLine in 8.6 */ #if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6) #define Tcl_GetErrorLine(interp) ((interp)->errorLine) #endif #define ITCL_TCL_PRE_8_5 (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 5) #define ItclCallFrame CallFrame #if !ITCL_TCL_PRE_8_5 #define Itcl_CallFrame Tcl_CallFrame #if defined(USE_TCL_STUBS) /* * Fix Tcl bug #803489 the right way. We need to always use the old Stub * slot positions, not the new broken ones part of TIP 127. I do like * that these functions have moved to the public space (about time), but * the slot change is the killer and is the painful side affect. */ # undef Tcl_CreateNamespace # define Tcl_CreateNamespace \ (tclIntStubsPtr->tcl_CreateNamespace) # undef Tcl_DeleteNamespace # define Tcl_DeleteNamespace \ (tclIntStubsPtr->tcl_DeleteNamespace) # undef Tcl_AppendExportList # define Tcl_AppendExportList \ (tclIntStubsPtr->tcl_AppendExportList) # undef Tcl_Export # define Tcl_Export \ (tclIntStubsPtr->tcl_Export) # undef Tcl_Import # define Tcl_Import \ (tclIntStubsPtr->tcl_Import) # undef Tcl_ForgetImport # define Tcl_ForgetImport \ (tclIntStubsPtr->tcl_ForgetImport) # undef Tcl_GetCurrentNamespace # define Tcl_GetCurrentNamespace \ (tclIntStubsPtr->tcl_GetCurrentNamespace) # undef Tcl_GetGlobalNamespace # define Tcl_GetGlobalNamespace \ (tclIntStubsPtr->tcl_GetGlobalNamespace) # undef Tcl_FindNamespace # define Tcl_FindNamespace \ (tclIntStubsPtr->tcl_FindNamespace) # undef Tcl_FindCommand # define Tcl_FindCommand \ (tclIntStubsPtr->tcl_FindCommand) # undef Tcl_GetCommandFromObj # define Tcl_GetCommandFromObj \ (tclIntStubsPtr->tcl_GetCommandFromObj) # undef Tcl_GetCommandFullName # define Tcl_GetCommandFullName \ (tclIntStubsPtr->tcl_GetCommandFullName) #endif /* use stubs */ #define ItclInitVarFlags(varPtr) \ (varPtr)->flags = 0 #define ItclInitVarArgument(varPtr) \ (varPtr)->flags = VAR_ARGUMENT #define ItclVarHashCreateVar(tablePtr, key, newPtr) \ TclVarHashCreateVar((tablePtr), (key), (newPtr)) #define ItclVarRefCount(varPtr) VarHashRefCount(varPtr) #define ItclClearVarUndefined(varPtr) #define ItclNextLocal(varPtr) ((varPtr)++) #define ItclVarObjValue(varPtr) ((varPtr)->value.objPtr) #define itclVarInHashSize sizeof(VarInHash) #define itclVarLocalSize sizeof(Var) #else /* Compiling on Tcl8.x, x<5 */ typedef struct Itcl_CallFrame { Tcl_Namespace *nsPtr; int dummy1; int dummy2; void *dummy3; void *dummy4; void *dummy5; int dummy6; void *dummy7; void *dummy8; int dummy9; void *dummy10; void *dummy11; void *dummy12; void *dummy13; } Itcl_CallFrame; /* * Definition of runtime behaviour to be able to run irrespective of the Tcl * version. */ #define VarInHash Var #define TclVarHashTable Tcl_HashTable typedef struct ItclShortVar { int flags; union { Tcl_Obj *objPtr; TclVarHashTable *tablePtr; struct Var *linkPtr; } value; } ItclShortVar; typedef struct ItclVarInHash { ItclShortVar var; int refCount; Tcl_HashEntry entry; } ItclVarInHash; #define ItclOffset(type, field) ((int) ((char *) &((type *) 0)->field)) #define itclOldRuntime (itclVarFlagOffset!=0) extern int itclVarFlagOffset; extern int itclVarRefCountOffset; extern int itclVarInHashSize; extern int itclVarLocalSize; extern int itclVarValueOffset; /* * VarReform related macros: provide access to the Var fields with offsets * determined at load time, so that the same code copes with the different * structs in Tcl8.5 and previous Tcl. */ #define ItclNextLocal(varPtr) \ ((varPtr) = (Var *) (((char *)(varPtr))+itclVarLocalSize)) #define ItclVarObjValue(varPtr) \ (*((Tcl_Obj **) (((char *)(varPtr))+itclVarValueOffset))) #define ItclVarRefCount(varPtr) \ (*((int *) (((char *)(varPtr))+itclVarRefCountOffset))) #define ItclVarFlags(varPtr) \ (*((int *)(((char *)(varPtr))+itclVarFlagOffset))) /* Note that itclVarFlagOffset==0 exactly when we are running in Tcl8.5 */ #define ItclInitVarFlags(varPtr) \ if (itclOldRuntime) { \ (varPtr)->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE);\ } else { \ ((ItclShortVar *)(varPtr))->flags = 0;\ } /* This is used for CompiledLocal, not for Var & Co. That struct did not * change, but the correct flag init did! The flags bits themselves are * unchanged */ #define ItclInitVarArgument(varPtr) \ if (itclOldRuntime) { \ (varPtr)->flags = (VAR_SCALAR | VAR_ARGUMENT);\ } else { \ (varPtr)->flags = VAR_ARGUMENT;\ } #define TclIsVarNamespaceVar(varPtr) \ (ItclVarFlags(varPtr) & VAR_NAMESPACE_VAR) #define TclSetVarNamespaceVar(varPtr) \ if (!TclIsVarNamespaceVar(varPtr)) {\ ItclVarFlags(varPtr) |= VAR_NAMESPACE_VAR;\ ItclVarRefCount(varPtr)++;\ } #define ItclClearVarUndefined(varPtr) \ if (itclOldRuntime) { \ ItclVarFlags(varPtr) &= ~VAR_UNDEFINED;\ } #ifndef MODULE_SCOPE #define MODULE_SCOPE #endif MODULE_SCOPE Var * ItclVarHashCreateVar (TclVarHashTable * tablePtr, const char * key, int * newPtr); #endif /* Version dependent defs and macros */ #define ItclVarHashFindVar(tablePtr, key) \ ItclVarHashCreateVar((tablePtr), (key), NULL) /* * 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; #define Itcl_IsMemberCodeImplemented(mcode) \ (((mcode)->flags & ITCL_IMPLEMENT_NONE) == 0) /* * 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 */ Itcl_CallFrame frame; /* call frame for object context */ Var *compiledLocals; /* points to storage for compiled locals */ Var localStorage[20]; /* default storage for compiled locals */ } ItclContext; /* * Compatibility flags. Used to support small "hacks". These are stored * in the global variable named itclCompatFlags. */ extern int itclCompatFlags; #define ITCL_COMPAT_USE_ISTATE_API 0x2 /* Tcl 8.5a2 added interp state APIs */ #include "itclIntDecls.h" /* * 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 #ifndef DEBUG #define assert(EX) ((void)0) #else #define assert(EX) (void)((EX) || (Itcl_Assert(STRINGIFY(EX), __FILE__, __LINE__), 0)) #endif /* DEBUG */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* ITCLINT_H */ itcl3.4.1/generic/itcl_methods.c0000644003604700454610000024644711610103534015244 0ustar dgp891div/* * ------------------------------------------------------------------------ * 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 commands available within a class scope. * In [incr Tcl], the term "method" is used for a procedure that has * access to object-specific data, while the term "proc" is used for * a procedure that has access only to common class data. * * ======================================================================== * AUTHOR: Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * http://www.tcltk.com/itcl * ======================================================================== * 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 ItclParseConfig _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], ItclObject *contextObj, int *rargc, ItclVarDefn ***rvars, char ***rvals)); static int ItclHandleConfig _ANSI_ARGS_((Tcl_Interp *interp, int argc, ItclVarDefn **vars, char **vals, ItclObject *contextObj)); /* * ------------------------------------------------------------------------ * Itcl_BodyCmd() * * Invoked by Tcl whenever the user issues an "itcl::body" command to * define or redefine the implementation for a class method/proc. * Handles the following syntax: * * itcl::body :: * * Looks for an existing class member function with the name , * and if found, tries to assign the implementation. If an argument * list was specified in the original declaration, it must match * or an error is flagged. If has the form "@name" * then it is treated as a reference to a C handling procedure; * otherwise, it is taken as a body of Tcl statements. * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_BodyCmd(dummy, interp, objc, objv) ClientData dummy; /* unused */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { int status = TCL_OK; char *head, *tail, *token, *arglist, *body; ItclClass *cdefn; ItclMemberFunc *mfunc; Tcl_HashEntry *entry; Tcl_DString buffer; if (objc != 4) { token = Tcl_GetStringFromObj(objv[0], (int*)NULL); Tcl_AppendResult(interp, "wrong # args: should be \"", token, " class::func arglist body\"", (char*)NULL); return TCL_ERROR; } /* * Parse the member name "namesp::namesp::class::func". * Make sure that a class name was specified, and that the * class exists. */ token = Tcl_GetStringFromObj(objv[1], (int*)NULL); Itcl_ParseNamespPath(token, &buffer, &head, &tail); if (!head || *head == '\0') { Tcl_AppendResult(interp, "missing class specifier for body declaration \"", token, "\"", (char*)NULL); status = TCL_ERROR; goto bodyCmdDone; } cdefn = Itcl_FindClass(interp, head, /* autoload */ 1); if (cdefn == NULL) { status = TCL_ERROR; goto bodyCmdDone; } /* * Find the function and try to change its implementation. * Note that command resolution table contains *all* functions, * even those in a base class. Make sure that the class * containing the method definition is the requested class. */ mfunc = NULL; entry = Tcl_FindHashEntry(&cdefn->resolveCmds, tail); if (entry) { mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); if (mfunc->member->classDefn != cdefn) { mfunc = NULL; } } if (mfunc == NULL) { Tcl_AppendResult(interp, "function \"", tail, "\" is not defined in class \"", cdefn->fullname, "\"", (char*)NULL); status = TCL_ERROR; goto bodyCmdDone; } arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL); body = Tcl_GetStringFromObj(objv[3], (int*)NULL); if (Itcl_ChangeMemberFunc(interp, mfunc, arglist, body) != TCL_OK) { status = TCL_ERROR; goto bodyCmdDone; } bodyCmdDone: Tcl_DStringFree(&buffer); return status; } /* * ------------------------------------------------------------------------ * Itcl_ConfigBodyCmd() * * Invoked by Tcl whenever the user issues an "itcl::configbody" command * to define or redefine the configuration code associated with a * public variable. Handles the following syntax: * * itcl::configbody :: * * Looks for an existing public variable with the name , * and if found, tries to assign the implementation. If has * the form "@name" then it is treated as a reference to a C handling * procedure; otherwise, it is taken as a body of Tcl statements. * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_ConfigBodyCmd(dummy, interp, objc, objv) ClientData dummy; /* unused */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { int status = TCL_OK; char *head, *tail, *token; Tcl_DString buffer; ItclClass *cdefn; ItclVarLookup *vlookup; ItclMember *member; ItclMemberCode *mcode; Tcl_HashEntry *entry; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "class::option body"); return TCL_ERROR; } /* * Parse the member name "namesp::namesp::class::option". * Make sure that a class name was specified, and that the * class exists. */ token = Tcl_GetStringFromObj(objv[1], (int*)NULL); Itcl_ParseNamespPath(token, &buffer, &head, &tail); if (!head || *head == '\0') { Tcl_AppendResult(interp, "missing class specifier for body declaration \"", token, "\"", (char*)NULL); status = TCL_ERROR; goto configBodyCmdDone; } cdefn = Itcl_FindClass(interp, head, /* autoload */ 1); if (cdefn == NULL) { status = TCL_ERROR; goto configBodyCmdDone; } /* * Find the variable and change its implementation. * Note that variable resolution table has *all* variables, * even those in a base class. Make sure that the class * containing the variable definition is the requested class. */ vlookup = NULL; entry = Tcl_FindHashEntry(&cdefn->resolveVars, tail); if (entry) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); if (vlookup->vdefn->member->classDefn != cdefn) { vlookup = NULL; } } if (vlookup == NULL) { Tcl_AppendResult(interp, "option \"", tail, "\" is not defined in class \"", cdefn->fullname, "\"", (char*)NULL); status = TCL_ERROR; goto configBodyCmdDone; } member = vlookup->vdefn->member; if (member->protection != ITCL_PUBLIC) { Tcl_AppendResult(interp, "option \"", member->fullname, "\" is not a public configuration option", (char*)NULL); status = TCL_ERROR; goto configBodyCmdDone; } token = Tcl_GetStringFromObj(objv[2], (int*)NULL); if (Itcl_CreateMemberCode(interp, cdefn, (char*)NULL, token, &mcode) != TCL_OK) { status = TCL_ERROR; goto configBodyCmdDone; } Itcl_PreserveData((ClientData)mcode); Itcl_EventuallyFree((ClientData)mcode, (Tcl_FreeProc*) Itcl_DeleteMemberCode); if (member->code) { Itcl_ReleaseData((ClientData)member->code); } member->code = mcode; configBodyCmdDone: Tcl_DStringFree(&buffer); return status; } /* * ------------------------------------------------------------------------ * Itcl_CreateMethod() * * Installs a method into the namespace associated with a class. * If another command with the same name is already installed, then * it is overwritten. * * Returns TCL_OK on success, or TCL_ERROR (along with an error message * in the specified interp) if anything goes wrong. * ------------------------------------------------------------------------ */ int Itcl_CreateMethod(interp, cdefn, name, arglist, body) Tcl_Interp* interp; /* interpreter managing this action */ ItclClass *cdefn; /* class definition */ CONST char* name; /* name of new method */ CONST char* arglist; /* space-separated list of arg names */ CONST char* body; /* body of commands for the method */ { ItclMemberFunc *mfunc; Tcl_DString buffer; /* * Make sure that the method name does not contain anything * goofy like a "::" scope qualifier. */ if (strstr(name,"::")) { Tcl_AppendResult(interp, "bad method name \"", name, "\"", (char*)NULL); return TCL_ERROR; } /* * Create the method definition. */ if (Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, &mfunc) != TCL_OK) { return TCL_ERROR; } /* * Build a fully-qualified name for the method, and install * the command handler. */ Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, cdefn->namesp->fullName, -1); Tcl_DStringAppend(&buffer, "::", 2); Tcl_DStringAppend(&buffer, name, -1); name = Tcl_DStringValue(&buffer); Itcl_PreserveData((ClientData)mfunc); mfunc->accessCmd = Tcl_CreateObjCommand(interp, name, Itcl_ExecMethod, (ClientData)mfunc, Itcl_ReleaseData); Tcl_DStringFree(&buffer); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_CreateProc() * * Installs a class proc into the namespace associated with a class. * If another command with the same name is already installed, then * it is overwritten. Returns TCL_OK on success, or TCL_ERROR (along * with an error message in the specified interp) if anything goes * wrong. * ------------------------------------------------------------------------ */ int Itcl_CreateProc(interp, cdefn, name, arglist, body) Tcl_Interp* interp; /* interpreter managing this action */ ItclClass *cdefn; /* class definition */ CONST char* name; /* name of new proc */ CONST char* arglist; /* space-separated list of arg names */ CONST char* body; /* body of commands for the proc */ { ItclMemberFunc *mfunc; Tcl_DString buffer; /* * Make sure that the proc name does not contain anything * goofy like a "::" scope qualifier. */ if (strstr(name,"::")) { Tcl_AppendResult(interp, "bad proc name \"", name, "\"", (char*)NULL); return TCL_ERROR; } /* * Create the proc definition. */ if (Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, &mfunc) != TCL_OK) { return TCL_ERROR; } /* * Mark procs as "common". This distinguishes them from methods. */ mfunc->member->flags |= ITCL_COMMON; /* * Build a fully-qualified name for the proc, and install * the command handler. */ Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, cdefn->namesp->fullName, -1); Tcl_DStringAppend(&buffer, "::", 2); Tcl_DStringAppend(&buffer, name, -1); name = Tcl_DStringValue(&buffer); Itcl_PreserveData((ClientData)mfunc); mfunc->accessCmd = Tcl_CreateObjCommand(interp, name, Itcl_ExecProc, (ClientData)mfunc, Itcl_ReleaseData); Tcl_DStringFree(&buffer); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_CreateMemberFunc() * * Creates the data record representing a member function. This * includes the argument list and the body of the function. If the * body is of the form "@name", then it is treated as a label for * a C procedure registered by Itcl_RegisterC(). * * If any errors are encountered, this procedure returns TCL_ERROR * along with an error message in the interpreter. Otherwise, it * returns TCL_OK, and "mfuncPtr" returns a pointer to the new * member function. * ------------------------------------------------------------------------ */ int Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, mfuncPtr) Tcl_Interp* interp; /* interpreter managing this action */ ItclClass *cdefn; /* class definition */ CONST char* name; /* name of new member */ CONST char* arglist; /* space-separated list of arg names */ CONST char* body; /* body of commands for the method */ ItclMemberFunc** mfuncPtr; /* returns: pointer to new method defn */ { int newEntry; ItclMemberFunc *mfunc; ItclMemberCode *mcode; Tcl_HashEntry *entry; /* * Add the member function to the list of functions for * the class. Make sure that a member function with the * same name doesn't already exist. */ entry = Tcl_CreateHashEntry(&cdefn->functions, name, &newEntry); if (!newEntry) { Tcl_AppendResult(interp, "\"", name, "\" already defined in class \"", cdefn->fullname, "\"", (char*)NULL); return TCL_ERROR; } /* * Try to create the implementation for this command member. */ if (Itcl_CreateMemberCode(interp, cdefn, arglist, body, &mcode) != TCL_OK) { Tcl_DeleteHashEntry(entry); return TCL_ERROR; } Itcl_PreserveData((ClientData)mcode); Itcl_EventuallyFree((ClientData)mcode, (Tcl_FreeProc*) Itcl_DeleteMemberCode); /* * Allocate a member function definition and return. */ mfunc = (ItclMemberFunc*)ckalloc(sizeof(ItclMemberFunc)); mfunc->member = Itcl_CreateMember(interp, cdefn, name); mfunc->member->code = mcode; if (mfunc->member->protection == ITCL_DEFAULT_PROTECT) { mfunc->member->protection = ITCL_PUBLIC; } mfunc->arglist = NULL; mfunc->argcount = 0; mfunc->accessCmd = NULL; if (arglist) { mfunc->member->flags |= ITCL_ARG_SPEC; } if (mcode->arglist) { Itcl_CreateArgList(interp, arglist, &mfunc->argcount, &mfunc->arglist); } if (strcmp(name,"constructor") == 0) { mfunc->member->flags |= ITCL_CONSTRUCTOR; } if (strcmp(name,"destructor") == 0) { mfunc->member->flags |= ITCL_DESTRUCTOR; } Tcl_SetHashValue(entry, (ClientData)mfunc); Itcl_PreserveData((ClientData)mfunc); Itcl_EventuallyFree((ClientData)mfunc, (Tcl_FreeProc*) Itcl_DeleteMemberFunc); *mfuncPtr = mfunc; return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ChangeMemberFunc() * * Modifies the data record representing a member function. This * is usually the body of the function, but can include the argument * list if it was not defined when the member was first created. * If the body is of the form "@name", then it is treated as a label * for a C procedure registered by Itcl_RegisterC(). * * If any errors are encountered, this procedure returns TCL_ERROR * along with an error message in the interpreter. Otherwise, it * returns TCL_OK, and "mfuncPtr" returns a pointer to the new * member function. * ------------------------------------------------------------------------ */ int Itcl_ChangeMemberFunc(interp, mfunc, arglist, body) Tcl_Interp* interp; /* interpreter managing this action */ ItclMemberFunc* mfunc; /* command member being changed */ CONST char* arglist; /* space-separated list of arg names */ CONST char* body; /* body of commands for the method */ { ItclMemberCode *mcode = NULL; Tcl_Obj *objPtr; /* * Try to create the implementation for this command member. */ if (Itcl_CreateMemberCode(interp, mfunc->member->classDefn, arglist, body, &mcode) != TCL_OK) { return TCL_ERROR; } /* * If the argument list was defined when the function was * created, compare the arg lists or usage strings to make sure * that the interface is not being redefined. */ if ((mfunc->member->flags & ITCL_ARG_SPEC) != 0 && !Itcl_EquivArgLists(mfunc->arglist, mfunc->argcount, mcode->arglist, mcode->argcount)) { objPtr = Itcl_ArgList(mfunc->argcount, mfunc->arglist); Tcl_IncrRefCount(objPtr); Tcl_AppendResult(interp, "argument list changed for function \"", mfunc->member->fullname, "\": should be \"", Tcl_GetStringFromObj(objPtr, (int*)NULL), "\"", (char*)NULL); Tcl_DecrRefCount(objPtr); Itcl_DeleteMemberCode((char*)mcode); return TCL_ERROR; } /* * Free up the old implementation and install the new one. */ Itcl_PreserveData((ClientData)mcode); Itcl_EventuallyFree((ClientData)mcode, (Tcl_FreeProc*) Itcl_DeleteMemberCode); Itcl_ReleaseData((ClientData)mfunc->member->code); mfunc->member->code = mcode; return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_DeleteMemberFunc() * * Destroys all data associated with the given member function definition. * Usually invoked by the interpreter when a member function is deleted. * ------------------------------------------------------------------------ */ void Itcl_DeleteMemberFunc(cdata) CONST char* cdata; /* pointer to member function definition */ { ItclMemberFunc* mfunc = (ItclMemberFunc*)cdata; if (mfunc) { Itcl_DeleteMember(mfunc->member); if (mfunc->arglist) { Itcl_DeleteArgList(mfunc->arglist); } ckfree((char*)mfunc); } } /* * ------------------------------------------------------------------------ * Itcl_CreateMemberCode() * * Creates the data record representing the implementation behind a * class member function. This includes the argument list and the body * of the function. If the body is of the form "@name", then it is * treated as a label for a C procedure registered by Itcl_RegisterC(). * * The implementation is kept by the member function definition, and * controlled by a preserve/release paradigm. That way, if it is in * use while it is being redefined, it will stay around long enough * to avoid a core dump. * * If any errors are encountered, this procedure returns TCL_ERROR * along with an error message in the interpreter. Otherwise, it * returns TCL_OK, and "mcodePtr" returns a pointer to the new * implementation. * ------------------------------------------------------------------------ */ int Itcl_CreateMemberCode(interp, cdefn, arglist, body, mcodePtr) Tcl_Interp* interp; /* interpreter managing this action */ ItclClass *cdefn; /* class containing this member */ CONST char* arglist; /* space-separated list of arg names */ CONST char* body; /* body of commands for the method */ ItclMemberCode** mcodePtr; /* returns: pointer to new implementation */ { int argc; CompiledLocal *args, *localPtr; ItclMemberCode *mcode; Proc *procPtr; /* * Allocate some space to hold the implementation. */ mcode = (ItclMemberCode*)ckalloc(sizeof(ItclMemberCode)); memset(mcode, 0, sizeof(ItclMemberCode)); if (arglist) { if (Itcl_CreateArgList(interp, arglist, &argc, &args) != TCL_OK) { Itcl_DeleteMemberCode((char*)mcode); return TCL_ERROR; } mcode->argcount = argc; mcode->arglist = args; mcode->flags |= ITCL_ARG_SPEC; } else { argc = 0; args = NULL; } /* * Create a standard Tcl Proc representation for this code body. * This is required, since the Tcl compiler looks for a proc * when handling things such as the call frame context and * compiled locals. */ procPtr = (Proc*)ckalloc(sizeof(Proc)); mcode->procPtr = procPtr; procPtr->iPtr = (Interp*)interp; procPtr->refCount = 1; procPtr->cmdPtr = (Command*)ckalloc(sizeof(Command)); memset(procPtr->cmdPtr, 0, sizeof(Command)); procPtr->cmdPtr->nsPtr = (Namespace*)cdefn->namesp; if (body) { procPtr->bodyPtr = Tcl_NewStringObj(body, -1); } else { procPtr->bodyPtr = Tcl_NewStringObj("", -1); mcode->flags |= ITCL_IMPLEMENT_NONE; } Tcl_IncrRefCount(procPtr->bodyPtr); /* * Plug the argument list into the "compiled locals" list. * * NOTE: The storage for this argument list is owned by * the caller, so although we plug it in here, it is not * our responsibility to free it. */ procPtr->firstLocalPtr = args; procPtr->lastLocalPtr = NULL; for (localPtr=mcode->arglist; localPtr; localPtr=localPtr->nextPtr) { procPtr->lastLocalPtr = localPtr; } procPtr->numArgs = argc; procPtr->numCompiledLocals = argc; /* * If the body definition starts with '@', then treat the value * as a symbolic name for a C procedure. */ if (body == NULL) { /* No-op */ } else if (*body == '@') { Tcl_CmdProc *argCmdProc; Tcl_ObjCmdProc *objCmdProc; ClientData cdata; if (!Itcl_FindC(interp, body+1, &argCmdProc, &objCmdProc, &cdata)) { Tcl_AppendResult(interp, "no registered C procedure with name \"", body+1, "\"", (char*)NULL); Itcl_DeleteMemberCode((char*)mcode); return TCL_ERROR; } if (objCmdProc != NULL) { mcode->flags |= ITCL_IMPLEMENT_OBJCMD; mcode->cfunc.objCmd = objCmdProc; mcode->clientData = cdata; } else if (argCmdProc != NULL) { mcode->flags |= ITCL_IMPLEMENT_ARGCMD; mcode->cfunc.argCmd = argCmdProc; mcode->clientData = cdata; } } /* * Otherwise, treat the body as a chunk of Tcl code. */ else { mcode->flags |= ITCL_IMPLEMENT_TCL; } *mcodePtr = mcode; return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_DeleteMemberCode() * * Destroys all data associated with the given command implementation. * Invoked automatically by Itcl_ReleaseData() when the implementation * is no longer being used. * ------------------------------------------------------------------------ */ void Itcl_DeleteMemberCode(cdata) CONST char* cdata; /* pointer to member function definition */ { ItclMemberCode* mcode = (ItclMemberCode*)cdata; /* * Free the argument list. If empty, free the compiled locals, if any. */ if (mcode->arglist) { Itcl_DeleteArgList(mcode->arglist); } else if (mcode->procPtr && mcode->procPtr->firstLocalPtr) { Itcl_DeleteArgList(mcode->procPtr->firstLocalPtr); } if (mcode->procPtr) { ckfree((char*) mcode->procPtr->cmdPtr); if (mcode->procPtr->bodyPtr) { Tcl_DecrRefCount(mcode->procPtr->bodyPtr); } ckfree((char*)mcode->procPtr); } ckfree((char*)mcode); } /* * ------------------------------------------------------------------------ * Itcl_GetMemberCode() * * Makes sure that the implementation for an [incr Tcl] code body is * ready to run. Note that a member function can be declared without * being defined. The class definition may contain a declaration of * the member function, but its body may be defined in a separate file. * If an undefined function is encountered, this routine automatically * attempts to autoload it. If the body is implemented via Tcl code, * then it is compiled here as well. * * Returns TCL_ERROR (along with an error message in the interpreter) * if an error is encountered, or if the implementation is not defined * and cannot be autoloaded. Returns TCL_OK if implementation is * ready to use. * ------------------------------------------------------------------------ */ int Itcl_GetMemberCode(interp, member) Tcl_Interp* interp; /* interpreter managing this action */ ItclMember* member; /* member containing code body */ { int result; ItclMemberCode *mcode = member->code; assert(mcode != NULL); /* * If the implementation has not yet been defined, try to * autoload it now. */ if (!Itcl_IsMemberCodeImplemented(mcode)) { result = Tcl_VarEval(interp, "::auto_load ", member->fullname, (char*)NULL); if (result != TCL_OK) { char msg[256]; sprintf(msg, "\n (while autoloading code for \"%.100s\")", member->fullname); Tcl_AddErrorInfo(interp, msg); return result; } Tcl_ResetResult(interp); /* get rid of 1/0 status */ } /* * If the implementation is still not available, then * autoloading must have failed. * * TRICKY NOTE: If code has been autoloaded, then the * old mcode pointer is probably invalid. Go back to * the member and look at the current code pointer again. */ mcode = member->code; assert(mcode != NULL); if (!Itcl_IsMemberCodeImplemented(mcode)) { Tcl_AppendResult(interp, "member function \"", member->fullname, "\" is not defined and cannot be autoloaded", (char*)NULL); return TCL_ERROR; } /* * If the member is a constructor and the class has an * initialization command, compile it here. */ if ((member->flags & ITCL_CONSTRUCTOR) != 0 && (member->classDefn->initCode != NULL)) { result = TclProcCompileProc(interp, mcode->procPtr, member->classDefn->initCode, (Namespace*)member->classDefn->namesp, "initialization code for", member->fullname); if (result != TCL_OK) { return result; } } /* * If the code body has a Tcl implementation, then compile it here. */ if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0) { result = TclProcCompileProc(interp, mcode->procPtr, mcode->procPtr->bodyPtr, (Namespace*)member->classDefn->namesp, "body for", member->fullname); if (result != TCL_OK) { return result; } } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_EvalMemberCode() * * Used to execute an ItclMemberCode representation of a code * fragment. This code may be a body of Tcl commands, or a C handler * procedure. * * Executes the command with the given arguments (objc,objv) and * returns an integer status code (TCL_OK/TCL_ERROR). Returns the * result string or an error message in the interpreter. * ------------------------------------------------------------------------ */ int Itcl_EvalMemberCode(interp, mfunc, member, contextObj, objc, objv) Tcl_Interp *interp; /* current interpreter */ ItclMemberFunc *mfunc; /* member func, or NULL (for error messages) */ ItclMember *member; /* command member containing code */ ItclObject *contextObj; /* object context, or NULL */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { int result = TCL_OK; Itcl_CallFrame *oldFramePtr = NULL; int i, transparent, newEntry; ItclObjectInfo *info; ItclMemberCode *mcode; ItclContext context; Itcl_CallFrame *framePtr, *transFramePtr; /* * If this code does not have an implementation yet, then * try to autoload one. Also, if this is Tcl code, make sure * that it's compiled and ready to use. */ if (Itcl_GetMemberCode(interp, member) != TCL_OK) { return TCL_ERROR; } mcode = member->code; /* * Bump the reference count on this code, in case it is * redefined or deleted during execution. */ Itcl_PreserveData((ClientData)mcode); /* * Install a new call frame context for the current code. * If the current call frame is marked as "transparent", then * do an "uplevel" operation to move past it. Transparent * call frames are installed by Itcl_HandleInstance. They * provide a way of entering an object context without * interfering with the normal call stack. */ transparent = 0; info = member->classDefn->info; framePtr = _Tcl_GetCallFrame(interp, 0); for (i = Itcl_GetStackSize(&info->transparentFrames)-1; i >= 0; i--) { transFramePtr = (Itcl_CallFrame*) Itcl_GetStackValue(&info->transparentFrames, i); if (framePtr == transFramePtr) { transparent = 1; break; } } if (transparent) { framePtr = _Tcl_GetCallFrame(interp, 1); oldFramePtr = _Tcl_ActivateCallFrame(interp, framePtr); } if (Itcl_PushContext(interp, member, member->classDefn, contextObj, &context) != TCL_OK) { return TCL_ERROR; } /* * If this is a method with a Tcl implementation, or a * constructor with initCode, then parse its arguments now. */ if (mfunc && objc > 0) { if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0 || ( (member->flags & ITCL_CONSTRUCTOR) != 0 && (member->classDefn->initCode != NULL) ) ) { if (Itcl_AssignArgs(interp, objc, objv, mfunc) != TCL_OK) { result = TCL_ERROR; goto evalMemberCodeDone; } } } /* * If this code is a constructor, and if it is being invoked * when an object is first constructed (i.e., the "constructed" * table is still active within the object), then handle the * "initCode" associated with the constructor and make sure that * all base classes are properly constructed. * * TRICKY NOTE: * The "initCode" must be executed here. This is the only * opportunity where the arguments of the constructor are * available in a call frame. */ if ((member->flags & ITCL_CONSTRUCTOR) && contextObj && contextObj->constructed) { result = Itcl_ConstructBase(interp, contextObj, member->classDefn); if (result != TCL_OK) { goto evalMemberCodeDone; } } /* * Execute the code body... */ if ((mcode->flags & ITCL_IMPLEMENT_OBJCMD) != 0) { result = (*mcode->cfunc.objCmd)(mcode->clientData, interp, objc, objv); } else if ((mcode->flags & ITCL_IMPLEMENT_ARGCMD) != 0) { CONST char **argv; argv = (CONST char**)ckalloc( (unsigned)(objc*sizeof(char*)) ); for (i=0; i < objc; i++) { argv[i] = Tcl_GetStringFromObj(objv[i], (int*)NULL); } result = (*mcode->cfunc.argCmd)(mcode->clientData, interp, objc, argv); ckfree((char*)argv); } else if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0) { result = Tcl_EvalObj(interp, mcode->procPtr->bodyPtr); } else { Tcl_Panic("itcl: bad implementation flag for %s", member->fullname); } /* * If this is a constructor or destructor, and if it is being * invoked at the appropriate time, keep track of which methods * have been called. This information is used to implicitly * invoke constructors/destructors as needed. */ if ((member->flags & ITCL_DESTRUCTOR) && contextObj && contextObj->destructed) { Tcl_CreateHashEntry(contextObj->destructed, member->classDefn->fullname, &newEntry); } if ((member->flags & ITCL_CONSTRUCTOR) && contextObj && contextObj->constructed) { Tcl_CreateHashEntry(contextObj->constructed, member->classDefn->name, &newEntry); } evalMemberCodeDone: Itcl_PopContext(interp, &context); if (transparent) { (void) _Tcl_ActivateCallFrame(interp, oldFramePtr); } Itcl_ReleaseData((ClientData)mcode); return result; } /* * ------------------------------------------------------------------------ * Itcl_CreateArgList() * * Parses a Tcl list representing an argument declaration and returns * a linked list of CompiledLocal values. Usually invoked as part * of Itcl_CreateMemberFunc() when a new method or procedure is being * defined. * ------------------------------------------------------------------------ */ int Itcl_CreateArgList(interp, decl, argcPtr, argPtr) Tcl_Interp* interp; /* interpreter managing this function */ CONST char* decl; /* string representing argument list */ int* argcPtr; /* returns number of args in argument list */ CompiledLocal** argPtr; /* returns pointer to parsed argument list */ { int status = TCL_OK; /* assume that this will succeed */ int i, argc, fargc; CONST char **argv, **fargv; CompiledLocal *localPtr, *last; *argPtr = last = NULL; *argcPtr = 0; if (decl) { if (Tcl_SplitList(interp, decl, &argc, &argv) != TCL_OK) { return TCL_ERROR; } for (i=0; i < argc && status == TCL_OK; i++) { if (Tcl_SplitList(interp, argv[i], &fargc, &fargv) != TCL_OK) { status = TCL_ERROR; } else { localPtr = NULL; if (fargc == 0 || *fargv[0] == '\0') { char mesg[100]; sprintf(mesg, "argument #%d has no name", i); Tcl_SetResult(interp, mesg, TCL_VOLATILE); status = TCL_ERROR; } else if (fargc > 2) { Tcl_AppendResult(interp, "too many fields in argument specifier \"", argv[i], "\"", (char*)NULL); status = TCL_ERROR; } else if (strstr(fargv[0],"::")) { Tcl_AppendResult(interp, "bad argument name \"", fargv[0], "\"", (char*)NULL); status = TCL_ERROR; } else if (fargc == 1) { localPtr = Itcl_CreateArg(fargv[0], (char*)NULL); } else { localPtr = Itcl_CreateArg(fargv[0], fargv[1]); } if (localPtr) { localPtr->frameIndex = i; if (*argPtr == NULL) { *argPtr = last = localPtr; } else { last->nextPtr = localPtr; last = localPtr; } } } ckfree((char*)fargv); } ckfree((char*)argv); } /* * If anything went wrong, destroy whatever arguments were * created and return an error. */ if (status == TCL_OK) { *argcPtr = argc; } else { Itcl_DeleteArgList(*argPtr); *argPtr = NULL; } return status; } /* * ------------------------------------------------------------------------ * Itcl_CreateArg() * * Creates a new Tcl Arg structure and fills it with the given * information. Returns a pointer to the new Arg structure. * ------------------------------------------------------------------------ */ CompiledLocal* Itcl_CreateArg(name, init) CONST char* name; /* name of new argument */ CONST char* init; /* initial value */ { CompiledLocal *localPtr = NULL; int nameLen; if (name == NULL) { name = ""; } nameLen = strlen(name); localPtr = (CompiledLocal*)ckalloc( (unsigned)(sizeof(CompiledLocal)-sizeof(localPtr->name) + nameLen+1) ); localPtr->nextPtr = NULL; localPtr->nameLength = nameLen; localPtr->frameIndex = 0; /* set this later */ ItclInitVarArgument(localPtr); localPtr->resolveInfo = NULL; if (init != NULL) { localPtr->defValuePtr = Tcl_NewStringObj(init, -1); Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } strcpy(localPtr->name, name); return localPtr; } /* * ------------------------------------------------------------------------ * Itcl_DeleteArgList() * * Destroys a chain of arguments acting as an argument list. Usually * invoked when a method/proc is being destroyed, to discard its * argument list. * ------------------------------------------------------------------------ */ void Itcl_DeleteArgList(arglist) CompiledLocal *arglist; /* first argument in arg list chain */ { CompiledLocal *localPtr, *next; for (localPtr=arglist; localPtr; localPtr=next) { if (localPtr->defValuePtr != NULL) { Tcl_DecrRefCount(localPtr->defValuePtr); } if (localPtr->resolveInfo) { if (localPtr->resolveInfo->deleteProc) { localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); } else { ckfree((char*)localPtr->resolveInfo); } localPtr->resolveInfo = NULL; } next = localPtr->nextPtr; ckfree((char*)localPtr); } } /* * ------------------------------------------------------------------------ * Itcl_ArgList() * * Returns a Tcl_Obj containing the string representation for the * given argument list. This object has a reference count of 1. * The reference count should be decremented when the string is no * longer needed, and it will free itself. * ------------------------------------------------------------------------ */ Tcl_Obj* Itcl_ArgList(argc, arglist) int argc; /* number of arguments */ CompiledLocal* arglist; /* first argument in arglist */ { char *val; Tcl_Obj *objPtr; Tcl_DString buffer; Tcl_DStringInit(&buffer); while (arglist && argc-- > 0) { if (arglist->defValuePtr) { val = Tcl_GetStringFromObj(arglist->defValuePtr, (int*)NULL); Tcl_DStringStartSublist(&buffer); Tcl_DStringAppendElement(&buffer, arglist->name); Tcl_DStringAppendElement(&buffer, val); Tcl_DStringEndSublist(&buffer); } else { Tcl_DStringAppendElement(&buffer, arglist->name); } arglist = arglist->nextPtr; } objPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), Tcl_DStringLength(&buffer)); Tcl_DStringFree(&buffer); return objPtr; } /* * ------------------------------------------------------------------------ * Itcl_EquivArgLists() * * Compares two argument lists to see if they are equivalent. The * first list is treated as a prototype, and the second list must * match it. Argument names may be different, but they must match in * meaning. If one argument is optional, the corresponding argument * must also be optional. If the prototype list ends with the magic * "args" argument, then it matches everything in the other list. * * Returns non-zero if the argument lists are equivalent. * ------------------------------------------------------------------------ */ int Itcl_EquivArgLists(arg1, arg1c, arg2, arg2c) CompiledLocal* arg1; /* prototype argument list */ int arg1c; /* number of args in prototype arg list */ CompiledLocal* arg2; /* another argument list to match against */ int arg2c; /* number of args in matching list */ { char *dval1, *dval2; while (arg1 && arg1c > 0 && arg2 && arg2c > 0) { /* * If the prototype argument list ends with the magic "args" * argument, then it matches everything in the other list. */ if (arg1c == 1 && strcmp(arg1->name,"args") == 0) { return 1; } /* * If one has a default value, then the other must have the * same default value. */ if (arg1->defValuePtr) { if (arg2->defValuePtr == NULL) { return 0; } dval1 = Tcl_GetStringFromObj(arg1->defValuePtr, (int*)NULL); dval2 = Tcl_GetStringFromObj(arg2->defValuePtr, (int*)NULL); if (strcmp(dval1, dval2) != 0) { return 0; } } else if (arg2->defValuePtr) { return 0; } arg1 = arg1->nextPtr; arg1c--; arg2 = arg2->nextPtr; arg2c--; } if (arg1c == 1 && strcmp(arg1->name,"args") == 0) { return 1; } return (arg1c == 0 && arg2c == 0); } /* * ------------------------------------------------------------------------ * Itcl_GetMemberFuncUsage() * * Returns a string showing how a command member should be invoked. * If the command member is a method, then the specified object name * is reported as part of the invocation path: * * obj method arg ?arg arg ...? * * Otherwise, the "obj" pointer is ignored, and the class name is * used as the invocation path: * * class::proc arg ?arg arg ...? * * Returns the string by appending it onto the Tcl_Obj passed in as * an argument. * ------------------------------------------------------------------------ */ void Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr) ItclMemberFunc *mfunc; /* command member being examined */ ItclObject *contextObj; /* invoked with respect to this object */ Tcl_Obj *objPtr; /* returns: string showing usage */ { int argcount; char *name; CompiledLocal *arglist, *argPtr; Tcl_HashEntry *entry; ItclMemberFunc *mf; ItclClass *cdefnPtr; /* * If the command is a method and an object context was * specified, then add the object context. If the method * was a constructor, and if the object is being created, * then report the invocation via the class creation command. */ if ((mfunc->member->flags & ITCL_COMMON) == 0) { if ((mfunc->member->flags & ITCL_CONSTRUCTOR) != 0 && contextObj->constructed) { cdefnPtr = (ItclClass*)contextObj->classDefn; mf = NULL; entry = Tcl_FindHashEntry(&cdefnPtr->resolveCmds, "constructor"); if (entry) { mf = (ItclMemberFunc*)Tcl_GetHashValue(entry); } if (mf == mfunc) { Tcl_GetCommandFullName(contextObj->classDefn->interp, contextObj->classDefn->accessCmd, objPtr); Tcl_AppendToObj(objPtr, " ", -1); name = (char *) Tcl_GetCommandName( contextObj->classDefn->interp, contextObj->accessCmd); Tcl_AppendToObj(objPtr, name, -1); } else { Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1); } } else if (contextObj && contextObj->accessCmd) { name = (char *) Tcl_GetCommandName(contextObj->classDefn->interp, contextObj->accessCmd); Tcl_AppendStringsToObj(objPtr, name, " ", mfunc->member->name, (char*)NULL); } else { Tcl_AppendStringsToObj(objPtr, " ", mfunc->member->name, (char*)NULL); } } else { Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1); } /* * Add the argument usage info. */ if (mfunc->member->code) { arglist = mfunc->member->code->arglist; argcount = mfunc->member->code->argcount; } else if (mfunc->arglist) { arglist = mfunc->arglist; argcount = mfunc->argcount; } else { arglist = NULL; argcount = 0; } if (arglist) { for (argPtr=arglist; argPtr && argcount > 0; argPtr=argPtr->nextPtr, argcount--) { if (argcount == 1 && strcmp(argPtr->name, "args") == 0) { Tcl_AppendToObj(objPtr, " ?arg arg ...?", -1); } else if (argPtr->defValuePtr) { Tcl_AppendStringsToObj(objPtr, " ?", argPtr->name, "?", (char*)NULL); } else { Tcl_AppendStringsToObj(objPtr, " ", argPtr->name, (char*)NULL); } } } } /* * ------------------------------------------------------------------------ * Itcl_ExecMethod() * * Invoked by Tcl to handle the execution of a user-defined method. * A method is similar to the usual Tcl proc, but has access to * object-specific data. If for some reason there is no current * object context, then a method call is inappropriate, and an error * is returned. * * Methods are implemented either as Tcl code fragments, or as C-coded * procedures. For Tcl code fragments, command arguments are parsed * according to the argument list, and the body is executed in the * scope of the class where it was defined. For C procedures, the * arguments are passed in "as-is", and the procedure is executed in * the most-specific class scope. * ------------------------------------------------------------------------ */ int Itcl_ExecMethod(clientData, interp, objc, objv) ClientData clientData; /* method definition */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { ItclMemberFunc *mfunc = (ItclMemberFunc*)clientData; ItclMember *member = mfunc->member; int result = TCL_OK; char *token; Tcl_HashEntry *entry; ItclClass *contextClass; ItclObject *contextObj; /* * Make sure that the current namespace context includes an * object that is being manipulated. Methods can be executed * only if an object context exists. */ if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) { return TCL_ERROR; } if (contextObj == NULL) { Tcl_AppendResult(interp, "cannot access object-specific info without an object context", (char*)NULL); return TCL_ERROR; } /* * Make sure that this command member can be accessed from * the current namespace context. */ if (mfunc->member->protection != ITCL_PUBLIC) { Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp, contextClass->info); if (!Itcl_CanAccessFunc(mfunc, contextNs)) { Tcl_AppendResult(interp, "can't access \"", member->fullname, "\": ", Itcl_ProtectionStr(member->protection), " function", (char*)NULL); return TCL_ERROR; } } /* * All methods should be "virtual" unless they are invoked with * a "::" scope qualifier. * * To implement the "virtual" behavior, find the most-specific * implementation for the method by looking in the "resolveCmds" * table for this class. */ token = Tcl_GetStringFromObj(objv[0], (int*)NULL); if (strstr(token, "::") == NULL) { entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveCmds, member->name); if (entry) { mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); member = mfunc->member; } } /* * Execute the code for the method. Be careful to protect * the method in case it gets deleted during execution. */ Itcl_PreserveData((ClientData)mfunc); result = Itcl_EvalMemberCode(interp, mfunc, member, contextObj, objc, objv); result = Itcl_ReportFuncErrors(interp, mfunc, contextObj, result); Itcl_ReleaseData((ClientData)mfunc); return result; } /* * ------------------------------------------------------------------------ * Itcl_ExecProc() * * Invoked by Tcl to handle the execution of a user-defined proc. * * Procs are implemented either as Tcl code fragments, or as C-coded * procedures. For Tcl code fragments, command arguments are parsed * according to the argument list, and the body is executed in the * scope of the class where it was defined. For C procedures, the * arguments are passed in "as-is", and the procedure is executed in * the most-specific class scope. * ------------------------------------------------------------------------ */ int Itcl_ExecProc(clientData, interp, objc, objv) ClientData clientData; /* proc definition */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { ItclMemberFunc *mfunc = (ItclMemberFunc*)clientData; ItclMember *member = mfunc->member; int result = TCL_OK; /* * Make sure that this command member can be accessed from * the current namespace context. */ if (mfunc->member->protection != ITCL_PUBLIC) { Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp, mfunc->member->classDefn->info); if (!Itcl_CanAccessFunc(mfunc, contextNs)) { Tcl_AppendResult(interp, "can't access \"", member->fullname, "\": ", Itcl_ProtectionStr(member->protection), " function", (char*)NULL); return TCL_ERROR; } } /* * Execute the code for the proc. Be careful to protect * the proc in case it gets deleted during execution. */ Itcl_PreserveData((ClientData)mfunc); result = Itcl_EvalMemberCode(interp, mfunc, member, (ItclObject*)NULL, objc, objv); result = Itcl_ReportFuncErrors(interp, mfunc, (ItclObject*)NULL, result); Itcl_ReleaseData((ClientData)mfunc); return result; } /* * ------------------------------------------------------------------------ * Itcl_PushContext() * * Sets up the class/object context so that a body of [incr Tcl] * code can be executed. This procedure pushes a call frame with * the proper namespace context for the class. If an object context * is supplied, the object's instance variables are integrated into * the call frame so they can be accessed as local variables. * ------------------------------------------------------------------------ */ int Itcl_PushContext(interp, member, contextClass, contextObj, contextPtr) Tcl_Interp *interp; /* interpreter managing this body of code */ ItclMember *member; /* member containing code body */ ItclClass *contextClass; /* class context */ ItclObject *contextObj; /* object context, or NULL */ ItclContext *contextPtr; /* storage space for class/object context */ { ItclCallFrame *framePtr = (ItclCallFrame *) &contextPtr->frame; int result, localCt, newEntry; ItclMemberCode *mcode; Proc *procPtr; Tcl_HashEntry *entry; /* * Activate the call frame. If this fails, we'll bail out * before allocating any resources. * * NOTE: Always push a call frame that looks like a proc. * This causes global variables to be handled properly * inside methods/procs. */ result = Tcl_PushCallFrame(interp, (Tcl_CallFrame*)framePtr, contextClass->namesp, /* isProcCallFrame */ 1); if (result != TCL_OK) { return result; } contextPtr->classDefn = contextClass; contextPtr->compiledLocals = &contextPtr->localStorage[0]; /* * If this is an object context, register it in a hash table * of all known contexts. We'll need this later if we * call Itcl_GetContext to get the object context for the * current call frame. */ if (contextObj) { entry = Tcl_CreateHashEntry(&contextClass->info->contextFrames, (char*)framePtr, &newEntry); Itcl_PreserveData((ClientData)contextObj); Tcl_SetHashValue(entry, (ClientData)contextObj); } /* * Set up the compiled locals in the call frame and assign * argument variables. */ if (member) { mcode = member->code; procPtr = mcode->procPtr; /* * Invoking TclInitCompiledLocals with a framePtr->procPtr->bodyPtr * that is not a compiled byte code type leads to a crash. So * make sure that the body is compiled here. This needs to * be done even if the body of the Itcl method is not implemented * as a Tcl proc or has no implementation. The empty string should * have been defined as the body if no implementation was defined. */ assert(mcode->procPtr->bodyPtr != NULL); result = TclProcCompileProc(interp, mcode->procPtr, mcode->procPtr->bodyPtr, (Namespace*)member->classDefn->namesp, "body for", member->fullname); if (result != TCL_OK) { return result; } /* * If there are too many compiled locals to fit in the default * storage space for the context, then allocate more space. */ localCt = procPtr->numCompiledLocals; if (localCt > (int)(sizeof(contextPtr->localStorage)/itclVarLocalSize)) { contextPtr->compiledLocals = (Var*)ckalloc( (unsigned)(localCt * itclVarLocalSize) ); } /* * Initialize and resolve compiled variable references. * Class variables will have special resolution rules. * In that case, we call their "resolver" procs to get our * hands on the variable, and we make the compiled local a * link to the real variable. */ framePtr->procPtr = procPtr; framePtr->numCompiledLocals = localCt; framePtr->compiledLocals = contextPtr->compiledLocals; TclInitCompiledLocals(interp, (CallFrame *) framePtr, (Namespace*)contextClass->namesp); } return result; } /* * ------------------------------------------------------------------------ * Itcl_PopContext() * * Removes a class/object context previously set up by Itcl_PushContext. * Usually called after an [incr Tcl] code body has been executed, * to clean up. * ------------------------------------------------------------------------ */ void Itcl_PopContext(interp, contextPtr) Tcl_Interp *interp; /* interpreter managing this body of code */ ItclContext *contextPtr; /* storage space for class/object context */ { Itcl_CallFrame *framePtr; ItclObjectInfo *info; ItclObject *contextObj; Tcl_HashEntry *entry; /* * See if the current call frame has an object context * associated with it. If so, release the claim on the * object info. */ framePtr = _Tcl_GetCallFrame(interp, 0); info = contextPtr->classDefn->info; entry = Tcl_FindHashEntry(&info->contextFrames, (char*)framePtr); if (entry != NULL) { contextObj = (ItclObject*)Tcl_GetHashValue(entry); Itcl_ReleaseData((ClientData)contextObj); Tcl_DeleteHashEntry(entry); } /* * Remove the call frame. */ Tcl_PopCallFrame(interp); /* * Free the compiledLocals array if malloc'ed storage was used. */ if (contextPtr->compiledLocals != &contextPtr->localStorage[0]) { ckfree((char*)contextPtr->compiledLocals); } } /* * ------------------------------------------------------------------------ * Itcl_GetContext() * * Convenience routine for looking up the current object/class context. * Useful in implementing methods/procs to see what class, and perhaps * what object, is active. * * Returns TCL_OK if the current namespace is a class namespace. * Also returns pointers to the class definition, and to object * data if an object context is active. Returns TCL_ERROR (along * with an error message in the interpreter) if a class namespace * is not active. * ------------------------------------------------------------------------ */ int Itcl_GetContext(interp, cdefnPtr, odefnPtr) Tcl_Interp *interp; /* current interpreter */ ItclClass **cdefnPtr; /* returns: class definition or NULL */ ItclObject **odefnPtr; /* returns: object data or NULL */ { Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp); ItclObjectInfo *info; Itcl_CallFrame *framePtr; Tcl_HashEntry *entry; /* * Return NULL for anything that cannot be found. */ *cdefnPtr = NULL; *odefnPtr = NULL; /* * If the active namespace is a class namespace, then return * all known info. See if the current call frame is a known * object context, and if so, return that context. */ if (Itcl_IsClassNamespace(activeNs)) { *cdefnPtr = (ItclClass*)activeNs->clientData; framePtr = _Tcl_GetCallFrame(interp, 0); info = (*cdefnPtr)->info; entry = Tcl_FindHashEntry(&info->contextFrames, (char*)framePtr); if (entry != NULL) { *odefnPtr = (ItclObject*)Tcl_GetHashValue(entry); } return TCL_OK; } /* * If there is no class/object context, return an error message. */ Tcl_AppendResult(interp, "namespace \"", activeNs->fullName, "\" is not a class namespace", (char*)NULL); return TCL_ERROR; } /* * ------------------------------------------------------------------------ * Itcl_AssignArgs() * * Matches a list of arguments against a Tcl argument specification. * Supports all of the rules regarding arguments for Tcl procs, including * default arguments and variable-length argument lists. * * Assumes that a local call frame is already installed. As variables * are successfully matched, they are stored as variables in the call * frame. Returns TCL_OK on success, or TCL_ERROR (along with an error * message in interp->result) on error. * ------------------------------------------------------------------------ */ int Itcl_AssignArgs(interp, objc, objv, mfunc) Tcl_Interp *interp; /* interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ ItclMemberFunc *mfunc; /* member function info (for error messages) */ { ItclMemberCode *mcode = mfunc->member->code; int result = TCL_OK; int defargc; CONST char **defargv = NULL; Tcl_Obj **defobjv = NULL; int configc = 0; ItclVarDefn **configVars = NULL; char **configVals = NULL; int vi, argsLeft; ItclClass *contextClass; ItclObject *contextObj; CompiledLocal *argPtr; ItclCallFrame *framePtr; Var *varPtr; Tcl_Obj *objPtr, *listPtr; char *value; framePtr = (ItclCallFrame *) _Tcl_GetCallFrame(interp, 0); framePtr->objc = objc; framePtr->objv = objv; /* ref counts for args are incremented below */ /* * See if there is a current object context. We may need * it later on. */ (void) Itcl_GetContext(interp, &contextClass, &contextObj); Tcl_ResetResult(interp); /* * Match the actual arguments against the procedure's formal * parameters to compute local variables. */ varPtr = framePtr->compiledLocals; for (argsLeft=mcode->argcount, argPtr=mcode->arglist, objv++, objc--; argsLeft > 0; argPtr=argPtr->nextPtr, argsLeft--, ItclNextLocal(varPtr), objv++, objc--) { if (!TclIsVarArgument(argPtr)) { Tcl_Panic("local variable %s is not argument but should be", argPtr->name); return TCL_ERROR; } if (TclIsVarTemporary(argPtr)) { Tcl_Panic("local variable is temporary but should be an argument"); return TCL_ERROR; } /* * Handle the special case of the last formal being "args". * When it occurs, assign it a list consisting of all the * remaining actual arguments. */ if ((argsLeft == 1) && (strcmp(argPtr->name, "args") == 0)) { if (objc < 0) objc = 0; listPtr = Tcl_NewListObj(objc, objv); ItclVarObjValue(varPtr) = listPtr; Tcl_IncrRefCount(listPtr); /* local var is a reference */ ItclClearVarUndefined(varPtr); objc = 0; break; } /* * Handle the special case of the last formal being "config". * When it occurs, treat all remaining arguments as public * variable assignments. Set the local "config" variable * to the list of public variables assigned. */ else if ( (argsLeft == 1) && (strcmp(argPtr->name, "config") == 0) && contextObj ) { /* * If this is not an old-style method, discourage against * the use of the "config" argument. */ if ((mfunc->member->flags & ITCL_OLD_STYLE) == 0) { Tcl_AppendResult(interp, "\"config\" argument is an anachronism\n", "[incr Tcl] no longer supports the \"config\" argument.\n", "Instead, use the \"args\" argument and then use the\n", "built-in configure method to handle args like this:\n", " eval configure $args", (char*)NULL); result = TCL_ERROR; goto argErrors; } /* * Otherwise, handle the "config" argument in the usual way... * - parse all "-name value" assignments * - set "config" argument to the list of variable names */ if (objc > 0) { /* still have some arguments left? */ result = ItclParseConfig(interp, objc, objv, contextObj, &configc, &configVars, &configVals); if (result != TCL_OK) { goto argErrors; } listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); for (vi=0; vi < configc; vi++) { objPtr = Tcl_NewStringObj( configVars[vi]->member->classDefn->name, -1); Tcl_AppendToObj(objPtr, "::", -1); Tcl_AppendToObj(objPtr, configVars[vi]->member->name, -1); Tcl_ListObjAppendElement(interp, listPtr, objPtr); } ItclVarObjValue(varPtr) = listPtr; Tcl_IncrRefCount(listPtr); /* local var is a reference */ ItclClearVarUndefined(varPtr); objc = 0; /* all remaining args handled */ } else if (argPtr->defValuePtr) { value = Tcl_GetStringFromObj(argPtr->defValuePtr, (int*)NULL); result = Tcl_SplitList(interp, value, &defargc, &defargv); if (result != TCL_OK) { goto argErrors; } defobjv = (Tcl_Obj**)ckalloc( (unsigned)(defargc*sizeof(Tcl_Obj*)) ); for (vi=0; vi < defargc; vi++) { objPtr = Tcl_NewStringObj(defargv[vi], -1); Tcl_IncrRefCount(objPtr); defobjv[vi] = objPtr; } result = ItclParseConfig(interp, defargc, defobjv, contextObj, &configc, &configVars, &configVals); if (result != TCL_OK) { goto argErrors; } listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); for (vi=0; vi < configc; vi++) { objPtr = Tcl_NewStringObj( configVars[vi]->member->classDefn->name, -1); Tcl_AppendToObj(objPtr, "::", -1); Tcl_AppendToObj(objPtr, configVars[vi]->member->name, -1); Tcl_ListObjAppendElement(interp, listPtr, objPtr); } ItclVarObjValue(varPtr) = listPtr; Tcl_IncrRefCount(listPtr); /* local var is a reference */ ItclClearVarUndefined(varPtr); } else { objPtr = Tcl_NewStringObj("", 0); ItclVarObjValue(varPtr) = objPtr; Tcl_IncrRefCount(objPtr); /* local var is a reference */ ItclClearVarUndefined(varPtr); } } /* * Resume the usual processing of arguments... */ else if (objc > 0) { /* take next arg as value */ objPtr = *objv; ItclVarObjValue(varPtr) = objPtr; ItclClearVarUndefined(varPtr); Tcl_IncrRefCount(objPtr); /* local var is a reference */ } else if (argPtr->defValuePtr) { /* ...or use default value */ objPtr = argPtr->defValuePtr; ItclVarObjValue(varPtr) = objPtr; ItclClearVarUndefined(varPtr); Tcl_IncrRefCount(objPtr); /* local var is a reference */ } else { if (mfunc) { objPtr = Tcl_GetObjResult(interp); Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr); Tcl_AppendToObj(objPtr, "\"", -1); } else { Tcl_AppendResult(interp, "no value given for parameter \"", argPtr->name, "\"", (char*)NULL); } result = TCL_ERROR; goto argErrors; } } if (objc > 0) { if (mfunc) { objPtr = Tcl_GetObjResult(interp); Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr); Tcl_AppendToObj(objPtr, "\"", -1); } else { Tcl_AppendResult(interp, "too many arguments", (char*)NULL); } result = TCL_ERROR; goto argErrors; } /* * Handle any "config" assignments. */ if (configc > 0) { if (ItclHandleConfig(interp, configc, configVars, configVals, contextObj) != TCL_OK) { result = TCL_ERROR; goto argErrors; } } /* * All arguments were successfully matched. */ result = TCL_OK; /* * If any errors were found, clean up and return error status. */ argErrors: if (defobjv) { for (vi=0; vi < defargc; vi++) { Tcl_DecrRefCount(defobjv[vi]); } ckfree((char*)defobjv); } if (defargv) { ckfree((char*)defargv); } if (configVars) { ckfree((char*)configVars); } if (configVals) { ckfree((char*)configVals); } return result; } /* * ------------------------------------------------------------------------ * ItclParseConfig() * * Parses a set of arguments as "-variable value" assignments. * Interprets all variable names in the most-specific class scope, * so that an inherited method with a "config" parameter will work * correctly. Returns a list of public variable names and their * corresponding values; both lists should passed to ItclHandleConfig() * to perform assignments, and freed when no longer in use. Returns a * status TCL_OK/TCL_ERROR and returns error messages in the interpreter. * ------------------------------------------------------------------------ */ static int ItclParseConfig(interp, objc, objv, contextObj, rargc, rvars, rvals) Tcl_Interp *interp; /* interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ ItclObject *contextObj; /* object whose public vars are being config'd */ int *rargc; /* return: number of variables accessed */ ItclVarDefn ***rvars; /* return: list of variables */ char ***rvals; /* return: list of values */ { int result = TCL_OK; ItclVarLookup *vlookup; Tcl_HashEntry *entry; char *varName, *value; if (objc < 0) objc = 0; *rargc = 0; *rvars = (ItclVarDefn**)ckalloc((unsigned)(objc*sizeof(ItclVarDefn*))); *rvals = (char**)ckalloc((unsigned)(objc*sizeof(char*))); while (objc-- > 0) { /* * Next argument should be "-variable" */ varName = Tcl_GetStringFromObj(*objv, (int*)NULL); if (*varName != '-') { Tcl_AppendResult(interp, "syntax error in config assignment \"", varName, "\": should be \"-variable value\"", (char*)NULL); result = TCL_ERROR; break; } else if (objc-- <= 0) { Tcl_AppendResult(interp, "syntax error in config assignment \"", varName, "\": should be \"-variable value\" (missing value)", (char*)NULL); result = TCL_ERROR; break; } entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars, varName+1); if (entry) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); value = Tcl_GetStringFromObj(*(objv+1), (int*)NULL); (*rvars)[*rargc] = vlookup->vdefn; /* variable definition */ (*rvals)[*rargc] = value; /* config value */ (*rargc)++; objv += 2; } else { Tcl_AppendResult(interp, "syntax error in config assignment \"", varName, "\": unrecognized variable", (char*)NULL); result = TCL_ERROR; break; } } return result; } /* * ------------------------------------------------------------------------ * ItclHandleConfig() * * Handles the assignment of "config" values to public variables. * The list of assignments is parsed in ItclParseConfig(), but the * actual assignments are performed here. If the variables have any * associated "config" code, it is invoked here as well. If errors * are detected during assignment or "config" code execution, the * variable is set back to its previous value and an error is returned. * * Returns a status TCL_OK/TCL_ERROR, and returns any error messages * in the given interpreter. * ------------------------------------------------------------------------ */ static int ItclHandleConfig(interp, argc, vars, vals, contextObj) Tcl_Interp *interp; /* interpreter currently in control */ int argc; /* number of assignments */ ItclVarDefn **vars; /* list of public variable definitions */ char **vals; /* list of public variable values */ ItclObject *contextObj; /* object whose public vars are being config'd */ { int result = TCL_OK; int i; CONST char *val; Tcl_DString lastval; ItclContext context; Itcl_CallFrame *oldFramePtr, *uplevelFramePtr; Tcl_DStringInit(&lastval); /* * All "config" assignments are performed in the most-specific * class scope, so that inherited methods with "config" arguments * will work correctly. */ result = Itcl_PushContext(interp, (ItclMember*)NULL, contextObj->classDefn, contextObj, &context); if (result != TCL_OK) { return TCL_ERROR; } /* * Perform each assignment and execute the "config" code * associated with each variable. If any errors are encountered, * set the variable back to its previous value, and return an error. */ for (i=0; i < argc; i++) { val = Tcl_GetVar2(interp, vars[i]->member->fullname, (char*)NULL, 0); if (!val) { val = ""; } Tcl_DStringSetLength(&lastval, 0); Tcl_DStringAppend(&lastval, val, -1); /* * Set the variable to the specified value. */ if (!Tcl_SetVar2(interp, vars[i]->member->fullname, (char*)NULL, vals[i], 0)) { char msg[256]; sprintf(msg, "\n (while configuring public variable \"%.100s\")", vars[i]->member->fullname); Tcl_AddErrorInfo(interp, msg); result = TCL_ERROR; break; } /* * If the variable has a "config" condition, then execute it. * If it fails, put the variable back the way it was and return * an error. * * TRICKY NOTE: Be careful to evaluate the code one level * up in the call stack, so that it's executed in the * calling context, and not in the context that we've * set up for public variable access. */ if (vars[i]->member->code) { uplevelFramePtr = _Tcl_GetCallFrame(interp, 1); oldFramePtr = _Tcl_ActivateCallFrame(interp, uplevelFramePtr); result = Itcl_EvalMemberCode(interp, (ItclMemberFunc*)NULL, vars[i]->member, contextObj, 0, (Tcl_Obj* CONST*)NULL); (void) _Tcl_ActivateCallFrame(interp, oldFramePtr); if (result != TCL_OK) { char msg[256]; sprintf(msg, "\n (while configuring public variable \"%.100s\")", vars[i]->member->fullname); Tcl_AddErrorInfo(interp, msg); Tcl_SetVar2(interp, vars[i]->member->fullname, (char*)NULL, Tcl_DStringValue(&lastval), 0); break; } } } /* * Clean up and return. */ Itcl_PopContext(interp, &context); Tcl_DStringFree(&lastval); return result; } /* * ------------------------------------------------------------------------ * Itcl_ConstructBase() * * Usually invoked just before executing the body of a constructor * when an object is first created. This procedure makes sure that * all base classes are properly constructed. If an "initCode" fragment * was defined with the constructor for the class, then it is invoked. * After that, the list of base classes is checked for constructors * that are defined but have not yet been invoked. Each of these is * invoked implicitly with no arguments. * * Assumes that a local call frame is already installed, and that * constructor arguments have already been matched and are sitting in * this frame. Returns TCL_OK on success; otherwise, this procedure * returns TCL_ERROR, along with an error message in the interpreter. * ------------------------------------------------------------------------ */ int Itcl_ConstructBase(interp, contextObj, contextClass) Tcl_Interp *interp; /* interpreter */ ItclObject *contextObj; /* object being constructed */ ItclClass *contextClass; /* current class being constructed */ { int result; Itcl_ListElem *elem; ItclClass *cdefn; Tcl_HashEntry *entry; /* * If the class has an "initCode", invoke it in the current context. * * TRICKY NOTE: * This context is the call frame containing the arguments * for the constructor. The "initCode" makes sense right * now--just before the body of the constructor is executed. */ if (contextClass->initCode) { if (Tcl_EvalObj(interp, contextClass->initCode) != TCL_OK) { return TCL_ERROR; } } /* * Scan through the list of base classes and see if any of these * have not been constructed. Invoke base class constructors * implicitly, as needed. Go through the list of base classes * in reverse order, so that least-specific classes are constructed * first. */ elem = Itcl_LastListElem(&contextClass->bases); while (elem) { cdefn = (ItclClass*)Itcl_GetListValue(elem); if (!Tcl_FindHashEntry(contextObj->constructed, cdefn->name)) { result = Itcl_InvokeMethodIfExists(interp, "constructor", cdefn, contextObj, 0, (Tcl_Obj* CONST*)NULL); if (result != TCL_OK) { return TCL_ERROR; } /* * The base class may not have a constructor, but its * own base classes could have one. If the constructor * wasn't found in the last step, then other base classes * weren't constructed either. Make sure that all of its * base classes are properly constructed. */ entry = Tcl_FindHashEntry(&cdefn->functions, "constructor"); if (entry == NULL) { result = Itcl_ConstructBase(interp, contextObj, cdefn); if (result != TCL_OK) { return TCL_ERROR; } } } elem = Itcl_PrevListElem(elem); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_InvokeMethodIfExists() * * Looks for a particular method in the specified class. If the * method is found, it is invoked with the given arguments. Any * protection level (protected/private) for the method is ignored. * If the method does not exist, this procedure does nothing. * * This procedure is used primarily to invoke the constructor/destructor * when an object is created/destroyed. * * Returns TCL_OK on success; otherwise, this procedure returns * TCL_ERROR along with an error message in the interpreter. * ------------------------------------------------------------------------ */ int Itcl_InvokeMethodIfExists(interp, name, contextClass, contextObj, objc, objv) Tcl_Interp *interp; /* interpreter */ CONST char *name; /* name of desired method */ ItclClass *contextClass; /* current class being constructed */ ItclObject *contextObj; /* object being constructed */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { int result = TCL_OK; ItclMemberFunc *mfunc; ItclMember *member; Tcl_HashEntry *entry; Tcl_Obj *cmdlinePtr; int cmdlinec; Tcl_Obj **cmdlinev; /* * Scan through the list of base classes and see if any of these * have not been constructed. Invoke base class constructors * implicitly, as needed. Go through the list of base classes * in reverse order, so that least-specific classes are constructed * first. */ entry = Tcl_FindHashEntry(&contextClass->functions, name); if (entry) { mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); member = mfunc->member; /* * Prepend the method name to the list of arguments. */ cmdlinePtr = Itcl_CreateArgs(interp, name, objc, objv); (void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr, &cmdlinec, &cmdlinev); /* * Execute the code for the method. Be careful to protect * the method in case it gets deleted during execution. */ Itcl_PreserveData((ClientData)mfunc); result = Itcl_EvalMemberCode(interp, mfunc, member, contextObj, cmdlinec, cmdlinev); result = Itcl_ReportFuncErrors(interp, mfunc, contextObj, result); Itcl_ReleaseData((ClientData)mfunc); Tcl_DecrRefCount(cmdlinePtr); } return result; } /* * ------------------------------------------------------------------------ * Itcl_ReportFuncErrors() * * Used to interpret the status code returned when the body of a * Tcl-style proc is executed. Handles the "errorInfo" and "errorCode" * variables properly, and adds error information into the interpreter * if anything went wrong. Returns a new status code that should be * treated as the return status code for the command. * * This same operation is usually buried in the Tcl InterpProc() * procedure. It is defined here so that it can be reused more easily. * ------------------------------------------------------------------------ */ int Itcl_ReportFuncErrors(interp, mfunc, contextObj, result) Tcl_Interp* interp; /* interpreter being modified */ ItclMemberFunc *mfunc; /* command member that was invoked */ ItclObject *contextObj; /* object context for this command */ int result; /* integer status code from proc body */ { Interp* iPtr = (Interp*)interp; Tcl_Obj *objPtr; char num[20]; if (result != TCL_OK) { if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } else if (result == TCL_ERROR) { objPtr = Tcl_NewStringObj("\n ", -1); Tcl_IncrRefCount(objPtr); if (mfunc->member->flags & ITCL_CONSTRUCTOR) { Tcl_AppendToObj(objPtr, "while constructing object \"", -1); Tcl_GetCommandFullName(contextObj->classDefn->interp, contextObj->accessCmd, objPtr); Tcl_AppendToObj(objPtr, "\" in ", -1); Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1); if ((mfunc->member->code->flags & ITCL_IMPLEMENT_TCL) != 0) { Tcl_AppendToObj(objPtr, " (", -1); } } else if (mfunc->member->flags & ITCL_DESTRUCTOR) { Tcl_AppendToObj(objPtr, "while deleting object \"", -1); Tcl_GetCommandFullName(contextObj->classDefn->interp, contextObj->accessCmd, objPtr); Tcl_AppendToObj(objPtr, "\" in ", -1); Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1); if ((mfunc->member->code->flags & ITCL_IMPLEMENT_TCL) != 0) { Tcl_AppendToObj(objPtr, " (", -1); } } else { Tcl_AppendToObj(objPtr, "(", -1); if (contextObj && contextObj->accessCmd) { Tcl_AppendToObj(objPtr, "object \"", -1); Tcl_GetCommandFullName(contextObj->classDefn->interp, contextObj->accessCmd, objPtr); Tcl_AppendToObj(objPtr, "\" ", -1); } if ((mfunc->member->flags & ITCL_COMMON) != 0) { Tcl_AppendToObj(objPtr, "procedure", -1); } else { Tcl_AppendToObj(objPtr, "method", -1); } Tcl_AppendToObj(objPtr, " \"", -1); Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1); Tcl_AppendToObj(objPtr, "\" ", -1); } if ((mfunc->member->code->flags & ITCL_IMPLEMENT_TCL) != 0) { Tcl_AppendToObj(objPtr, "body line ", -1); sprintf(num, "%d", Tcl_GetErrorLine((Tcl_Interp *)iPtr)); Tcl_AppendToObj(objPtr, num, -1); Tcl_AppendToObj(objPtr, ")", -1); } else { Tcl_AppendToObj(objPtr, ")", -1); } Tcl_AddErrorInfo(interp, Tcl_GetStringFromObj(objPtr, (int*)NULL)); Tcl_DecrRefCount(objPtr); } else if (result == TCL_BREAK) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "invoked \"break\" outside of a loop", -1); result = TCL_ERROR; } else if (result == TCL_CONTINUE) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "invoked \"continue\" outside of a loop", -1); result = TCL_ERROR; } } return result; } itcl3.4.1/generic/itcl_ensemble.c0000644003604700454610000020646611610103534015370 0ustar dgp891div/* * ------------------------------------------------------------------------ * 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 * ======================================================================== * 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 */ }; /* * 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, CONST char *ensName)); static int AddEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp, Ensemble* ensData, CONST char* partName, CONST 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, CONST char **nameArgv, int nameArgc, Ensemble** ensDataPtr)); static int CreateEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp, Ensemble *ensData, CONST char* partName, EnsemblePart **ensPartPtr)); static void DeleteEnsemblePart _ANSI_ARGS_((EnsemblePart *ensPart)); static int FindEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp, Ensemble *ensData, CONST char* partName, EnsemblePart **rensPart)); static int FindEnsemblePartIndex _ANSI_ARGS_((Ensemble *ensData, CONST 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 (Tcl_GetObjType(itclEnsInvocType.name) == NULL) { Tcl_RegisterObjType(&itclEnsInvocType); } 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 */ CONST char* ensName; /* name of the new ensemble */ { CONST 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_AppendResult(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_AppendResult(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 */ CONST char* ensName; /* ensemble containing this part */ CONST char* partName; /* name of the new part */ CONST 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 */ { CONST 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_AppendResult(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 */ CONST char *ensName; /* ensemble containing the part */ CONST char *partName; /* name of the desired part */ Tcl_CmdInfo *infoPtr; /* returns: info associated with part */ { CONST 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 */ CONST char *ensName; /* name of the ensemble */ Tcl_Obj *objPtr; /* returns: summary of usage info */ { CONST 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 */ CONST 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; /* * Initialize non-NULL data only. This allows us to handle the * structure differences between versions better. */ cmdPtr = (Command *) ckalloc(sizeof(Command)); memset((VOID *) cmdPtr, 0, sizeof(Command)); cmdPtr->nsPtr = ((Command *) ensData->cmd)->nsPtr; cmdPtr->objProc = HandleEnsemble; cmdPtr->objClientData = (ClientData)ensData; cmdPtr->deleteProc = DeleteEnsemble; cmdPtr->deleteData = cmdPtr->objClientData; 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 */ CONST char* partName; /* name of the new part */ CONST 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); } /* * Initialize non-NULL data only. This allows us to handle the * structure differences between versions better. */ cmdPtr = (Command *) ckalloc(sizeof(Command)); memset((VOID *) cmdPtr, 0, sizeof(Command)); cmdPtr->nsPtr = ((Command *) ensData->cmd)->nsPtr; cmdPtr->objProc = objProc; cmdPtr->objClientData = (ClientData)clientData; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = (ClientData)clientData; 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 */ CONST 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_AppendResult(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_AppendResult(interp, "invalid ensemble name \"", pname, "\"", (char*)NULL); ckfree(pname); return TCL_ERROR; } cmdPtr = ensPart->cmdPtr; if (cmdPtr == NULL || cmdPtr->deleteProc != DeleteEnsemble) { Tcl_AppendResult(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 */ CONST 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_AppendResult(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 */ CONST 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 */ CONST 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; 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_AppendResult(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) { Tcl_Panic("Itcl_EnsembleCmd: can't create ensemble"); } } cmdPtr = (Command*)ensPart->cmdPtr; if (cmdPtr->deleteProc != DeleteEnsemble) { Tcl_AppendResult(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_AppendResult(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) { status = Tcl_EvalObj(ensInfo->parser, objv[2]); } else if (objc > 3) { objPtr = Tcl_NewListObj(objc-2, objv+2); Tcl_IncrRefCount(objPtr); /* stop Eval trashing it */ status = Tcl_EvalObj(ensInfo->parser, objPtr); 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) { CONST 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)", Tcl_GetErrorLine(ensInfo->parser)); 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_AppendResult(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); Tcl_IncrRefCount(objPtr); 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, length); /* * 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; } itcl3.4.1/generic/itclStubInit.c0000644003604700454610000001257011610066043015172 0ustar dgp891div/* * itclStubInit.c -- * * This file contains the initializers for the Itcl stub vectors. * * Copyright (c) 1998-1999 by XXX * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "itclInt.h" /* * Remove macros that will interfere with the definitions below. */ /* * WARNING: The contents of this file is automatically generated by the * tools/genStubs.tcl script. Any modifications to the function declarations * below should be made in the generic/tcl.decls script. */ /* !BEGIN!: Do not edit below this line. */ ItclIntStubs itclIntStubs = { TCL_STUB_MAGIC, NULL, Itcl_IsClassNamespace, /* 0 */ Itcl_IsClass, /* 1 */ Itcl_FindClass, /* 2 */ Itcl_FindObject, /* 3 */ Itcl_IsObject, /* 4 */ Itcl_ObjectIsa, /* 5 */ Itcl_Protection, /* 6 */ Itcl_ProtectionStr, /* 7 */ Itcl_CanAccess, /* 8 */ Itcl_CanAccessFunc, /* 9 */ Itcl_GetTrueNamespace, /* 10 */ Itcl_ParseNamespPath, /* 11 */ Itcl_DecodeScopedCommand, /* 12 */ Itcl_EvalArgs, /* 13 */ Itcl_CreateArgs, /* 14 */ Itcl_PushContext, /* 15 */ Itcl_PopContext, /* 16 */ Itcl_GetContext, /* 17 */ Itcl_InitHierIter, /* 18 */ Itcl_DeleteHierIter, /* 19 */ Itcl_AdvanceHierIter, /* 20 */ Itcl_FindClassesCmd, /* 21 */ Itcl_FindObjectsCmd, /* 22 */ Itcl_ProtectionCmd, /* 23 */ Itcl_DelClassCmd, /* 24 */ Itcl_DelObjectCmd, /* 25 */ Itcl_ScopeCmd, /* 26 */ Itcl_CodeCmd, /* 27 */ Itcl_StubCreateCmd, /* 28 */ Itcl_StubExistsCmd, /* 29 */ Itcl_IsStub, /* 30 */ Itcl_CreateClass, /* 31 */ Itcl_DeleteClass, /* 32 */ Itcl_FindClassNamespace, /* 33 */ Itcl_HandleClass, /* 34 */ Itcl_ClassCmdResolver, /* 35 */ Itcl_ClassVarResolver, /* 36 */ Itcl_ClassCompiledVarResolver, /* 37 */ Itcl_BuildVirtualTables, /* 38 */ Itcl_CreateVarDefn, /* 39 */ Itcl_DeleteVarDefn, /* 40 */ Itcl_GetCommonVar, /* 41 */ Itcl_CreateMember, /* 42 */ Itcl_DeleteMember, /* 43 */ Itcl_CreateObject, /* 44 */ Itcl_DeleteObject, /* 45 */ Itcl_DestructObject, /* 46 */ Itcl_HandleInstance, /* 47 */ Itcl_GetInstanceVar, /* 48 */ Itcl_ScopedVarResolver, /* 49 */ Itcl_BodyCmd, /* 50 */ Itcl_ConfigBodyCmd, /* 51 */ Itcl_CreateMethod, /* 52 */ Itcl_CreateProc, /* 53 */ Itcl_CreateMemberFunc, /* 54 */ Itcl_ChangeMemberFunc, /* 55 */ Itcl_DeleteMemberFunc, /* 56 */ Itcl_CreateMemberCode, /* 57 */ Itcl_DeleteMemberCode, /* 58 */ Itcl_GetMemberCode, /* 59 */ NULL, /* 60 */ Itcl_EvalMemberCode, /* 61 */ Itcl_CreateArgList, /* 62 */ Itcl_CreateArg, /* 63 */ Itcl_DeleteArgList, /* 64 */ Itcl_ArgList, /* 65 */ Itcl_EquivArgLists, /* 66 */ Itcl_GetMemberFuncUsage, /* 67 */ Itcl_ExecMethod, /* 68 */ Itcl_ExecProc, /* 69 */ Itcl_AssignArgs, /* 70 */ Itcl_ConstructBase, /* 71 */ Itcl_InvokeMethodIfExists, /* 72 */ NULL, /* 73 */ Itcl_ReportFuncErrors, /* 74 */ Itcl_ParseInit, /* 75 */ Itcl_ClassCmd, /* 76 */ Itcl_ClassInheritCmd, /* 77 */ Itcl_ClassProtectionCmd, /* 78 */ Itcl_ClassConstructorCmd, /* 79 */ Itcl_ClassDestructorCmd, /* 80 */ Itcl_ClassMethodCmd, /* 81 */ Itcl_ClassProcCmd, /* 82 */ Itcl_ClassVariableCmd, /* 83 */ Itcl_ClassCommonCmd, /* 84 */ Itcl_ParseVarResolver, /* 85 */ Itcl_BiInit, /* 86 */ Itcl_InstallBiMethods, /* 87 */ Itcl_BiIsaCmd, /* 88 */ Itcl_BiConfigureCmd, /* 89 */ Itcl_BiCgetCmd, /* 90 */ Itcl_BiChainCmd, /* 91 */ Itcl_BiInfoClassCmd, /* 92 */ Itcl_BiInfoInheritCmd, /* 93 */ Itcl_BiInfoHeritageCmd, /* 94 */ Itcl_BiInfoFunctionCmd, /* 95 */ Itcl_BiInfoVariableCmd, /* 96 */ Itcl_BiInfoBodyCmd, /* 97 */ Itcl_BiInfoArgsCmd, /* 98 */ Itcl_DefaultInfoCmd, /* 99 */ Itcl_EnsembleInit, /* 100 */ Itcl_CreateEnsemble, /* 101 */ Itcl_AddEnsemblePart, /* 102 */ Itcl_GetEnsemblePart, /* 103 */ Itcl_IsEnsemble, /* 104 */ Itcl_GetEnsembleUsage, /* 105 */ Itcl_GetEnsembleUsageForObj, /* 106 */ Itcl_EnsembleCmd, /* 107 */ Itcl_EnsPartCmd, /* 108 */ Itcl_EnsembleErrorCmd, /* 109 */ NULL, /* 110 */ NULL, /* 111 */ _Tcl_GetCallFrame, /* 112 */ _Tcl_ActivateCallFrame, /* 113 */ _TclNewVar, /* 114 */ Itcl_Assert, /* 115 */ Itcl_IsObjectCmd, /* 116 */ Itcl_IsClassCmd, /* 117 */ }; static ItclStubHooks itclStubHooks = { &itclIntStubs }; ItclStubs itclStubs = { TCL_STUB_MAGIC, &itclStubHooks, Itcl_Init, /* 0 */ Itcl_SafeInit, /* 1 */ Itcl_RegisterC, /* 2 */ Itcl_RegisterObjC, /* 3 */ Itcl_FindC, /* 4 */ Itcl_InitStack, /* 5 */ Itcl_DeleteStack, /* 6 */ Itcl_PushStack, /* 7 */ Itcl_PopStack, /* 8 */ Itcl_PeekStack, /* 9 */ Itcl_GetStackValue, /* 10 */ Itcl_InitList, /* 11 */ Itcl_DeleteList, /* 12 */ Itcl_CreateListElem, /* 13 */ Itcl_DeleteListElem, /* 14 */ Itcl_InsertList, /* 15 */ Itcl_InsertListElem, /* 16 */ Itcl_AppendList, /* 17 */ Itcl_AppendListElem, /* 18 */ Itcl_SetListValue, /* 19 */ Itcl_EventuallyFree, /* 20 */ Itcl_PreserveData, /* 21 */ Itcl_ReleaseData, /* 22 */ Itcl_SaveInterpState, /* 23 */ Itcl_RestoreInterpState, /* 24 */ Itcl_DiscardInterpState, /* 25 */ }; /* !END!: Do not edit above this line. */ itcl3.4.1/generic/itclIntDecls.h0000644003604700454610000014727711610066043015160 0ustar dgp891div/* * itclIntDecls.h -- * * This file contains the declarations for all unsupported * functions that are exported by the Tcl library. These * interfaces are not guaranteed to remain the same between * versions. Use at your own risk. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _ITCLINTDECLS #define _ITCLINTDECLS /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made * in the itcl/generic/tclInt.decls script. */ /* !BEGIN!: Do not edit below this line. */ /* * Exported function declarations: */ #ifndef Itcl_IsClassNamespace_TCL_DECLARED #define Itcl_IsClassNamespace_TCL_DECLARED /* 0 */ TCL_EXTERN(int) Itcl_IsClassNamespace _ANSI_ARGS_(( Tcl_Namespace * namesp)); #endif #ifndef Itcl_IsClass_TCL_DECLARED #define Itcl_IsClass_TCL_DECLARED /* 1 */ TCL_EXTERN(int) Itcl_IsClass _ANSI_ARGS_((Tcl_Command cmd)); #endif #ifndef Itcl_FindClass_TCL_DECLARED #define Itcl_FindClass_TCL_DECLARED /* 2 */ TCL_EXTERN(ItclClass*) Itcl_FindClass _ANSI_ARGS_((Tcl_Interp* interp, CONST char* path, int autoload)); #endif #ifndef Itcl_FindObject_TCL_DECLARED #define Itcl_FindObject_TCL_DECLARED /* 3 */ TCL_EXTERN(int) Itcl_FindObject _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ItclObject ** roPtr)); #endif #ifndef Itcl_IsObject_TCL_DECLARED #define Itcl_IsObject_TCL_DECLARED /* 4 */ TCL_EXTERN(int) Itcl_IsObject _ANSI_ARGS_((Tcl_Command cmd)); #endif #ifndef Itcl_ObjectIsa_TCL_DECLARED #define Itcl_ObjectIsa_TCL_DECLARED /* 5 */ TCL_EXTERN(int) Itcl_ObjectIsa _ANSI_ARGS_((ItclObject * contextObj, ItclClass * cdefn)); #endif #ifndef Itcl_Protection_TCL_DECLARED #define Itcl_Protection_TCL_DECLARED /* 6 */ TCL_EXTERN(int) Itcl_Protection _ANSI_ARGS_((Tcl_Interp * interp, int newLevel)); #endif #ifndef Itcl_ProtectionStr_TCL_DECLARED #define Itcl_ProtectionStr_TCL_DECLARED /* 7 */ TCL_EXTERN(char*) Itcl_ProtectionStr _ANSI_ARGS_((int pLevel)); #endif #ifndef Itcl_CanAccess_TCL_DECLARED #define Itcl_CanAccess_TCL_DECLARED /* 8 */ TCL_EXTERN(int) Itcl_CanAccess _ANSI_ARGS_((ItclMember* memberPtr, Tcl_Namespace* fromNsPtr)); #endif #ifndef Itcl_CanAccessFunc_TCL_DECLARED #define Itcl_CanAccessFunc_TCL_DECLARED /* 9 */ TCL_EXTERN(int) Itcl_CanAccessFunc _ANSI_ARGS_(( ItclMemberFunc* mfunc, Tcl_Namespace* fromNsPtr)); #endif #ifndef Itcl_GetTrueNamespace_TCL_DECLARED #define Itcl_GetTrueNamespace_TCL_DECLARED /* 10 */ TCL_EXTERN(Tcl_Namespace*) Itcl_GetTrueNamespace _ANSI_ARGS_(( Tcl_Interp * interp, ItclObjectInfo * info)); #endif #ifndef Itcl_ParseNamespPath_TCL_DECLARED #define Itcl_ParseNamespPath_TCL_DECLARED /* 11 */ TCL_EXTERN(void) Itcl_ParseNamespPath _ANSI_ARGS_((CONST char * name, Tcl_DString * buffer, char ** head, char ** tail)); #endif #ifndef Itcl_DecodeScopedCommand_TCL_DECLARED #define Itcl_DecodeScopedCommand_TCL_DECLARED /* 12 */ TCL_EXTERN(int) Itcl_DecodeScopedCommand _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * name, Tcl_Namespace ** rNsPtr, char ** rCmdPtr)); #endif #ifndef Itcl_EvalArgs_TCL_DECLARED #define Itcl_EvalArgs_TCL_DECLARED /* 13 */ TCL_EXTERN(int) Itcl_EvalArgs _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_CreateArgs_TCL_DECLARED #define Itcl_CreateArgs_TCL_DECLARED /* 14 */ TCL_EXTERN(Tcl_Obj*) Itcl_CreateArgs _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_PushContext_TCL_DECLARED #define Itcl_PushContext_TCL_DECLARED /* 15 */ TCL_EXTERN(int) Itcl_PushContext _ANSI_ARGS_((Tcl_Interp * interp, ItclMember * member, ItclClass * contextClass, ItclObject * contextObj, ItclContext * contextPtr)); #endif #ifndef Itcl_PopContext_TCL_DECLARED #define Itcl_PopContext_TCL_DECLARED /* 16 */ TCL_EXTERN(void) Itcl_PopContext _ANSI_ARGS_((Tcl_Interp * interp, ItclContext * contextPtr)); #endif #ifndef Itcl_GetContext_TCL_DECLARED #define Itcl_GetContext_TCL_DECLARED /* 17 */ TCL_EXTERN(int) Itcl_GetContext _ANSI_ARGS_((Tcl_Interp * interp, ItclClass ** cdefnPtr, ItclObject ** odefnPtr)); #endif #ifndef Itcl_InitHierIter_TCL_DECLARED #define Itcl_InitHierIter_TCL_DECLARED /* 18 */ TCL_EXTERN(void) Itcl_InitHierIter _ANSI_ARGS_((ItclHierIter * iter, ItclClass * cdefn)); #endif #ifndef Itcl_DeleteHierIter_TCL_DECLARED #define Itcl_DeleteHierIter_TCL_DECLARED /* 19 */ TCL_EXTERN(void) Itcl_DeleteHierIter _ANSI_ARGS_((ItclHierIter * iter)); #endif #ifndef Itcl_AdvanceHierIter_TCL_DECLARED #define Itcl_AdvanceHierIter_TCL_DECLARED /* 20 */ TCL_EXTERN(ItclClass*) Itcl_AdvanceHierIter _ANSI_ARGS_(( ItclHierIter * iter)); #endif #ifndef Itcl_FindClassesCmd_TCL_DECLARED #define Itcl_FindClassesCmd_TCL_DECLARED /* 21 */ TCL_EXTERN(int) Itcl_FindClassesCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_FindObjectsCmd_TCL_DECLARED #define Itcl_FindObjectsCmd_TCL_DECLARED /* 22 */ TCL_EXTERN(int) Itcl_FindObjectsCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ProtectionCmd_TCL_DECLARED #define Itcl_ProtectionCmd_TCL_DECLARED /* 23 */ TCL_EXTERN(int) Itcl_ProtectionCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_DelClassCmd_TCL_DECLARED #define Itcl_DelClassCmd_TCL_DECLARED /* 24 */ TCL_EXTERN(int) Itcl_DelClassCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_DelObjectCmd_TCL_DECLARED #define Itcl_DelObjectCmd_TCL_DECLARED /* 25 */ TCL_EXTERN(int) Itcl_DelObjectCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ScopeCmd_TCL_DECLARED #define Itcl_ScopeCmd_TCL_DECLARED /* 26 */ TCL_EXTERN(int) Itcl_ScopeCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_CodeCmd_TCL_DECLARED #define Itcl_CodeCmd_TCL_DECLARED /* 27 */ TCL_EXTERN(int) Itcl_CodeCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_StubCreateCmd_TCL_DECLARED #define Itcl_StubCreateCmd_TCL_DECLARED /* 28 */ TCL_EXTERN(int) Itcl_StubCreateCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_StubExistsCmd_TCL_DECLARED #define Itcl_StubExistsCmd_TCL_DECLARED /* 29 */ TCL_EXTERN(int) Itcl_StubExistsCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_IsStub_TCL_DECLARED #define Itcl_IsStub_TCL_DECLARED /* 30 */ TCL_EXTERN(int) Itcl_IsStub _ANSI_ARGS_((Tcl_Command cmd)); #endif #ifndef Itcl_CreateClass_TCL_DECLARED #define Itcl_CreateClass_TCL_DECLARED /* 31 */ TCL_EXTERN(int) Itcl_CreateClass _ANSI_ARGS_((Tcl_Interp* interp, CONST char* path, ItclObjectInfo * info, ItclClass ** rPtr)); #endif #ifndef Itcl_DeleteClass_TCL_DECLARED #define Itcl_DeleteClass_TCL_DECLARED /* 32 */ TCL_EXTERN(int) Itcl_DeleteClass _ANSI_ARGS_((Tcl_Interp * interp, ItclClass * cdefnPtr)); #endif #ifndef Itcl_FindClassNamespace_TCL_DECLARED #define Itcl_FindClassNamespace_TCL_DECLARED /* 33 */ TCL_EXTERN(Tcl_Namespace*) Itcl_FindClassNamespace _ANSI_ARGS_(( Tcl_Interp* interp, CONST char* path)); #endif #ifndef Itcl_HandleClass_TCL_DECLARED #define Itcl_HandleClass_TCL_DECLARED /* 34 */ TCL_EXTERN(int) Itcl_HandleClass _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassCmdResolver_TCL_DECLARED #define Itcl_ClassCmdResolver_TCL_DECLARED /* 35 */ TCL_EXTERN(int) Itcl_ClassCmdResolver _ANSI_ARGS_(( Tcl_Interp * interp, CONST char* name, Tcl_Namespace * context, int flags, Tcl_Command * rPtr)); #endif #ifndef Itcl_ClassVarResolver_TCL_DECLARED #define Itcl_ClassVarResolver_TCL_DECLARED /* 36 */ TCL_EXTERN(int) Itcl_ClassVarResolver _ANSI_ARGS_(( Tcl_Interp * interp, CONST char* name, Tcl_Namespace * context, int flags, Tcl_Var * rPtr)); #endif #ifndef Itcl_ClassCompiledVarResolver_TCL_DECLARED #define Itcl_ClassCompiledVarResolver_TCL_DECLARED /* 37 */ TCL_EXTERN(int) Itcl_ClassCompiledVarResolver _ANSI_ARGS_(( Tcl_Interp * interp, CONST char* name, int length, Tcl_Namespace * context, Tcl_ResolvedVarInfo ** rPtr)); #endif #ifndef Itcl_BuildVirtualTables_TCL_DECLARED #define Itcl_BuildVirtualTables_TCL_DECLARED /* 38 */ TCL_EXTERN(void) Itcl_BuildVirtualTables _ANSI_ARGS_(( ItclClass* cdefnPtr)); #endif #ifndef Itcl_CreateVarDefn_TCL_DECLARED #define Itcl_CreateVarDefn_TCL_DECLARED /* 39 */ TCL_EXTERN(int) Itcl_CreateVarDefn _ANSI_ARGS_((Tcl_Interp * interp, ItclClass* cdefn, char* name, char* init, char* config, ItclVarDefn** vdefnPtr)); #endif #ifndef Itcl_DeleteVarDefn_TCL_DECLARED #define Itcl_DeleteVarDefn_TCL_DECLARED /* 40 */ TCL_EXTERN(void) Itcl_DeleteVarDefn _ANSI_ARGS_((ItclVarDefn * vdefn)); #endif #ifndef Itcl_GetCommonVar_TCL_DECLARED #define Itcl_GetCommonVar_TCL_DECLARED /* 41 */ TCL_EXTERN(CONST char*) Itcl_GetCommonVar _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ItclClass * contextClass)); #endif #ifndef Itcl_CreateMember_TCL_DECLARED #define Itcl_CreateMember_TCL_DECLARED /* 42 */ TCL_EXTERN(ItclMember*) Itcl_CreateMember _ANSI_ARGS_((Tcl_Interp* interp, ItclClass * cdefn, CONST char* name)); #endif #ifndef Itcl_DeleteMember_TCL_DECLARED #define Itcl_DeleteMember_TCL_DECLARED /* 43 */ TCL_EXTERN(void) Itcl_DeleteMember _ANSI_ARGS_((ItclMember * memPtr)); #endif #ifndef Itcl_CreateObject_TCL_DECLARED #define Itcl_CreateObject_TCL_DECLARED /* 44 */ TCL_EXTERN(int) Itcl_CreateObject _ANSI_ARGS_((Tcl_Interp * interp, CONST char* name, ItclClass * cdefn, int objc, Tcl_Obj *CONST objv[], ItclObject ** roPtr)); #endif #ifndef Itcl_DeleteObject_TCL_DECLARED #define Itcl_DeleteObject_TCL_DECLARED /* 45 */ TCL_EXTERN(int) Itcl_DeleteObject _ANSI_ARGS_((Tcl_Interp * interp, ItclObject * contextObj)); #endif #ifndef Itcl_DestructObject_TCL_DECLARED #define Itcl_DestructObject_TCL_DECLARED /* 46 */ TCL_EXTERN(int) Itcl_DestructObject _ANSI_ARGS_((Tcl_Interp * interp, ItclObject * contextObj, int flags)); #endif #ifndef Itcl_HandleInstance_TCL_DECLARED #define Itcl_HandleInstance_TCL_DECLARED /* 47 */ TCL_EXTERN(int) Itcl_HandleInstance _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_GetInstanceVar_TCL_DECLARED #define Itcl_GetInstanceVar_TCL_DECLARED /* 48 */ TCL_EXTERN(CONST char*) Itcl_GetInstanceVar _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * name, ItclObject * contextObj, ItclClass * contextClass)); #endif #ifndef Itcl_ScopedVarResolver_TCL_DECLARED #define Itcl_ScopedVarResolver_TCL_DECLARED /* 49 */ TCL_EXTERN(int) Itcl_ScopedVarResolver _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNs, int flags, Tcl_Var * rPtr)); #endif #ifndef Itcl_BodyCmd_TCL_DECLARED #define Itcl_BodyCmd_TCL_DECLARED /* 50 */ TCL_EXTERN(int) Itcl_BodyCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ConfigBodyCmd_TCL_DECLARED #define Itcl_ConfigBodyCmd_TCL_DECLARED /* 51 */ TCL_EXTERN(int) Itcl_ConfigBodyCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_CreateMethod_TCL_DECLARED #define Itcl_CreateMethod_TCL_DECLARED /* 52 */ TCL_EXTERN(int) Itcl_CreateMethod _ANSI_ARGS_((Tcl_Interp* interp, ItclClass * cdefn, CONST char* name, CONST char* arglist, CONST char* body)); #endif #ifndef Itcl_CreateProc_TCL_DECLARED #define Itcl_CreateProc_TCL_DECLARED /* 53 */ TCL_EXTERN(int) Itcl_CreateProc _ANSI_ARGS_((Tcl_Interp* interp, ItclClass * cdefn, CONST char* name, CONST char* arglist, CONST char* body)); #endif #ifndef Itcl_CreateMemberFunc_TCL_DECLARED #define Itcl_CreateMemberFunc_TCL_DECLARED /* 54 */ TCL_EXTERN(int) Itcl_CreateMemberFunc _ANSI_ARGS_(( Tcl_Interp* interp, ItclClass * cdefn, CONST char* name, CONST char* arglist, CONST char* body, ItclMemberFunc** mfuncPtr)); #endif #ifndef Itcl_ChangeMemberFunc_TCL_DECLARED #define Itcl_ChangeMemberFunc_TCL_DECLARED /* 55 */ TCL_EXTERN(int) Itcl_ChangeMemberFunc _ANSI_ARGS_(( Tcl_Interp* interp, ItclMemberFunc* mfunc, CONST char* arglist, CONST char* body)); #endif #ifndef Itcl_DeleteMemberFunc_TCL_DECLARED #define Itcl_DeleteMemberFunc_TCL_DECLARED /* 56 */ TCL_EXTERN(void) Itcl_DeleteMemberFunc _ANSI_ARGS_((CONST char* cdata)); #endif #ifndef Itcl_CreateMemberCode_TCL_DECLARED #define Itcl_CreateMemberCode_TCL_DECLARED /* 57 */ TCL_EXTERN(int) Itcl_CreateMemberCode _ANSI_ARGS_(( Tcl_Interp* interp, ItclClass * cdefn, CONST char* arglist, CONST char* body, ItclMemberCode** mcodePtr)); #endif #ifndef Itcl_DeleteMemberCode_TCL_DECLARED #define Itcl_DeleteMemberCode_TCL_DECLARED /* 58 */ TCL_EXTERN(void) Itcl_DeleteMemberCode _ANSI_ARGS_((CONST char* cdata)); #endif #ifndef Itcl_GetMemberCode_TCL_DECLARED #define Itcl_GetMemberCode_TCL_DECLARED /* 59 */ TCL_EXTERN(int) Itcl_GetMemberCode _ANSI_ARGS_((Tcl_Interp* interp, ItclMember* member)); #endif /* Slot 60 is reserved */ #ifndef Itcl_EvalMemberCode_TCL_DECLARED #define Itcl_EvalMemberCode_TCL_DECLARED /* 61 */ TCL_EXTERN(int) Itcl_EvalMemberCode _ANSI_ARGS_((Tcl_Interp * interp, ItclMemberFunc * mfunc, ItclMember * member, ItclObject * contextObj, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_CreateArgList_TCL_DECLARED #define Itcl_CreateArgList_TCL_DECLARED /* 62 */ TCL_EXTERN(int) Itcl_CreateArgList _ANSI_ARGS_((Tcl_Interp* interp, CONST char* decl, int* argcPtr, CompiledLocal** argPtr)); #endif #ifndef Itcl_CreateArg_TCL_DECLARED #define Itcl_CreateArg_TCL_DECLARED /* 63 */ TCL_EXTERN(CompiledLocal*) Itcl_CreateArg _ANSI_ARGS_((CONST char* name, CONST char* init)); #endif #ifndef Itcl_DeleteArgList_TCL_DECLARED #define Itcl_DeleteArgList_TCL_DECLARED /* 64 */ TCL_EXTERN(void) Itcl_DeleteArgList _ANSI_ARGS_(( CompiledLocal * arglist)); #endif #ifndef Itcl_ArgList_TCL_DECLARED #define Itcl_ArgList_TCL_DECLARED /* 65 */ TCL_EXTERN(Tcl_Obj*) Itcl_ArgList _ANSI_ARGS_((int argc, CompiledLocal* arglist)); #endif #ifndef Itcl_EquivArgLists_TCL_DECLARED #define Itcl_EquivArgLists_TCL_DECLARED /* 66 */ TCL_EXTERN(int) Itcl_EquivArgLists _ANSI_ARGS_((CompiledLocal* arg1, int arg1c, CompiledLocal* arg2, int arg2c)); #endif #ifndef Itcl_GetMemberFuncUsage_TCL_DECLARED #define Itcl_GetMemberFuncUsage_TCL_DECLARED /* 67 */ TCL_EXTERN(void) Itcl_GetMemberFuncUsage _ANSI_ARGS_(( ItclMemberFunc * mfunc, ItclObject * contextObj, Tcl_Obj * objPtr)); #endif #ifndef Itcl_ExecMethod_TCL_DECLARED #define Itcl_ExecMethod_TCL_DECLARED /* 68 */ TCL_EXTERN(int) Itcl_ExecMethod _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ExecProc_TCL_DECLARED #define Itcl_ExecProc_TCL_DECLARED /* 69 */ TCL_EXTERN(int) Itcl_ExecProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_AssignArgs_TCL_DECLARED #define Itcl_AssignArgs_TCL_DECLARED /* 70 */ TCL_EXTERN(int) Itcl_AssignArgs _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], ItclMemberFunc * mfunc)); #endif #ifndef Itcl_ConstructBase_TCL_DECLARED #define Itcl_ConstructBase_TCL_DECLARED /* 71 */ TCL_EXTERN(int) Itcl_ConstructBase _ANSI_ARGS_((Tcl_Interp * interp, ItclObject * contextObj, ItclClass * contextClass)); #endif #ifndef Itcl_InvokeMethodIfExists_TCL_DECLARED #define Itcl_InvokeMethodIfExists_TCL_DECLARED /* 72 */ TCL_EXTERN(int) Itcl_InvokeMethodIfExists _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * name, ItclClass * contextClass, ItclObject * contextObj, int objc, Tcl_Obj *CONST objv[])); #endif /* Slot 73 is reserved */ #ifndef Itcl_ReportFuncErrors_TCL_DECLARED #define Itcl_ReportFuncErrors_TCL_DECLARED /* 74 */ TCL_EXTERN(int) Itcl_ReportFuncErrors _ANSI_ARGS_(( Tcl_Interp* interp, ItclMemberFunc * mfunc, ItclObject * contextObj, int result)); #endif #ifndef Itcl_ParseInit_TCL_DECLARED #define Itcl_ParseInit_TCL_DECLARED /* 75 */ TCL_EXTERN(int) Itcl_ParseInit _ANSI_ARGS_((Tcl_Interp * interp, ItclObjectInfo * info)); #endif #ifndef Itcl_ClassCmd_TCL_DECLARED #define Itcl_ClassCmd_TCL_DECLARED /* 76 */ TCL_EXTERN(int) Itcl_ClassCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassInheritCmd_TCL_DECLARED #define Itcl_ClassInheritCmd_TCL_DECLARED /* 77 */ TCL_EXTERN(int) Itcl_ClassInheritCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassProtectionCmd_TCL_DECLARED #define Itcl_ClassProtectionCmd_TCL_DECLARED /* 78 */ TCL_EXTERN(int) Itcl_ClassProtectionCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassConstructorCmd_TCL_DECLARED #define Itcl_ClassConstructorCmd_TCL_DECLARED /* 79 */ TCL_EXTERN(int) Itcl_ClassConstructorCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassDestructorCmd_TCL_DECLARED #define Itcl_ClassDestructorCmd_TCL_DECLARED /* 80 */ TCL_EXTERN(int) Itcl_ClassDestructorCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassMethodCmd_TCL_DECLARED #define Itcl_ClassMethodCmd_TCL_DECLARED /* 81 */ TCL_EXTERN(int) Itcl_ClassMethodCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassProcCmd_TCL_DECLARED #define Itcl_ClassProcCmd_TCL_DECLARED /* 82 */ TCL_EXTERN(int) Itcl_ClassProcCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassVariableCmd_TCL_DECLARED #define Itcl_ClassVariableCmd_TCL_DECLARED /* 83 */ TCL_EXTERN(int) Itcl_ClassVariableCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassCommonCmd_TCL_DECLARED #define Itcl_ClassCommonCmd_TCL_DECLARED /* 84 */ TCL_EXTERN(int) Itcl_ClassCommonCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ParseVarResolver_TCL_DECLARED #define Itcl_ParseVarResolver_TCL_DECLARED /* 85 */ TCL_EXTERN(int) Itcl_ParseVarResolver _ANSI_ARGS_(( Tcl_Interp * interp, CONST char* name, Tcl_Namespace * contextNs, int flags, Tcl_Var* rPtr)); #endif #ifndef Itcl_BiInit_TCL_DECLARED #define Itcl_BiInit_TCL_DECLARED /* 86 */ TCL_EXTERN(int) Itcl_BiInit _ANSI_ARGS_((Tcl_Interp * interp)); #endif #ifndef Itcl_InstallBiMethods_TCL_DECLARED #define Itcl_InstallBiMethods_TCL_DECLARED /* 87 */ TCL_EXTERN(int) Itcl_InstallBiMethods _ANSI_ARGS_(( Tcl_Interp * interp, ItclClass * cdefn)); #endif #ifndef Itcl_BiIsaCmd_TCL_DECLARED #define Itcl_BiIsaCmd_TCL_DECLARED /* 88 */ TCL_EXTERN(int) Itcl_BiIsaCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiConfigureCmd_TCL_DECLARED #define Itcl_BiConfigureCmd_TCL_DECLARED /* 89 */ TCL_EXTERN(int) Itcl_BiConfigureCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiCgetCmd_TCL_DECLARED #define Itcl_BiCgetCmd_TCL_DECLARED /* 90 */ TCL_EXTERN(int) Itcl_BiCgetCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiChainCmd_TCL_DECLARED #define Itcl_BiChainCmd_TCL_DECLARED /* 91 */ TCL_EXTERN(int) Itcl_BiChainCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiInfoClassCmd_TCL_DECLARED #define Itcl_BiInfoClassCmd_TCL_DECLARED /* 92 */ TCL_EXTERN(int) Itcl_BiInfoClassCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiInfoInheritCmd_TCL_DECLARED #define Itcl_BiInfoInheritCmd_TCL_DECLARED /* 93 */ TCL_EXTERN(int) Itcl_BiInfoInheritCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiInfoHeritageCmd_TCL_DECLARED #define Itcl_BiInfoHeritageCmd_TCL_DECLARED /* 94 */ TCL_EXTERN(int) Itcl_BiInfoHeritageCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiInfoFunctionCmd_TCL_DECLARED #define Itcl_BiInfoFunctionCmd_TCL_DECLARED /* 95 */ TCL_EXTERN(int) Itcl_BiInfoFunctionCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiInfoVariableCmd_TCL_DECLARED #define Itcl_BiInfoVariableCmd_TCL_DECLARED /* 96 */ TCL_EXTERN(int) Itcl_BiInfoVariableCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiInfoBodyCmd_TCL_DECLARED #define Itcl_BiInfoBodyCmd_TCL_DECLARED /* 97 */ TCL_EXTERN(int) Itcl_BiInfoBodyCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiInfoArgsCmd_TCL_DECLARED #define Itcl_BiInfoArgsCmd_TCL_DECLARED /* 98 */ TCL_EXTERN(int) Itcl_BiInfoArgsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_DefaultInfoCmd_TCL_DECLARED #define Itcl_DefaultInfoCmd_TCL_DECLARED /* 99 */ TCL_EXTERN(int) Itcl_DefaultInfoCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_EnsembleInit_TCL_DECLARED #define Itcl_EnsembleInit_TCL_DECLARED /* 100 */ TCL_EXTERN(int) Itcl_EnsembleInit _ANSI_ARGS_((Tcl_Interp * interp)); #endif #ifndef Itcl_CreateEnsemble_TCL_DECLARED #define Itcl_CreateEnsemble_TCL_DECLARED /* 101 */ TCL_EXTERN(int) Itcl_CreateEnsemble _ANSI_ARGS_((Tcl_Interp * interp, CONST char* ensName)); #endif #ifndef Itcl_AddEnsemblePart_TCL_DECLARED #define Itcl_AddEnsemblePart_TCL_DECLARED /* 102 */ TCL_EXTERN(int) Itcl_AddEnsemblePart _ANSI_ARGS_(( Tcl_Interp * interp, CONST char* ensName, CONST char* partName, CONST char* usageInfo, Tcl_ObjCmdProc * objProc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); #endif #ifndef Itcl_GetEnsemblePart_TCL_DECLARED #define Itcl_GetEnsemblePart_TCL_DECLARED /* 103 */ TCL_EXTERN(int) Itcl_GetEnsemblePart _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * ensName, CONST char * partName, Tcl_CmdInfo * infoPtr)); #endif #ifndef Itcl_IsEnsemble_TCL_DECLARED #define Itcl_IsEnsemble_TCL_DECLARED /* 104 */ TCL_EXTERN(int) Itcl_IsEnsemble _ANSI_ARGS_((Tcl_CmdInfo* infoPtr)); #endif #ifndef Itcl_GetEnsembleUsage_TCL_DECLARED #define Itcl_GetEnsembleUsage_TCL_DECLARED /* 105 */ TCL_EXTERN(int) Itcl_GetEnsembleUsage _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * ensName, Tcl_Obj * objPtr)); #endif #ifndef Itcl_GetEnsembleUsageForObj_TCL_DECLARED #define Itcl_GetEnsembleUsageForObj_TCL_DECLARED /* 106 */ TCL_EXTERN(int) Itcl_GetEnsembleUsageForObj _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * ensObjPtr, Tcl_Obj * objPtr)); #endif #ifndef Itcl_EnsembleCmd_TCL_DECLARED #define Itcl_EnsembleCmd_TCL_DECLARED /* 107 */ TCL_EXTERN(int) Itcl_EnsembleCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_EnsPartCmd_TCL_DECLARED #define Itcl_EnsPartCmd_TCL_DECLARED /* 108 */ TCL_EXTERN(int) Itcl_EnsPartCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_EnsembleErrorCmd_TCL_DECLARED #define Itcl_EnsembleErrorCmd_TCL_DECLARED /* 109 */ TCL_EXTERN(int) Itcl_EnsembleErrorCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif /* Slot 110 is reserved */ /* Slot 111 is reserved */ #ifndef _Tcl_GetCallFrame_TCL_DECLARED #define _Tcl_GetCallFrame_TCL_DECLARED /* 112 */ TCL_EXTERN(Itcl_CallFrame*) _Tcl_GetCallFrame _ANSI_ARGS_(( Tcl_Interp * interp, int level)); #endif #ifndef _Tcl_ActivateCallFrame_TCL_DECLARED #define _Tcl_ActivateCallFrame_TCL_DECLARED /* 113 */ TCL_EXTERN(Itcl_CallFrame*) _Tcl_ActivateCallFrame _ANSI_ARGS_(( Tcl_Interp * interp, Itcl_CallFrame * framePtr)); #endif #ifndef _TclNewVar_TCL_DECLARED #define _TclNewVar_TCL_DECLARED /* 114 */ TCL_EXTERN(Var*) _TclNewVar _ANSI_ARGS_((void)); #endif #ifndef Itcl_Assert_TCL_DECLARED #define Itcl_Assert_TCL_DECLARED /* 115 */ TCL_EXTERN(void) Itcl_Assert _ANSI_ARGS_((CONST char * testExpr, CONST char * fileName, int lineNum)); #endif #ifndef Itcl_IsObjectCmd_TCL_DECLARED #define Itcl_IsObjectCmd_TCL_DECLARED /* 116 */ TCL_EXTERN(int) Itcl_IsObjectCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_IsClassCmd_TCL_DECLARED #define Itcl_IsClassCmd_TCL_DECLARED /* 117 */ TCL_EXTERN(int) Itcl_IsClassCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif typedef struct ItclIntStubs { int magic; struct ItclIntStubHooks *hooks; int (*itcl_IsClassNamespace) _ANSI_ARGS_((Tcl_Namespace * namesp)); /* 0 */ int (*itcl_IsClass) _ANSI_ARGS_((Tcl_Command cmd)); /* 1 */ ItclClass* (*itcl_FindClass) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* path, int autoload)); /* 2 */ int (*itcl_FindObject) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ItclObject ** roPtr)); /* 3 */ int (*itcl_IsObject) _ANSI_ARGS_((Tcl_Command cmd)); /* 4 */ int (*itcl_ObjectIsa) _ANSI_ARGS_((ItclObject * contextObj, ItclClass * cdefn)); /* 5 */ int (*itcl_Protection) _ANSI_ARGS_((Tcl_Interp * interp, int newLevel)); /* 6 */ char* (*itcl_ProtectionStr) _ANSI_ARGS_((int pLevel)); /* 7 */ int (*itcl_CanAccess) _ANSI_ARGS_((ItclMember* memberPtr, Tcl_Namespace* fromNsPtr)); /* 8 */ int (*itcl_CanAccessFunc) _ANSI_ARGS_((ItclMemberFunc* mfunc, Tcl_Namespace* fromNsPtr)); /* 9 */ Tcl_Namespace* (*itcl_GetTrueNamespace) _ANSI_ARGS_((Tcl_Interp * interp, ItclObjectInfo * info)); /* 10 */ void (*itcl_ParseNamespPath) _ANSI_ARGS_((CONST char * name, Tcl_DString * buffer, char ** head, char ** tail)); /* 11 */ int (*itcl_DecodeScopedCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace ** rNsPtr, char ** rCmdPtr)); /* 12 */ int (*itcl_EvalArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 13 */ Tcl_Obj* (*itcl_CreateArgs) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int objc, Tcl_Obj *CONST objv[])); /* 14 */ int (*itcl_PushContext) _ANSI_ARGS_((Tcl_Interp * interp, ItclMember * member, ItclClass * contextClass, ItclObject * contextObj, ItclContext * contextPtr)); /* 15 */ void (*itcl_PopContext) _ANSI_ARGS_((Tcl_Interp * interp, ItclContext * contextPtr)); /* 16 */ int (*itcl_GetContext) _ANSI_ARGS_((Tcl_Interp * interp, ItclClass ** cdefnPtr, ItclObject ** odefnPtr)); /* 17 */ void (*itcl_InitHierIter) _ANSI_ARGS_((ItclHierIter * iter, ItclClass * cdefn)); /* 18 */ void (*itcl_DeleteHierIter) _ANSI_ARGS_((ItclHierIter * iter)); /* 19 */ ItclClass* (*itcl_AdvanceHierIter) _ANSI_ARGS_((ItclHierIter * iter)); /* 20 */ int (*itcl_FindClassesCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 21 */ int (*itcl_FindObjectsCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 22 */ int (*itcl_ProtectionCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 23 */ int (*itcl_DelClassCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 24 */ int (*itcl_DelObjectCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 25 */ int (*itcl_ScopeCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 26 */ int (*itcl_CodeCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 27 */ int (*itcl_StubCreateCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 28 */ int (*itcl_StubExistsCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 29 */ int (*itcl_IsStub) _ANSI_ARGS_((Tcl_Command cmd)); /* 30 */ int (*itcl_CreateClass) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* path, ItclObjectInfo * info, ItclClass ** rPtr)); /* 31 */ int (*itcl_DeleteClass) _ANSI_ARGS_((Tcl_Interp * interp, ItclClass * cdefnPtr)); /* 32 */ Tcl_Namespace* (*itcl_FindClassNamespace) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* path)); /* 33 */ int (*itcl_HandleClass) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 34 */ int (*itcl_ClassCmdResolver) _ANSI_ARGS_((Tcl_Interp * interp, CONST char* name, Tcl_Namespace * context, int flags, Tcl_Command * rPtr)); /* 35 */ int (*itcl_ClassVarResolver) _ANSI_ARGS_((Tcl_Interp * interp, CONST char* name, Tcl_Namespace * context, int flags, Tcl_Var * rPtr)); /* 36 */ int (*itcl_ClassCompiledVarResolver) _ANSI_ARGS_((Tcl_Interp * interp, CONST char* name, int length, Tcl_Namespace * context, Tcl_ResolvedVarInfo ** rPtr)); /* 37 */ void (*itcl_BuildVirtualTables) _ANSI_ARGS_((ItclClass* cdefnPtr)); /* 38 */ int (*itcl_CreateVarDefn) _ANSI_ARGS_((Tcl_Interp * interp, ItclClass* cdefn, char* name, char* init, char* config, ItclVarDefn** vdefnPtr)); /* 39 */ void (*itcl_DeleteVarDefn) _ANSI_ARGS_((ItclVarDefn * vdefn)); /* 40 */ CONST char* (*itcl_GetCommonVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ItclClass * contextClass)); /* 41 */ ItclMember* (*itcl_CreateMember) _ANSI_ARGS_((Tcl_Interp* interp, ItclClass * cdefn, CONST char* name)); /* 42 */ void (*itcl_DeleteMember) _ANSI_ARGS_((ItclMember * memPtr)); /* 43 */ int (*itcl_CreateObject) _ANSI_ARGS_((Tcl_Interp * interp, CONST char* name, ItclClass * cdefn, int objc, Tcl_Obj *CONST objv[], ItclObject ** roPtr)); /* 44 */ int (*itcl_DeleteObject) _ANSI_ARGS_((Tcl_Interp * interp, ItclObject * contextObj)); /* 45 */ int (*itcl_DestructObject) _ANSI_ARGS_((Tcl_Interp * interp, ItclObject * contextObj, int flags)); /* 46 */ int (*itcl_HandleInstance) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 47 */ CONST char* (*itcl_GetInstanceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ItclObject * contextObj, ItclClass * contextClass)); /* 48 */ int (*itcl_ScopedVarResolver) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNs, int flags, Tcl_Var * rPtr)); /* 49 */ int (*itcl_BodyCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 50 */ int (*itcl_ConfigBodyCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 51 */ int (*itcl_CreateMethod) _ANSI_ARGS_((Tcl_Interp* interp, ItclClass * cdefn, CONST char* name, CONST char* arglist, CONST char* body)); /* 52 */ int (*itcl_CreateProc) _ANSI_ARGS_((Tcl_Interp* interp, ItclClass * cdefn, CONST char* name, CONST char* arglist, CONST char* body)); /* 53 */ int (*itcl_CreateMemberFunc) _ANSI_ARGS_((Tcl_Interp* interp, ItclClass * cdefn, CONST char* name, CONST char* arglist, CONST char* body, ItclMemberFunc** mfuncPtr)); /* 54 */ int (*itcl_ChangeMemberFunc) _ANSI_ARGS_((Tcl_Interp* interp, ItclMemberFunc* mfunc, CONST char* arglist, CONST char* body)); /* 55 */ void (*itcl_DeleteMemberFunc) _ANSI_ARGS_((CONST char* cdata)); /* 56 */ int (*itcl_CreateMemberCode) _ANSI_ARGS_((Tcl_Interp* interp, ItclClass * cdefn, CONST char* arglist, CONST char* body, ItclMemberCode** mcodePtr)); /* 57 */ void (*itcl_DeleteMemberCode) _ANSI_ARGS_((CONST char* cdata)); /* 58 */ int (*itcl_GetMemberCode) _ANSI_ARGS_((Tcl_Interp* interp, ItclMember* member)); /* 59 */ void *reserved60; int (*itcl_EvalMemberCode) _ANSI_ARGS_((Tcl_Interp * interp, ItclMemberFunc * mfunc, ItclMember * member, ItclObject * contextObj, int objc, Tcl_Obj *CONST objv[])); /* 61 */ int (*itcl_CreateArgList) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* decl, int* argcPtr, CompiledLocal** argPtr)); /* 62 */ CompiledLocal* (*itcl_CreateArg) _ANSI_ARGS_((CONST char* name, CONST char* init)); /* 63 */ void (*itcl_DeleteArgList) _ANSI_ARGS_((CompiledLocal * arglist)); /* 64 */ Tcl_Obj* (*itcl_ArgList) _ANSI_ARGS_((int argc, CompiledLocal* arglist)); /* 65 */ int (*itcl_EquivArgLists) _ANSI_ARGS_((CompiledLocal* arg1, int arg1c, CompiledLocal* arg2, int arg2c)); /* 66 */ void (*itcl_GetMemberFuncUsage) _ANSI_ARGS_((ItclMemberFunc * mfunc, ItclObject * contextObj, Tcl_Obj * objPtr)); /* 67 */ int (*itcl_ExecMethod) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 68 */ int (*itcl_ExecProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 69 */ int (*itcl_AssignArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], ItclMemberFunc * mfunc)); /* 70 */ int (*itcl_ConstructBase) _ANSI_ARGS_((Tcl_Interp * interp, ItclObject * contextObj, ItclClass * contextClass)); /* 71 */ int (*itcl_InvokeMethodIfExists) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ItclClass * contextClass, ItclObject * contextObj, int objc, Tcl_Obj *CONST objv[])); /* 72 */ void *reserved73; int (*itcl_ReportFuncErrors) _ANSI_ARGS_((Tcl_Interp* interp, ItclMemberFunc * mfunc, ItclObject * contextObj, int result)); /* 74 */ int (*itcl_ParseInit) _ANSI_ARGS_((Tcl_Interp * interp, ItclObjectInfo * info)); /* 75 */ int (*itcl_ClassCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 76 */ int (*itcl_ClassInheritCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 77 */ int (*itcl_ClassProtectionCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 78 */ int (*itcl_ClassConstructorCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 79 */ int (*itcl_ClassDestructorCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 80 */ int (*itcl_ClassMethodCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 81 */ int (*itcl_ClassProcCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 82 */ int (*itcl_ClassVariableCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 83 */ int (*itcl_ClassCommonCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 84 */ int (*itcl_ParseVarResolver) _ANSI_ARGS_((Tcl_Interp * interp, CONST char* name, Tcl_Namespace * contextNs, int flags, Tcl_Var* rPtr)); /* 85 */ int (*itcl_BiInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 86 */ int (*itcl_InstallBiMethods) _ANSI_ARGS_((Tcl_Interp * interp, ItclClass * cdefn)); /* 87 */ int (*itcl_BiIsaCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 88 */ int (*itcl_BiConfigureCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 89 */ int (*itcl_BiCgetCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 90 */ int (*itcl_BiChainCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 91 */ int (*itcl_BiInfoClassCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 92 */ int (*itcl_BiInfoInheritCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 93 */ int (*itcl_BiInfoHeritageCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 94 */ int (*itcl_BiInfoFunctionCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 95 */ int (*itcl_BiInfoVariableCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 96 */ int (*itcl_BiInfoBodyCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 97 */ int (*itcl_BiInfoArgsCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 98 */ int (*itcl_DefaultInfoCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 99 */ int (*itcl_EnsembleInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 100 */ int (*itcl_CreateEnsemble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char* ensName)); /* 101 */ int (*itcl_AddEnsemblePart) _ANSI_ARGS_((Tcl_Interp * interp, CONST char* ensName, CONST char* partName, CONST char* usageInfo, Tcl_ObjCmdProc * objProc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 102 */ int (*itcl_GetEnsemblePart) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * ensName, CONST char * partName, Tcl_CmdInfo * infoPtr)); /* 103 */ int (*itcl_IsEnsemble) _ANSI_ARGS_((Tcl_CmdInfo* infoPtr)); /* 104 */ int (*itcl_GetEnsembleUsage) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * ensName, Tcl_Obj * objPtr)); /* 105 */ int (*itcl_GetEnsembleUsageForObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * ensObjPtr, Tcl_Obj * objPtr)); /* 106 */ int (*itcl_EnsembleCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 107 */ int (*itcl_EnsPartCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 108 */ int (*itcl_EnsembleErrorCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 109 */ void *reserved110; void *reserved111; Itcl_CallFrame* (*_Tcl_GetCallFrame) _ANSI_ARGS_((Tcl_Interp * interp, int level)); /* 112 */ Itcl_CallFrame* (*_Tcl_ActivateCallFrame) _ANSI_ARGS_((Tcl_Interp * interp, Itcl_CallFrame * framePtr)); /* 113 */ Var* (*_TclNewVar) _ANSI_ARGS_((void)); /* 114 */ void (*itcl_Assert) _ANSI_ARGS_((CONST char * testExpr, CONST char * fileName, int lineNum)); /* 115 */ int (*itcl_IsObjectCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 116 */ int (*itcl_IsClassCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 117 */ } ItclIntStubs; TCL_EXTERNC ItclIntStubs *itclIntStubsPtr; #if defined(USE_ITCL_STUBS) && !defined(USE_ITCL_STUB_PROCS) /* * Inline function declarations: */ #ifndef Itcl_IsClassNamespace #define Itcl_IsClassNamespace \ (itclIntStubsPtr->itcl_IsClassNamespace) /* 0 */ #endif #ifndef Itcl_IsClass #define Itcl_IsClass \ (itclIntStubsPtr->itcl_IsClass) /* 1 */ #endif #ifndef Itcl_FindClass #define Itcl_FindClass \ (itclIntStubsPtr->itcl_FindClass) /* 2 */ #endif #ifndef Itcl_FindObject #define Itcl_FindObject \ (itclIntStubsPtr->itcl_FindObject) /* 3 */ #endif #ifndef Itcl_IsObject #define Itcl_IsObject \ (itclIntStubsPtr->itcl_IsObject) /* 4 */ #endif #ifndef Itcl_ObjectIsa #define Itcl_ObjectIsa \ (itclIntStubsPtr->itcl_ObjectIsa) /* 5 */ #endif #ifndef Itcl_Protection #define Itcl_Protection \ (itclIntStubsPtr->itcl_Protection) /* 6 */ #endif #ifndef Itcl_ProtectionStr #define Itcl_ProtectionStr \ (itclIntStubsPtr->itcl_ProtectionStr) /* 7 */ #endif #ifndef Itcl_CanAccess #define Itcl_CanAccess \ (itclIntStubsPtr->itcl_CanAccess) /* 8 */ #endif #ifndef Itcl_CanAccessFunc #define Itcl_CanAccessFunc \ (itclIntStubsPtr->itcl_CanAccessFunc) /* 9 */ #endif #ifndef Itcl_GetTrueNamespace #define Itcl_GetTrueNamespace \ (itclIntStubsPtr->itcl_GetTrueNamespace) /* 10 */ #endif #ifndef Itcl_ParseNamespPath #define Itcl_ParseNamespPath \ (itclIntStubsPtr->itcl_ParseNamespPath) /* 11 */ #endif #ifndef Itcl_DecodeScopedCommand #define Itcl_DecodeScopedCommand \ (itclIntStubsPtr->itcl_DecodeScopedCommand) /* 12 */ #endif #ifndef Itcl_EvalArgs #define Itcl_EvalArgs \ (itclIntStubsPtr->itcl_EvalArgs) /* 13 */ #endif #ifndef Itcl_CreateArgs #define Itcl_CreateArgs \ (itclIntStubsPtr->itcl_CreateArgs) /* 14 */ #endif #ifndef Itcl_PushContext #define Itcl_PushContext \ (itclIntStubsPtr->itcl_PushContext) /* 15 */ #endif #ifndef Itcl_PopContext #define Itcl_PopContext \ (itclIntStubsPtr->itcl_PopContext) /* 16 */ #endif #ifndef Itcl_GetContext #define Itcl_GetContext \ (itclIntStubsPtr->itcl_GetContext) /* 17 */ #endif #ifndef Itcl_InitHierIter #define Itcl_InitHierIter \ (itclIntStubsPtr->itcl_InitHierIter) /* 18 */ #endif #ifndef Itcl_DeleteHierIter #define Itcl_DeleteHierIter \ (itclIntStubsPtr->itcl_DeleteHierIter) /* 19 */ #endif #ifndef Itcl_AdvanceHierIter #define Itcl_AdvanceHierIter \ (itclIntStubsPtr->itcl_AdvanceHierIter) /* 20 */ #endif #ifndef Itcl_FindClassesCmd #define Itcl_FindClassesCmd \ (itclIntStubsPtr->itcl_FindClassesCmd) /* 21 */ #endif #ifndef Itcl_FindObjectsCmd #define Itcl_FindObjectsCmd \ (itclIntStubsPtr->itcl_FindObjectsCmd) /* 22 */ #endif #ifndef Itcl_ProtectionCmd #define Itcl_ProtectionCmd \ (itclIntStubsPtr->itcl_ProtectionCmd) /* 23 */ #endif #ifndef Itcl_DelClassCmd #define Itcl_DelClassCmd \ (itclIntStubsPtr->itcl_DelClassCmd) /* 24 */ #endif #ifndef Itcl_DelObjectCmd #define Itcl_DelObjectCmd \ (itclIntStubsPtr->itcl_DelObjectCmd) /* 25 */ #endif #ifndef Itcl_ScopeCmd #define Itcl_ScopeCmd \ (itclIntStubsPtr->itcl_ScopeCmd) /* 26 */ #endif #ifndef Itcl_CodeCmd #define Itcl_CodeCmd \ (itclIntStubsPtr->itcl_CodeCmd) /* 27 */ #endif #ifndef Itcl_StubCreateCmd #define Itcl_StubCreateCmd \ (itclIntStubsPtr->itcl_StubCreateCmd) /* 28 */ #endif #ifndef Itcl_StubExistsCmd #define Itcl_StubExistsCmd \ (itclIntStubsPtr->itcl_StubExistsCmd) /* 29 */ #endif #ifndef Itcl_IsStub #define Itcl_IsStub \ (itclIntStubsPtr->itcl_IsStub) /* 30 */ #endif #ifndef Itcl_CreateClass #define Itcl_CreateClass \ (itclIntStubsPtr->itcl_CreateClass) /* 31 */ #endif #ifndef Itcl_DeleteClass #define Itcl_DeleteClass \ (itclIntStubsPtr->itcl_DeleteClass) /* 32 */ #endif #ifndef Itcl_FindClassNamespace #define Itcl_FindClassNamespace \ (itclIntStubsPtr->itcl_FindClassNamespace) /* 33 */ #endif #ifndef Itcl_HandleClass #define Itcl_HandleClass \ (itclIntStubsPtr->itcl_HandleClass) /* 34 */ #endif #ifndef Itcl_ClassCmdResolver #define Itcl_ClassCmdResolver \ (itclIntStubsPtr->itcl_ClassCmdResolver) /* 35 */ #endif #ifndef Itcl_ClassVarResolver #define Itcl_ClassVarResolver \ (itclIntStubsPtr->itcl_ClassVarResolver) /* 36 */ #endif #ifndef Itcl_ClassCompiledVarResolver #define Itcl_ClassCompiledVarResolver \ (itclIntStubsPtr->itcl_ClassCompiledVarResolver) /* 37 */ #endif #ifndef Itcl_BuildVirtualTables #define Itcl_BuildVirtualTables \ (itclIntStubsPtr->itcl_BuildVirtualTables) /* 38 */ #endif #ifndef Itcl_CreateVarDefn #define Itcl_CreateVarDefn \ (itclIntStubsPtr->itcl_CreateVarDefn) /* 39 */ #endif #ifndef Itcl_DeleteVarDefn #define Itcl_DeleteVarDefn \ (itclIntStubsPtr->itcl_DeleteVarDefn) /* 40 */ #endif #ifndef Itcl_GetCommonVar #define Itcl_GetCommonVar \ (itclIntStubsPtr->itcl_GetCommonVar) /* 41 */ #endif #ifndef Itcl_CreateMember #define Itcl_CreateMember \ (itclIntStubsPtr->itcl_CreateMember) /* 42 */ #endif #ifndef Itcl_DeleteMember #define Itcl_DeleteMember \ (itclIntStubsPtr->itcl_DeleteMember) /* 43 */ #endif #ifndef Itcl_CreateObject #define Itcl_CreateObject \ (itclIntStubsPtr->itcl_CreateObject) /* 44 */ #endif #ifndef Itcl_DeleteObject #define Itcl_DeleteObject \ (itclIntStubsPtr->itcl_DeleteObject) /* 45 */ #endif #ifndef Itcl_DestructObject #define Itcl_DestructObject \ (itclIntStubsPtr->itcl_DestructObject) /* 46 */ #endif #ifndef Itcl_HandleInstance #define Itcl_HandleInstance \ (itclIntStubsPtr->itcl_HandleInstance) /* 47 */ #endif #ifndef Itcl_GetInstanceVar #define Itcl_GetInstanceVar \ (itclIntStubsPtr->itcl_GetInstanceVar) /* 48 */ #endif #ifndef Itcl_ScopedVarResolver #define Itcl_ScopedVarResolver \ (itclIntStubsPtr->itcl_ScopedVarResolver) /* 49 */ #endif #ifndef Itcl_BodyCmd #define Itcl_BodyCmd \ (itclIntStubsPtr->itcl_BodyCmd) /* 50 */ #endif #ifndef Itcl_ConfigBodyCmd #define Itcl_ConfigBodyCmd \ (itclIntStubsPtr->itcl_ConfigBodyCmd) /* 51 */ #endif #ifndef Itcl_CreateMethod #define Itcl_CreateMethod \ (itclIntStubsPtr->itcl_CreateMethod) /* 52 */ #endif #ifndef Itcl_CreateProc #define Itcl_CreateProc \ (itclIntStubsPtr->itcl_CreateProc) /* 53 */ #endif #ifndef Itcl_CreateMemberFunc #define Itcl_CreateMemberFunc \ (itclIntStubsPtr->itcl_CreateMemberFunc) /* 54 */ #endif #ifndef Itcl_ChangeMemberFunc #define Itcl_ChangeMemberFunc \ (itclIntStubsPtr->itcl_ChangeMemberFunc) /* 55 */ #endif #ifndef Itcl_DeleteMemberFunc #define Itcl_DeleteMemberFunc \ (itclIntStubsPtr->itcl_DeleteMemberFunc) /* 56 */ #endif #ifndef Itcl_CreateMemberCode #define Itcl_CreateMemberCode \ (itclIntStubsPtr->itcl_CreateMemberCode) /* 57 */ #endif #ifndef Itcl_DeleteMemberCode #define Itcl_DeleteMemberCode \ (itclIntStubsPtr->itcl_DeleteMemberCode) /* 58 */ #endif #ifndef Itcl_GetMemberCode #define Itcl_GetMemberCode \ (itclIntStubsPtr->itcl_GetMemberCode) /* 59 */ #endif /* Slot 60 is reserved */ #ifndef Itcl_EvalMemberCode #define Itcl_EvalMemberCode \ (itclIntStubsPtr->itcl_EvalMemberCode) /* 61 */ #endif #ifndef Itcl_CreateArgList #define Itcl_CreateArgList \ (itclIntStubsPtr->itcl_CreateArgList) /* 62 */ #endif #ifndef Itcl_CreateArg #define Itcl_CreateArg \ (itclIntStubsPtr->itcl_CreateArg) /* 63 */ #endif #ifndef Itcl_DeleteArgList #define Itcl_DeleteArgList \ (itclIntStubsPtr->itcl_DeleteArgList) /* 64 */ #endif #ifndef Itcl_ArgList #define Itcl_ArgList \ (itclIntStubsPtr->itcl_ArgList) /* 65 */ #endif #ifndef Itcl_EquivArgLists #define Itcl_EquivArgLists \ (itclIntStubsPtr->itcl_EquivArgLists) /* 66 */ #endif #ifndef Itcl_GetMemberFuncUsage #define Itcl_GetMemberFuncUsage \ (itclIntStubsPtr->itcl_GetMemberFuncUsage) /* 67 */ #endif #ifndef Itcl_ExecMethod #define Itcl_ExecMethod \ (itclIntStubsPtr->itcl_ExecMethod) /* 68 */ #endif #ifndef Itcl_ExecProc #define Itcl_ExecProc \ (itclIntStubsPtr->itcl_ExecProc) /* 69 */ #endif #ifndef Itcl_AssignArgs #define Itcl_AssignArgs \ (itclIntStubsPtr->itcl_AssignArgs) /* 70 */ #endif #ifndef Itcl_ConstructBase #define Itcl_ConstructBase \ (itclIntStubsPtr->itcl_ConstructBase) /* 71 */ #endif #ifndef Itcl_InvokeMethodIfExists #define Itcl_InvokeMethodIfExists \ (itclIntStubsPtr->itcl_InvokeMethodIfExists) /* 72 */ #endif /* Slot 73 is reserved */ #ifndef Itcl_ReportFuncErrors #define Itcl_ReportFuncErrors \ (itclIntStubsPtr->itcl_ReportFuncErrors) /* 74 */ #endif #ifndef Itcl_ParseInit #define Itcl_ParseInit \ (itclIntStubsPtr->itcl_ParseInit) /* 75 */ #endif #ifndef Itcl_ClassCmd #define Itcl_ClassCmd \ (itclIntStubsPtr->itcl_ClassCmd) /* 76 */ #endif #ifndef Itcl_ClassInheritCmd #define Itcl_ClassInheritCmd \ (itclIntStubsPtr->itcl_ClassInheritCmd) /* 77 */ #endif #ifndef Itcl_ClassProtectionCmd #define Itcl_ClassProtectionCmd \ (itclIntStubsPtr->itcl_ClassProtectionCmd) /* 78 */ #endif #ifndef Itcl_ClassConstructorCmd #define Itcl_ClassConstructorCmd \ (itclIntStubsPtr->itcl_ClassConstructorCmd) /* 79 */ #endif #ifndef Itcl_ClassDestructorCmd #define Itcl_ClassDestructorCmd \ (itclIntStubsPtr->itcl_ClassDestructorCmd) /* 80 */ #endif #ifndef Itcl_ClassMethodCmd #define Itcl_ClassMethodCmd \ (itclIntStubsPtr->itcl_ClassMethodCmd) /* 81 */ #endif #ifndef Itcl_ClassProcCmd #define Itcl_ClassProcCmd \ (itclIntStubsPtr->itcl_ClassProcCmd) /* 82 */ #endif #ifndef Itcl_ClassVariableCmd #define Itcl_ClassVariableCmd \ (itclIntStubsPtr->itcl_ClassVariableCmd) /* 83 */ #endif #ifndef Itcl_ClassCommonCmd #define Itcl_ClassCommonCmd \ (itclIntStubsPtr->itcl_ClassCommonCmd) /* 84 */ #endif #ifndef Itcl_ParseVarResolver #define Itcl_ParseVarResolver \ (itclIntStubsPtr->itcl_ParseVarResolver) /* 85 */ #endif #ifndef Itcl_BiInit #define Itcl_BiInit \ (itclIntStubsPtr->itcl_BiInit) /* 86 */ #endif #ifndef Itcl_InstallBiMethods #define Itcl_InstallBiMethods \ (itclIntStubsPtr->itcl_InstallBiMethods) /* 87 */ #endif #ifndef Itcl_BiIsaCmd #define Itcl_BiIsaCmd \ (itclIntStubsPtr->itcl_BiIsaCmd) /* 88 */ #endif #ifndef Itcl_BiConfigureCmd #define Itcl_BiConfigureCmd \ (itclIntStubsPtr->itcl_BiConfigureCmd) /* 89 */ #endif #ifndef Itcl_BiCgetCmd #define Itcl_BiCgetCmd \ (itclIntStubsPtr->itcl_BiCgetCmd) /* 90 */ #endif #ifndef Itcl_BiChainCmd #define Itcl_BiChainCmd \ (itclIntStubsPtr->itcl_BiChainCmd) /* 91 */ #endif #ifndef Itcl_BiInfoClassCmd #define Itcl_BiInfoClassCmd \ (itclIntStubsPtr->itcl_BiInfoClassCmd) /* 92 */ #endif #ifndef Itcl_BiInfoInheritCmd #define Itcl_BiInfoInheritCmd \ (itclIntStubsPtr->itcl_BiInfoInheritCmd) /* 93 */ #endif #ifndef Itcl_BiInfoHeritageCmd #define Itcl_BiInfoHeritageCmd \ (itclIntStubsPtr->itcl_BiInfoHeritageCmd) /* 94 */ #endif #ifndef Itcl_BiInfoFunctionCmd #define Itcl_BiInfoFunctionCmd \ (itclIntStubsPtr->itcl_BiInfoFunctionCmd) /* 95 */ #endif #ifndef Itcl_BiInfoVariableCmd #define Itcl_BiInfoVariableCmd \ (itclIntStubsPtr->itcl_BiInfoVariableCmd) /* 96 */ #endif #ifndef Itcl_BiInfoBodyCmd #define Itcl_BiInfoBodyCmd \ (itclIntStubsPtr->itcl_BiInfoBodyCmd) /* 97 */ #endif #ifndef Itcl_BiInfoArgsCmd #define Itcl_BiInfoArgsCmd \ (itclIntStubsPtr->itcl_BiInfoArgsCmd) /* 98 */ #endif #ifndef Itcl_DefaultInfoCmd #define Itcl_DefaultInfoCmd \ (itclIntStubsPtr->itcl_DefaultInfoCmd) /* 99 */ #endif #ifndef Itcl_EnsembleInit #define Itcl_EnsembleInit \ (itclIntStubsPtr->itcl_EnsembleInit) /* 100 */ #endif #ifndef Itcl_CreateEnsemble #define Itcl_CreateEnsemble \ (itclIntStubsPtr->itcl_CreateEnsemble) /* 101 */ #endif #ifndef Itcl_AddEnsemblePart #define Itcl_AddEnsemblePart \ (itclIntStubsPtr->itcl_AddEnsemblePart) /* 102 */ #endif #ifndef Itcl_GetEnsemblePart #define Itcl_GetEnsemblePart \ (itclIntStubsPtr->itcl_GetEnsemblePart) /* 103 */ #endif #ifndef Itcl_IsEnsemble #define Itcl_IsEnsemble \ (itclIntStubsPtr->itcl_IsEnsemble) /* 104 */ #endif #ifndef Itcl_GetEnsembleUsage #define Itcl_GetEnsembleUsage \ (itclIntStubsPtr->itcl_GetEnsembleUsage) /* 105 */ #endif #ifndef Itcl_GetEnsembleUsageForObj #define Itcl_GetEnsembleUsageForObj \ (itclIntStubsPtr->itcl_GetEnsembleUsageForObj) /* 106 */ #endif #ifndef Itcl_EnsembleCmd #define Itcl_EnsembleCmd \ (itclIntStubsPtr->itcl_EnsembleCmd) /* 107 */ #endif #ifndef Itcl_EnsPartCmd #define Itcl_EnsPartCmd \ (itclIntStubsPtr->itcl_EnsPartCmd) /* 108 */ #endif #ifndef Itcl_EnsembleErrorCmd #define Itcl_EnsembleErrorCmd \ (itclIntStubsPtr->itcl_EnsembleErrorCmd) /* 109 */ #endif /* Slot 110 is reserved */ /* Slot 111 is reserved */ #ifndef _Tcl_GetCallFrame #define _Tcl_GetCallFrame \ (itclIntStubsPtr->_Tcl_GetCallFrame) /* 112 */ #endif #ifndef _Tcl_ActivateCallFrame #define _Tcl_ActivateCallFrame \ (itclIntStubsPtr->_Tcl_ActivateCallFrame) /* 113 */ #endif #ifndef _TclNewVar #define _TclNewVar \ (itclIntStubsPtr->_TclNewVar) /* 114 */ #endif #ifndef Itcl_Assert #define Itcl_Assert \ (itclIntStubsPtr->itcl_Assert) /* 115 */ #endif #ifndef Itcl_IsObjectCmd #define Itcl_IsObjectCmd \ (itclIntStubsPtr->itcl_IsObjectCmd) /* 116 */ #endif #ifndef Itcl_IsClassCmd #define Itcl_IsClassCmd \ (itclIntStubsPtr->itcl_IsClassCmd) /* 117 */ #endif #endif /* defined(USE_ITCL_STUBS) && !defined(USE_ITCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #endif /* _ITCLINTDECLS */ itcl3.4.1/generic/itclDecls.h0000644003604700454610000002537511610066043014477 0ustar dgp891div/* * itclDecls.h -- * * Declarations of functions in the platform independent public Itcl API. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _ITCLDECLS #define _ITCLDECLS /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made * in the itcl/generic/tcl.decls script. */ /* !BEGIN!: Do not edit below this line. */ /* * Exported function declarations: */ #ifndef Itcl_Init_TCL_DECLARED #define Itcl_Init_TCL_DECLARED /* 0 */ TCL_EXTERN(int) Itcl_Init _ANSI_ARGS_((Tcl_Interp * interp)); #endif #ifndef Itcl_SafeInit_TCL_DECLARED #define Itcl_SafeInit_TCL_DECLARED /* 1 */ TCL_EXTERN(int) Itcl_SafeInit _ANSI_ARGS_((Tcl_Interp * interp)); #endif #ifndef Itcl_RegisterC_TCL_DECLARED #define Itcl_RegisterC_TCL_DECLARED /* 2 */ TCL_EXTERN(int) Itcl_RegisterC _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_CmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); #endif #ifndef Itcl_RegisterObjC_TCL_DECLARED #define Itcl_RegisterObjC_TCL_DECLARED /* 3 */ TCL_EXTERN(int) Itcl_RegisterObjC _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_ObjCmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); #endif #ifndef Itcl_FindC_TCL_DECLARED #define Itcl_FindC_TCL_DECLARED /* 4 */ TCL_EXTERN(int) Itcl_FindC _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_CmdProc ** argProcPtr, Tcl_ObjCmdProc ** objProcPtr, ClientData * cDataPtr)); #endif #ifndef Itcl_InitStack_TCL_DECLARED #define Itcl_InitStack_TCL_DECLARED /* 5 */ TCL_EXTERN(void) Itcl_InitStack _ANSI_ARGS_((Itcl_Stack * stack)); #endif #ifndef Itcl_DeleteStack_TCL_DECLARED #define Itcl_DeleteStack_TCL_DECLARED /* 6 */ TCL_EXTERN(void) Itcl_DeleteStack _ANSI_ARGS_((Itcl_Stack * stack)); #endif #ifndef Itcl_PushStack_TCL_DECLARED #define Itcl_PushStack_TCL_DECLARED /* 7 */ TCL_EXTERN(void) Itcl_PushStack _ANSI_ARGS_((ClientData cdata, Itcl_Stack * stack)); #endif #ifndef Itcl_PopStack_TCL_DECLARED #define Itcl_PopStack_TCL_DECLARED /* 8 */ TCL_EXTERN(ClientData) Itcl_PopStack _ANSI_ARGS_((Itcl_Stack * stack)); #endif #ifndef Itcl_PeekStack_TCL_DECLARED #define Itcl_PeekStack_TCL_DECLARED /* 9 */ TCL_EXTERN(ClientData) Itcl_PeekStack _ANSI_ARGS_((Itcl_Stack * stack)); #endif #ifndef Itcl_GetStackValue_TCL_DECLARED #define Itcl_GetStackValue_TCL_DECLARED /* 10 */ TCL_EXTERN(ClientData) Itcl_GetStackValue _ANSI_ARGS_((Itcl_Stack * stack, int pos)); #endif #ifndef Itcl_InitList_TCL_DECLARED #define Itcl_InitList_TCL_DECLARED /* 11 */ TCL_EXTERN(void) Itcl_InitList _ANSI_ARGS_((Itcl_List * listPtr)); #endif #ifndef Itcl_DeleteList_TCL_DECLARED #define Itcl_DeleteList_TCL_DECLARED /* 12 */ TCL_EXTERN(void) Itcl_DeleteList _ANSI_ARGS_((Itcl_List * listPtr)); #endif #ifndef Itcl_CreateListElem_TCL_DECLARED #define Itcl_CreateListElem_TCL_DECLARED /* 13 */ TCL_EXTERN(Itcl_ListElem*) Itcl_CreateListElem _ANSI_ARGS_(( Itcl_List * listPtr)); #endif #ifndef Itcl_DeleteListElem_TCL_DECLARED #define Itcl_DeleteListElem_TCL_DECLARED /* 14 */ TCL_EXTERN(Itcl_ListElem*) Itcl_DeleteListElem _ANSI_ARGS_(( Itcl_ListElem * elemPtr)); #endif #ifndef Itcl_InsertList_TCL_DECLARED #define Itcl_InsertList_TCL_DECLARED /* 15 */ TCL_EXTERN(Itcl_ListElem*) Itcl_InsertList _ANSI_ARGS_((Itcl_List * listPtr, ClientData val)); #endif #ifndef Itcl_InsertListElem_TCL_DECLARED #define Itcl_InsertListElem_TCL_DECLARED /* 16 */ TCL_EXTERN(Itcl_ListElem*) Itcl_InsertListElem _ANSI_ARGS_(( Itcl_ListElem * pos, ClientData val)); #endif #ifndef Itcl_AppendList_TCL_DECLARED #define Itcl_AppendList_TCL_DECLARED /* 17 */ TCL_EXTERN(Itcl_ListElem*) Itcl_AppendList _ANSI_ARGS_((Itcl_List * listPtr, ClientData val)); #endif #ifndef Itcl_AppendListElem_TCL_DECLARED #define Itcl_AppendListElem_TCL_DECLARED /* 18 */ TCL_EXTERN(Itcl_ListElem*) Itcl_AppendListElem _ANSI_ARGS_(( Itcl_ListElem * pos, ClientData val)); #endif #ifndef Itcl_SetListValue_TCL_DECLARED #define Itcl_SetListValue_TCL_DECLARED /* 19 */ TCL_EXTERN(void) Itcl_SetListValue _ANSI_ARGS_(( Itcl_ListElem * elemPtr, ClientData val)); #endif #ifndef Itcl_EventuallyFree_TCL_DECLARED #define Itcl_EventuallyFree_TCL_DECLARED /* 20 */ TCL_EXTERN(void) Itcl_EventuallyFree _ANSI_ARGS_((ClientData cdata, Tcl_FreeProc * fproc)); #endif #ifndef Itcl_PreserveData_TCL_DECLARED #define Itcl_PreserveData_TCL_DECLARED /* 21 */ TCL_EXTERN(void) Itcl_PreserveData _ANSI_ARGS_((ClientData cdata)); #endif #ifndef Itcl_ReleaseData_TCL_DECLARED #define Itcl_ReleaseData_TCL_DECLARED /* 22 */ TCL_EXTERN(void) Itcl_ReleaseData _ANSI_ARGS_((ClientData cdata)); #endif #ifndef Itcl_SaveInterpState_TCL_DECLARED #define Itcl_SaveInterpState_TCL_DECLARED /* 23 */ TCL_EXTERN(Itcl_InterpState) Itcl_SaveInterpState _ANSI_ARGS_(( Tcl_Interp* interp, int status)); #endif #ifndef Itcl_RestoreInterpState_TCL_DECLARED #define Itcl_RestoreInterpState_TCL_DECLARED /* 24 */ TCL_EXTERN(int) Itcl_RestoreInterpState _ANSI_ARGS_(( Tcl_Interp* interp, Itcl_InterpState state)); #endif #ifndef Itcl_DiscardInterpState_TCL_DECLARED #define Itcl_DiscardInterpState_TCL_DECLARED /* 25 */ TCL_EXTERN(void) Itcl_DiscardInterpState _ANSI_ARGS_(( Itcl_InterpState state)); #endif typedef struct ItclStubHooks { struct ItclIntStubs *itclIntStubs; } ItclStubHooks; typedef struct ItclStubs { int magic; struct ItclStubHooks *hooks; int (*itcl_Init) _ANSI_ARGS_((Tcl_Interp * interp)); /* 0 */ int (*itcl_SafeInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 1 */ int (*itcl_RegisterC) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_CmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 2 */ int (*itcl_RegisterObjC) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_ObjCmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 3 */ int (*itcl_FindC) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_CmdProc ** argProcPtr, Tcl_ObjCmdProc ** objProcPtr, ClientData * cDataPtr)); /* 4 */ void (*itcl_InitStack) _ANSI_ARGS_((Itcl_Stack * stack)); /* 5 */ void (*itcl_DeleteStack) _ANSI_ARGS_((Itcl_Stack * stack)); /* 6 */ void (*itcl_PushStack) _ANSI_ARGS_((ClientData cdata, Itcl_Stack * stack)); /* 7 */ ClientData (*itcl_PopStack) _ANSI_ARGS_((Itcl_Stack * stack)); /* 8 */ ClientData (*itcl_PeekStack) _ANSI_ARGS_((Itcl_Stack * stack)); /* 9 */ ClientData (*itcl_GetStackValue) _ANSI_ARGS_((Itcl_Stack * stack, int pos)); /* 10 */ void (*itcl_InitList) _ANSI_ARGS_((Itcl_List * listPtr)); /* 11 */ void (*itcl_DeleteList) _ANSI_ARGS_((Itcl_List * listPtr)); /* 12 */ Itcl_ListElem* (*itcl_CreateListElem) _ANSI_ARGS_((Itcl_List * listPtr)); /* 13 */ Itcl_ListElem* (*itcl_DeleteListElem) _ANSI_ARGS_((Itcl_ListElem * elemPtr)); /* 14 */ Itcl_ListElem* (*itcl_InsertList) _ANSI_ARGS_((Itcl_List * listPtr, ClientData val)); /* 15 */ Itcl_ListElem* (*itcl_InsertListElem) _ANSI_ARGS_((Itcl_ListElem * pos, ClientData val)); /* 16 */ Itcl_ListElem* (*itcl_AppendList) _ANSI_ARGS_((Itcl_List * listPtr, ClientData val)); /* 17 */ Itcl_ListElem* (*itcl_AppendListElem) _ANSI_ARGS_((Itcl_ListElem * pos, ClientData val)); /* 18 */ void (*itcl_SetListValue) _ANSI_ARGS_((Itcl_ListElem * elemPtr, ClientData val)); /* 19 */ void (*itcl_EventuallyFree) _ANSI_ARGS_((ClientData cdata, Tcl_FreeProc * fproc)); /* 20 */ void (*itcl_PreserveData) _ANSI_ARGS_((ClientData cdata)); /* 21 */ void (*itcl_ReleaseData) _ANSI_ARGS_((ClientData cdata)); /* 22 */ Itcl_InterpState (*itcl_SaveInterpState) _ANSI_ARGS_((Tcl_Interp* interp, int status)); /* 23 */ int (*itcl_RestoreInterpState) _ANSI_ARGS_((Tcl_Interp* interp, Itcl_InterpState state)); /* 24 */ void (*itcl_DiscardInterpState) _ANSI_ARGS_((Itcl_InterpState state)); /* 25 */ } ItclStubs; TCL_EXTERNC ItclStubs *itclStubsPtr; #if defined(USE_ITCL_STUBS) && !defined(USE_ITCL_STUB_PROCS) /* * Inline function declarations: */ #ifndef Itcl_Init #define Itcl_Init \ (itclStubsPtr->itcl_Init) /* 0 */ #endif #ifndef Itcl_SafeInit #define Itcl_SafeInit \ (itclStubsPtr->itcl_SafeInit) /* 1 */ #endif #ifndef Itcl_RegisterC #define Itcl_RegisterC \ (itclStubsPtr->itcl_RegisterC) /* 2 */ #endif #ifndef Itcl_RegisterObjC #define Itcl_RegisterObjC \ (itclStubsPtr->itcl_RegisterObjC) /* 3 */ #endif #ifndef Itcl_FindC #define Itcl_FindC \ (itclStubsPtr->itcl_FindC) /* 4 */ #endif #ifndef Itcl_InitStack #define Itcl_InitStack \ (itclStubsPtr->itcl_InitStack) /* 5 */ #endif #ifndef Itcl_DeleteStack #define Itcl_DeleteStack \ (itclStubsPtr->itcl_DeleteStack) /* 6 */ #endif #ifndef Itcl_PushStack #define Itcl_PushStack \ (itclStubsPtr->itcl_PushStack) /* 7 */ #endif #ifndef Itcl_PopStack #define Itcl_PopStack \ (itclStubsPtr->itcl_PopStack) /* 8 */ #endif #ifndef Itcl_PeekStack #define Itcl_PeekStack \ (itclStubsPtr->itcl_PeekStack) /* 9 */ #endif #ifndef Itcl_GetStackValue #define Itcl_GetStackValue \ (itclStubsPtr->itcl_GetStackValue) /* 10 */ #endif #ifndef Itcl_InitList #define Itcl_InitList \ (itclStubsPtr->itcl_InitList) /* 11 */ #endif #ifndef Itcl_DeleteList #define Itcl_DeleteList \ (itclStubsPtr->itcl_DeleteList) /* 12 */ #endif #ifndef Itcl_CreateListElem #define Itcl_CreateListElem \ (itclStubsPtr->itcl_CreateListElem) /* 13 */ #endif #ifndef Itcl_DeleteListElem #define Itcl_DeleteListElem \ (itclStubsPtr->itcl_DeleteListElem) /* 14 */ #endif #ifndef Itcl_InsertList #define Itcl_InsertList \ (itclStubsPtr->itcl_InsertList) /* 15 */ #endif #ifndef Itcl_InsertListElem #define Itcl_InsertListElem \ (itclStubsPtr->itcl_InsertListElem) /* 16 */ #endif #ifndef Itcl_AppendList #define Itcl_AppendList \ (itclStubsPtr->itcl_AppendList) /* 17 */ #endif #ifndef Itcl_AppendListElem #define Itcl_AppendListElem \ (itclStubsPtr->itcl_AppendListElem) /* 18 */ #endif #ifndef Itcl_SetListValue #define Itcl_SetListValue \ (itclStubsPtr->itcl_SetListValue) /* 19 */ #endif #ifndef Itcl_EventuallyFree #define Itcl_EventuallyFree \ (itclStubsPtr->itcl_EventuallyFree) /* 20 */ #endif #ifndef Itcl_PreserveData #define Itcl_PreserveData \ (itclStubsPtr->itcl_PreserveData) /* 21 */ #endif #ifndef Itcl_ReleaseData #define Itcl_ReleaseData \ (itclStubsPtr->itcl_ReleaseData) /* 22 */ #endif #ifndef Itcl_SaveInterpState #define Itcl_SaveInterpState \ (itclStubsPtr->itcl_SaveInterpState) /* 23 */ #endif #ifndef Itcl_RestoreInterpState #define Itcl_RestoreInterpState \ (itclStubsPtr->itcl_RestoreInterpState) /* 24 */ #endif #ifndef Itcl_DiscardInterpState #define Itcl_DiscardInterpState \ (itclStubsPtr->itcl_DiscardInterpState) /* 25 */ #endif #endif /* defined(USE_ITCL_STUBS) && !defined(USE_ITCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #endif /* _ITCLDECLS */ itcl3.4.1/generic/itcl_cmds.c0000644003604700454610000015126611610103534014521 0ustar dgp891div/* * ------------------------------------------------------------------------ * 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 * ======================================================================== * 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 {[info exists library]} {\n\ lappend dirs $library\n\ } else {\n\ if {[catch {uplevel #0 source -rsrc itcl}] == 0} {\n\ return\n\ }\n\ set dirs {}\n\ if {[info exists env(ITCL_LIBRARY)]} {\n\ lappend dirs $env(ITCL_LIBRARY)\n\ }\n\ lappend dirs [file join [file dirname $tcl_library] itcl$version]\n\ set bindir [file dirname [info nameofexecutable]]\n\ lappend dirs [file join $bindir .. lib itcl$version]\n\ lappend dirs [file join $bindir .. library]\n\ lappend dirs [file join $bindir .. .. library]\n\ lappend dirs [file join $bindir .. .. itcl library]\n\ lappend dirs [file join $bindir .. .. .. itcl library]\n\ # On MacOSX, check the directories in the tcl_pkgPath\n\ if {[string equal $::tcl_platform(platform) \"unix\"] && \ [string equal $::tcl_platform(os) \"Darwin\"]} {\n\ foreach d $::tcl_pkgPath {\n\ lappend dirs [file join $d itcl$version]\n\ }\n\ }\n\ }\n\ foreach i $dirs {\n\ set library $i\n\ set itclfile [file join $i itcl.tcl]\n\ if {![catch {uplevel #0 [list source $itclfile]} msg]} {\n\ return\n\ }\n\ }\n\ set msg \"Can't find a usable itcl.tcl in the following directories:\n\"\n\ append msg \" $dirs\n\"\n\ append msg \"This probably means that Itcl/Tcl weren't installed properly.\n\"\n\ append msg \"If you know where the Itcl library directory was installed,\n\"\n\ append msg \"you can set the environment variable ITCL_LIBRARY to point\n\"\n\ append msg \"to the library directory.\n\"\n\ error $msg\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 [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\ }"; int itclCompatFlags = -1; #if ITCL_TCL_PRE_8_5 int itclVarFlagOffset; int itclVarRefCountOffset; int itclVarInHashSize; int itclVarLocalSize; int itclVarValueOffset; #endif /* * ------------------------------------------------------------------------ * 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; #ifndef USE_TCL_STUBS if (Tcl_PkgRequire(interp, "Tcl", TCL_VERSION, 0) == NULL) { return TCL_ERROR; } #else if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { return TCL_ERROR; } #endif /* * 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; } /* * Set the compatability options. Stubs allows us to load into many * version of the Tcl core. Some problems have crept-in, and we need * to adapt dynamically regarding use of some internal structures and * functions that have changed (or have been added) since 8.1.0 */ if (itclCompatFlags == -1) { int maj, min, ptch, type; itclCompatFlags = 0; Tcl_GetVersion(&maj, &min, &ptch, &type); #if USE_TCL_STUBS if ((maj == 8) && (min > 4) && ((type > TCL_ALPHA_RELEASE) || (ptch > 2))) { itclCompatFlags |= ITCL_COMPAT_USE_ISTATE_API; } #else itclCompatFlags = 0; #endif #if ITCL_TCL_PRE_8_5 #if USE_TCL_STUBS if ((maj == 8) && (min < 5)) { #endif itclVarFlagOffset = ItclOffset(Var, flags); itclVarRefCountOffset = ItclOffset(Var, refCount); itclVarValueOffset = ItclOffset(Var, value); itclVarInHashSize = sizeof(Var); itclVarLocalSize = sizeof(Var); #if USE_TCL_STUBS } else { itclVarFlagOffset = ItclOffset(ItclShortVar, flags); itclVarRefCountOffset = ItclOffset(ItclVarInHash, refCount); itclVarValueOffset = ItclOffset(ItclShortVar, value); itclVarInHashSize = sizeof(ItclVarInHash); itclVarLocalSize = sizeof(ItclShortVar); } #endif #endif } /* * 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); /* * Create the "itcl::is" command to test object * and classes existence. */ if (Itcl_CreateEnsemble(interp, "::itcl::is") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::is", "class", "name", Itcl_IsClassCmd, (ClientData)info, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData((ClientData)info); if (Itcl_AddEnsemblePart(interp, "::itcl::is", "object", "?-class classname? name", Itcl_IsObjectCmd, (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, (Tcl_ResolveVarProc*)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; } /* * 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); /* * This was changed from a glob export (itcl::*) to explicit * command exports, so that the itcl::is command can *not* be * exported. This is done for concern that the itcl::is command * imported might be confusing ("is"). */ if (!itclNs || (Tcl_Export(interp, itclNs, "body", /* reset */ 1) != TCL_OK) || (Tcl_Export(interp, itclNs, "class", 0) != TCL_OK) || (Tcl_Export(interp, itclNs, "code", 0) != TCL_OK) || (Tcl_Export(interp, itclNs, "configbody", 0) != TCL_OK) || (Tcl_Export(interp, itclNs, "delete", 0) != TCL_OK) || (Tcl_Export(interp, itclNs, "delete_helper", 0) != TCL_OK) || (Tcl_Export(interp, itclNs, "ensemble", 0) != TCL_OK) || (Tcl_Export(interp, itclNs, "find", 0) != TCL_OK) || (Tcl_Export(interp, itclNs, "local", 0) != TCL_OK) || (Tcl_Export(interp, itclNs, "scope", 0) != 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. */ { extern ItclStubs itclStubs; if (Tcl_PkgProvideEx(interp, "Itcl", ITCL_VERSION, (ClientData)&itclStubs) != 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); /* * Fix 227804: Whenever an object to delete was found we * have to reset the search to the beginning as the * current entry in the search was deleted and accessing it * is therefore not allowed anymore. */ entry = Tcl_FirstHashEntry(&info->objects, &place); /*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() * * Invoked by Tcl whenever the user issues an "itcl::find classes" * command to query the list of known classes. Handles the following * syntax: * * find 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; CONST char *cmdName; int newEntry, handledActiveNs; Tcl_HashTable unique; Tcl_HashEntry *entry; Tcl_HashSearch place; Itcl_Stack search; Tcl_Command cmd, originalCmd; Namespace *nsPtr; Tcl_Obj *objPtr; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } if (objc == 2) { pattern = Tcl_GetString(objv[1]); forceFullNames = (strstr(pattern, "::") != NULL); } else { pattern = NULL; } /* * Search through all commands in the current namespace first, * in the global namespace next, then in all child namespaces * in this interpreter. If we find any commands that * represent classes, report them. */ Itcl_InitStack(&search); Itcl_PushStack((ClientData)globalNs, &search); Itcl_PushStack((ClientData)activeNs, &search); /* last in, first out! */ Tcl_InitHashTable(&unique, TCL_ONE_WORD_KEYS); handledActiveNs = 0; while (Itcl_GetStackSize(&search) > 0) { nsPtr = (Namespace*)Itcl_PopStack(&search); if (nsPtr == (Namespace*)activeNs && handledActiveNs) { continue; } 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); cmdName = Tcl_GetString(objPtr); } else { cmdName = Tcl_GetCommandName(interp, cmd); objPtr = Tcl_NewStringObj(cmdName, -1); } if (originalCmd) { cmd = originalCmd; } Tcl_CreateHashEntry(&unique, (char*)cmd, &newEntry); if (newEntry && (!pattern || Tcl_StringMatch(cmdName, pattern))) { Tcl_ListObjAppendElement((Tcl_Interp*)NULL, Tcl_GetObjResult(interp), objPtr); } else { /* if not appended to the result, free objPtr. */ Tcl_DecrRefCount(objPtr); } } entry = Tcl_NextHashEntry(&place); } handledActiveNs = 1; /* don't process the active namespace twice */ /* * Push any child namespaces onto the stack and continue * the search in those namespaces. */ entry = Tcl_FirstHashEntry(&nsPtr->childTable, &place); while (entry != NULL) { Itcl_PushStack(Tcl_GetHashValue(entry), &search); entry = Tcl_NextHashEntry(&place); } } Tcl_DeleteHashTable(&unique); Itcl_DeleteStack(&search); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_FindObjectsCmd() * * Invoked by Tcl whenever the user issues an "itcl::find objects" * command to query the list of known objects. Handles the following * syntax: * * find 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 = NULL, *token = NULL; CONST char *cmdName = NULL; int pos, newEntry, match, handledActiveNs; ItclObject *contextObj; Tcl_HashTable unique; Tcl_HashEntry *entry; Tcl_HashSearch place; Itcl_Stack search; Tcl_Command cmd, originalCmd; Namespace *nsPtr; Command *cmdPtr; Tcl_Obj *objPtr; /* * Parse arguments: * objects ?-class ? ?-isa ? ?? */ pos = 0; while (++pos < objc) { token = Tcl_GetString(objv[pos]); if (*token != '-') { if (!pattern) { pattern = token; forceFullNames = (strstr(pattern, "::") != NULL); } else { break; } } else if ((pos+1 < objc) && (strcmp(token,"-class") == 0)) { name = Tcl_GetString(objv[pos+1]); 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_GetString(objv[pos+1]); isaDefn = Itcl_FindClass(interp, name, /* autoload */ 1); if (isaDefn == NULL) { return TCL_ERROR; } pos++; } /* * Last token? Take it as the pattern, even if it starts * with a "-". This allows us to match object names that * start with "-". */ else if (pos == objc-1 && !pattern) { pattern = token; forceFullNames = (strstr(pattern, "::") != NULL); } 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 first, * in the global namespace next, then in all child namespaces * in this interpreter. If we find any commands that * represent objects, report them. */ Itcl_InitStack(&search); Itcl_PushStack((ClientData)globalNs, &search); Itcl_PushStack((ClientData)activeNs, &search); /* last in, first out! */ Tcl_InitHashTable(&unique, TCL_ONE_WORD_KEYS); handledActiveNs = 0; while (Itcl_GetStackSize(&search) > 0) { nsPtr = (Namespace*)Itcl_PopStack(&search); if (nsPtr == (Namespace*)activeNs && handledActiveNs) { continue; } 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); cmdName = Tcl_GetString(objPtr); } else { cmdName = Tcl_GetCommandName(interp, cmd); objPtr = Tcl_NewStringObj(cmdName, -1); } Tcl_CreateHashEntry(&unique, (char*)cmd, &newEntry); match = 0; if (newEntry && (!pattern || Tcl_StringMatch(cmdName, 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, Tcl_GetObjResult(interp), objPtr); } else { Tcl_DecrRefCount(objPtr); /* throw away the name */ } } entry = Tcl_NextHashEntry(&place); } handledActiveNs = 1; /* don't process the active namespace twice */ /* * Push any child namespaces onto the stack and continue * the search in those namespaces. */ entry = Tcl_FirstHashEntry(&nsPtr->childTable, &place); while (entry != NULL) { Itcl_PushStack(Tcl_GetHashValue(entry), &search); entry = Tcl_NextHashEntry(&place); } } Tcl_DeleteHashTable(&unique); Itcl_DeleteStack(&search); 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) { result = Tcl_EvalObj(interp, objv[1]); } 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_GetString(objv[0]); sprintf(mesg, "\n (%.100s body line %d)", name, Tcl_GetErrorLine(interp)); 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_GetString(objv[i]); cdefn = Itcl_FindClass(interp, name, /* autoload */ 1); if (cdefn == NULL) { return TCL_ERROR; } } for (i=1; i < objc; i++) { name = Tcl_GetString(objv[i]); 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_AppendResult(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; Itcl_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_AppendResult(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_AppendResult(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_AppendResult(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_AppendResult(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_AppendResult(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_IsObjectCmd() * * Invoked by Tcl whenever the user issues an "itcl::is object" * command to test whether the argument is an object or not. * syntax: * * itcl::is object ?-class classname? commandname * * Sets interp result to 1 if it is an object, 0 otherwise * ------------------------------------------------------------------------ */ int Itcl_IsObjectCmd(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 */ { int classFlag = 0; int idx = 0; char *name = ""; char *cname; char *cmdName; char *token; Tcl_Command cmd; Command *cmdPtr; Tcl_Namespace *contextNs = NULL; ItclClass *classDefn = NULL; ItclObject *contextObj; /* * Handle the arguments. * objc needs to be either: * 2 itcl::is object commandname * 4 itcl::is object -class classname commandname */ if (objc != 2 && objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "?-class classname? commandname"); return TCL_ERROR; } /* * Parse the command args. Look for the -class * keyword. */ for (idx=1; idx < objc; idx++) { token = Tcl_GetString(objv[idx]); if (strcmp(token,"-class") == 0) { cname = Tcl_GetString(objv[idx+1]); classDefn = Itcl_FindClass(interp, cname, /* no autoload */ 0); if (classDefn == NULL) { return TCL_ERROR; } idx++; classFlag = 1; } else { name = Tcl_GetString(objv[idx]); } } /* end for objc loop */ /* * 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; } cmd = Tcl_FindCommand(interp, cmdName, contextNs, /* flags */ 0); /* * Need the NULL test, or the test will fail if cmd is NULL */ if (cmd == NULL || ! Itcl_IsObject(cmd)) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); return TCL_OK; } /* * Handle the case when the -class flag is given */ if (classFlag) { cmdPtr = (Command*)cmd; contextObj = (ItclObject*)cmdPtr->objClientData; if (! Itcl_ObjectIsa(contextObj, classDefn)) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); return TCL_OK; } } /* * Got this far, so assume that it is a valid object */ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); ckfree(cmdName); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_IsClassCmd() * * Invoked by Tcl whenever the user issues an "itcl::is class" * command to test whether the argument is an itcl class or not * syntax: * * itcl::is class commandname * * Sets interp result to 1 if it is a class, 0 otherwise * ------------------------------------------------------------------------ */ int Itcl_IsClassCmd(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 */ { char *cname; char *name; ItclClass *classDefn = NULL; Tcl_Namespace *contextNs = NULL; /* * Need itcl::is class classname */ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "commandname"); return TCL_ERROR; } name = Tcl_GetString(objv[1]); /* * The object name may be a scoped value of the form * "namespace inscope ". If it is, * decode it. */ if (Itcl_DecodeScopedCommand(interp, name, &contextNs, &cname) != TCL_OK) { return TCL_ERROR; } classDefn = Itcl_FindClass(interp, cname, /* no autoload */ 0); /* * If classDefn is NULL, then it wasn't found, hence it * isn't a class */ if (classDefn != NULL) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); } else { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); } ckfree(cname); return TCL_OK; } /* end Itcl_IsClassCmd function */ itcl3.4.1/generic/itcl_bicmds.c0000644003604700454610000015307011610103534015027 0ustar dgp891div/* * ------------------------------------------------------------------------ * 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 * ======================================================================== * 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_AppendResult(interp, "improper usage: should be \"object isa className\"", (char*)NULL); return TCL_ERROR; } if (objc != 2) { token = Tcl_GetStringFromObj(objv[0], (int*)NULL); Tcl_AppendResult(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 ?-