/* * ------------------------------------------------------------------------ * 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 * * overhauled version author: Arnulf Wiedemann * ======================================================================== * 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 "tclInt.h" #include "itclInt.h" /* * ------------------------------------------------------------------------ * Itcl_ThisCmd() * * Invoked by Tcl for fast access to itcl methods * syntax: * * this methodName args .... * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ static int NRThisCmd( ClientData clientData, /* class info */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ClientData clientData2; Tcl_Object oPtr; ItclClass *iclsPtr; ItclShowArgs(1, "NRThisCmd", objc, objv); iclsPtr = (ItclClass *)clientData; clientData2 = Itcl_GetCallFrameClientData(interp); oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)clientData2); return Itcl_PublicObjectCmd(oPtr, interp, iclsPtr->clsPtr, objc, objv); } /* ARGSUSED */ int Itcl_ThisCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { FOREACH_HASH_DECLS; ClientData clientData2; Tcl_Object oPtr; Tcl_Obj **newObjv; ItclClass *iclsPtr; ItclDelegatedFunction *idmPtr; const char *funcName; const char *val; int result; if (objc == 1) { return Itcl_SelfCmd(clientData,interp, objc, objv); } ItclShowArgs(1, "Itcl_ThisCmd", objc, objv); iclsPtr = (ItclClass *)clientData; clientData2 = Itcl_GetCallFrameClientData(interp); if (clientData2 == NULL) { Tcl_AppendResult(interp, "this cannot be invoked without an object context", NULL); return TCL_ERROR; } oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)clientData2); if (oPtr == NULL) { Tcl_AppendResult(interp, "this cannot be invoked without an object context", NULL); return TCL_ERROR; } if (objc == 1) { Tcl_Obj *namePtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(oPtr), namePtr); Tcl_SetObjResult(interp, namePtr); return TCL_OK; } hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objv[1]); funcName = Tcl_GetString(objv[1]); if (!(iclsPtr->flags & ITCL_CLASS)) { FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { if (strcmp(Tcl_GetString(idmPtr->namePtr), funcName) == 0) { if (idmPtr->icPtr == NULL) { if (idmPtr->usingPtr != NULL) { newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc); newObjv[0] = idmPtr->usingPtr; Tcl_IncrRefCount(newObjv[0]); memcpy(newObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc - 2)); ItclShowArgs(1, "EVAL2", objc - 1, newObjv); result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0); Tcl_DecrRefCount(newObjv[0]); ckfree((char *)newObjv); } else { Tcl_AppendResult(interp, "delegate has not yet been implemented in", ": \"this\" method/command!", NULL); return TCL_ERROR; } } else { newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc + 1)); newObjv[0] = Tcl_NewStringObj("this", -1); Tcl_IncrRefCount(newObjv[0]); val = Tcl_GetVar2(interp, Tcl_GetString(idmPtr->icPtr->namePtr), NULL, 0); newObjv[1] = Tcl_NewStringObj(val, -1); Tcl_IncrRefCount(newObjv[1]); memcpy(newObjv+2, objv+1, sizeof(Tcl_Obj *) * (objc -1)); ItclShowArgs(1, "EVAL2", objc+1, newObjv); result = Tcl_EvalObjv(interp, objc+1, newObjv, 0); Tcl_DecrRefCount(newObjv[1]); Tcl_DecrRefCount(newObjv[0]); ckfree((char *)newObjv); } return result; } } } if (hPtr == NULL) { Tcl_AppendResult(interp, "class \"", iclsPtr->nsPtr->fullName, "\" has no method: \"", Tcl_GetString(objv[1]), "\"", NULL); return TCL_ERROR; } return Tcl_NRCallObjProc(interp, NRThisCmd, clientData, objc, objv); } /* * ------------------------------------------------------------------------ * 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 dummy, /* 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); Tcl_HashTable unique; Tcl_HashEntry *hPtr; Tcl_HashSearch place; Tcl_Command cmd; Tcl_Command originalCmd; Tcl_Namespace *nsPtr; Tcl_Obj *objPtr; Itcl_Stack search; char *pattern; const char *cmdName; int newEntry; int handledActiveNs; int forceFullNames = 0; (void)dummy; ItclShowArgs(2, "Itcl_FindClassesCmd", objc, objv); 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(globalNs, &search); Itcl_PushStack(activeNs, &search); /* last in, first out! */ Tcl_InitHashTable(&unique, TCL_ONE_WORD_KEYS); handledActiveNs = 0; while (Itcl_GetStackSize(&search) > 0) { nsPtr = (Tcl_Namespace *)Itcl_PopStack(&search); if (nsPtr == activeNs && handledActiveNs) { continue; } hPtr = Tcl_FirstHashEntry(Itcl_GetNamespaceCommandTable(nsPtr), &place); while (hPtr) { cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); if (Itcl_IsClass(cmd)) { originalCmd = Tcl_GetOriginalCommand(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 != activeNs || originalCmd != NULL) { objPtr = Tcl_NewStringObj(NULL, 0); Tcl_GetCommandFullName(interp, cmd, objPtr); cmdName = Tcl_GetString(objPtr); } else { cmdName = Tcl_GetCommandName(interp, cmd); objPtr = Tcl_NewStringObj((const char *)cmdName, -1); } if (originalCmd) { cmd = originalCmd; } Tcl_CreateHashEntry(&unique, (char*)cmd, &newEntry); if (newEntry && ((pattern == NULL) || Tcl_StringCaseMatch((const char *)cmdName, pattern, 0))) { Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), objPtr); } else { /* if not appended to the result, free objPtr. */ Tcl_DecrRefCount(objPtr); } } hPtr = 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. */ hPtr = Tcl_FirstHashEntry(Itcl_GetNamespaceChildTable(nsPtr), &place); while (hPtr != NULL) { Itcl_PushStack(Tcl_GetHashValue(hPtr), &search); hPtr = 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 dummy, /* 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 *iclsPtr = NULL; ItclClass *isaDefn = NULL; char *name = NULL; char *token = NULL; const char *cmdName = NULL; int pos; int newEntry; int match; int handledActiveNs; ItclObject *contextIoPtr; Tcl_HashTable unique; Tcl_HashEntry *entry; Tcl_HashSearch place; Itcl_Stack search; Tcl_Command cmd; Tcl_Command originalCmd; Tcl_CmdInfo cmdInfo; Tcl_Namespace *nsPtr; Tcl_Obj *objPtr; (void)dummy; /* * 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]); iclsPtr = Itcl_FindClass(interp, name, /* autoload */ 1); if (iclsPtr == 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++; } else { /* * Last token? Take it as the pattern, even if it starts * with a "-". This allows us to match object names that * start with "-". */ 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(globalNs, &search); Itcl_PushStack(activeNs, &search); /* last in, first out! */ Tcl_InitHashTable(&unique, TCL_ONE_WORD_KEYS); handledActiveNs = 0; while (Itcl_GetStackSize(&search) > 0) { nsPtr = (Tcl_Namespace *)Itcl_PopStack(&search); if (nsPtr == activeNs && handledActiveNs) { continue; } entry = Tcl_FirstHashEntry(Itcl_GetNamespaceCommandTable(nsPtr), &place); while (entry) { cmd = (Tcl_Command)Tcl_GetHashValue(entry); if (Itcl_IsObject(cmd)) { originalCmd = Tcl_GetOriginalCommand(cmd); if (originalCmd) { cmd = originalCmd; } Tcl_GetCommandInfoFromToken(cmd, &cmdInfo); contextIoPtr = (ItclObject*)cmdInfo.deleteData; /* * 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 != activeNs || originalCmd != NULL) { objPtr = Tcl_NewStringObj(NULL, 0); Tcl_GetCommandFullName(interp, cmd, objPtr); cmdName = Tcl_GetString(objPtr); } else { cmdName = Tcl_GetCommandName(interp, cmd); objPtr = Tcl_NewStringObj((const char *)cmdName, -1); } Tcl_CreateHashEntry(&unique, (char*)cmd, &newEntry); match = 0; if (newEntry && (!pattern || Tcl_StringCaseMatch((const char *)cmdName, pattern, 0))) { if ((iclsPtr == NULL) || (contextIoPtr->iclsPtr == iclsPtr)) { if (isaDefn == NULL) { match = 1; } else { entry = Tcl_FindHashEntry( &contextIoPtr->iclsPtr->heritage, (char*)isaDefn); if (entry) { match = 1; } } } } if (match) { Tcl_ListObjAppendElement(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(Itcl_GetNamespaceChildTable(nsPtr), &place); while (entry != NULL) { Itcl_PushStack(Tcl_GetHashValue(entry), &search); entry = Tcl_NextHashEntry(&place); } } Tcl_DeleteHashTable(&unique); Itcl_DeleteStack(&search); return TCL_OK; } /* * ------------------------------------------------------------------------ * 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 */ static int NRDelClassCmd( ClientData dummy, /* unused */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { int i; char *name; ItclClass *iclsPtr; (void)dummy; ItclShowArgs(1, "Itcl_DelClassCmd", objc, objv); /* * 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]); iclsPtr = Itcl_FindClass(interp, name, /* autoload */ 1); if (iclsPtr == NULL) { return TCL_ERROR; } } for (i=1; i < objc; i++) { name = Tcl_GetString(objv[i]); iclsPtr = Itcl_FindClass(interp, name, /* autoload */ 0); if (iclsPtr) { Tcl_ResetResult(interp); if (Itcl_DeleteClass(interp, iclsPtr) != TCL_OK) { return TCL_ERROR; } } } Tcl_ResetResult(interp); return TCL_OK; } /* ARGSUSED */ int Itcl_DelClassCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { return Tcl_NRCallObjProc(interp, NRDelClassCmd, clientData, objc, objv); } /* * ------------------------------------------------------------------------ * 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. * ------------------------------------------------------------------------ */ static int CallDeleteObject( ClientData data[], Tcl_Interp *interp, int result) { ItclObject *contextIoPtr = (ItclObject *)data[0]; if (contextIoPtr->destructorHasBeenCalled) { Tcl_AppendResult(interp, "can't delete an object while it is being ", "destructed", NULL); return TCL_ERROR; } if (result == TCL_OK) { result = Itcl_DeleteObject(interp, contextIoPtr); } return result; } static int NRDelObjectCmd( ClientData dummy, /* object management info */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclObject *contextIoPtr; char *name; void *callbackPtr; int i; int result; (void)dummy; ItclShowArgs(1, "Itcl_DelObjectCmd", objc, objv); /* * 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_GetString(objv[i]); contextIoPtr = NULL; if (Itcl_FindObject(interp, name, &contextIoPtr) != TCL_OK) { return TCL_ERROR; } if (contextIoPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "object \"", name, "\" not found", NULL); return TCL_ERROR; } callbackPtr = Itcl_GetCurrentCallbackPtr(interp); Tcl_NRAddCallback(interp, CallDeleteObject, contextIoPtr, NULL, NULL, NULL); result = Itcl_NRRunCallbacks(interp, callbackPtr); if (result != TCL_OK) { return TCL_ERROR; } } return TCL_OK; } /* ARGSUSED */ int Itcl_DelObjectCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { return Tcl_NRCallObjProc(interp, NRDelObjectCmd, clientData, objc, objv); } /* * ------------------------------------------------------------------------ * 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 in a format that Tcl can use to find the same variable from * any context. * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_ScopeCmd( ClientData dummy, /* unused */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Namespace *contextNsPtr; Tcl_HashEntry *hPtr; Tcl_Object oPtr; Tcl_Obj *objPtr2; Tcl_Var var; Tcl_HashEntry *entry; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; ItclObjectInfo *infoPtr; ItclVarLookup *vlookup; char *openParen; char *p; char *token; int doAppend; int result; (void)dummy; ItclShowArgs(1, "Itcl_ScopeCmd", objc, objv); if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "varname"); return TCL_ERROR; } contextNsPtr = Tcl_GetCurrentNamespace(interp); openParen = NULL; result = TCL_OK; /* * If this looks like a fully qualified name already, * then return it as is. */ token = Tcl_GetString(objv[1]); 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. */ contextIoPtr = NULL; contextIclsPtr = NULL; oPtr = NULL; infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)contextNsPtr); if (hPtr != NULL) { contextIclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); } if (Itcl_IsClassNamespace(contextNsPtr)) { ClientData clientData; entry = ItclResolveVarEntry(contextIclsPtr, token); if (!entry) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "variable \"", token, "\" not found in class \"", Tcl_GetString(contextIclsPtr->fullNamePtr), "\"", NULL); result = TCL_ERROR; goto scopeCmdDone; } vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); if (vlookup->ivPtr->flags & ITCL_COMMON) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); if (vlookup->ivPtr->protection != ITCL_PUBLIC) { Tcl_AppendToObj(resultPtr, ITCL_VARIABLES_NAMESPACE, -1); } Tcl_AppendToObj(resultPtr, Tcl_GetString(vlookup->ivPtr->fullNamePtr), -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 as a fully qualified name. */ infoPtr = contextIclsPtr->infoPtr; clientData = Itcl_GetCallFrameClientData(interp); if (clientData != NULL) { oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)clientData); if (oPtr != NULL) { contextIoPtr = (ItclObject*)Tcl_ObjectGetMetadata( oPtr, infoPtr->object_meta_type); } } if (contextIoPtr == NULL) { if (infoPtr->currIoPtr != NULL) { contextIoPtr = infoPtr->currIoPtr; } } if (contextIoPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't scope variable \"", token, "\": missing object context", NULL); result = TCL_ERROR; goto scopeCmdDone; } doAppend = 1; if (contextIclsPtr->flags & ITCL_ECLASS) { if (strcmp(token, "itcl_options") == 0) { doAppend = 0; } } objPtr2 = Tcl_NewStringObj(NULL, 0); Tcl_IncrRefCount(objPtr2); Tcl_AppendToObj(objPtr2, ITCL_VARIABLES_NAMESPACE, -1); Tcl_AppendToObj(objPtr2, (Tcl_GetObjectNamespace(contextIoPtr->oPtr))->fullName, -1); if (doAppend) { Tcl_AppendToObj(objPtr2, Tcl_GetString(vlookup->ivPtr->fullNamePtr), -1); } else { Tcl_AppendToObj(objPtr2, "::", -1); Tcl_AppendToObj(objPtr2, Tcl_GetString(vlookup->ivPtr->namePtr), -1); } if (openParen) { *openParen = '('; Tcl_AppendToObj(objPtr2, openParen, -1); openParen = NULL; } /* fix for SF bug #238 use Tcl_AppendResult instead of Tcl_AppendElement */ Tcl_AppendResult(interp, Tcl_GetString(objPtr2), NULL); Tcl_DecrRefCount(objPtr2); } else { /* * 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. */ Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); var = Itcl_FindNamespaceVar(interp, token, contextNsPtr, TCL_NAMESPACE_ONLY); if (!var) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "variable \"", token, "\" not found in namespace \"", contextNsPtr->fullName, "\"", NULL); result = TCL_ERROR; goto scopeCmdDone; } Itcl_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( 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); Tcl_Obj *listPtr; Tcl_Obj *objPtr; const char *token; int pos; (void)dummy; ItclShowArgs(1, "Itcl_CodeCmd", objc, objv); /* * Handle flags like "-namespace"... */ for (pos=1; pos < objc; pos++) { token = Tcl_GetString(objv[pos]); 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_GetString(objv[pos+1]); contextNs = Tcl_FindNamespace(interp, token, NULL, TCL_LEAVE_ERR_MSG); if (!contextNs) { return TCL_ERROR; } pos++; } } else { if (strcmp(token, "--") == 0) { pos++; break; } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option \"", token, "\": should be -namespace or --", 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, 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_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 * * Returns 1 if it is an object, 0 otherwise * ------------------------------------------------------------------------ */ int Itcl_IsObjectCmd( ClientData dummy, /* 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 = NULL; char *cname; char *cmdName; char *token; Tcl_Command cmd; Tcl_Namespace *contextNs = NULL; ItclClass *iclsPtr = NULL; (void)dummy; /* * 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]); iclsPtr = Itcl_FindClass(interp, cname, /* no autoload */ 0); if (iclsPtr == 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_NewWideIntObj(0)); ckfree((char *)cmdName); return TCL_OK; } /* * Handle the case when the -class flag is given */ if (classFlag) { ItclObject *contextIoPtr; if (Itcl_FindObject(interp, cmdName, &contextIoPtr) != TCL_OK) { return TCL_ERROR; } if (contextIoPtr == NULL) { /* seems that we are in constructor, so look for currIoPtr in info structure */ contextIoPtr = iclsPtr->infoPtr->currIoPtr; } if (! Itcl_ObjectIsa(contextIoPtr, iclsPtr)) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); ckfree((char *)cmdName); return TCL_OK; } } /* * Got this far, so assume that it is a valid object */ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(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 * * Returns 1 if it is a class, 0 otherwise * ------------------------------------------------------------------------ */ int Itcl_IsClassCmd( ClientData dummy, /* class/object info */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { char *cname; char *name; ItclClass *iclsPtr = NULL; Tcl_Namespace *contextNs = NULL; (void)dummy; /* * 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; } iclsPtr = Itcl_FindClass(interp, cname, /* no autoload */ 0); /* * If classDefn is NULL, then it wasn't found, hence it * isn't a class */ if (iclsPtr != NULL) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); } else { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); } ckfree(cname); return TCL_OK; } /* end Itcl_IsClassCmd function */ /* * ------------------------------------------------------------------------ * Itcl_FilterCmd() * * Used to add a filter command to an object which is called just before * a method/proc of a class is executed * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_FilterAddCmd( ClientData dummy, /* unused */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj **newObjv; int result; (void)dummy; ItclShowArgs(1, "Itcl_FilterCmd", objc, objv); /* Tcl_Namespace *contextNs = Tcl_GetCurrentNamespace(interp); */ /* FIXME need to change the chain command to do the same here as the TclOO next command !! */ if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, " ? ...?"); return TCL_ERROR; } newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+1)); newObjv[0] = Tcl_NewStringObj("::oo::define", -1); Tcl_IncrRefCount(newObjv[0]); newObjv[1] = objv[1]; newObjv[2] = Tcl_NewStringObj("filter", -1); Tcl_IncrRefCount(newObjv[2]); memcpy(newObjv+3, objv+2, sizeof(Tcl_Obj *)*(objc-2)); ItclShowArgs(1, "Itcl_FilterAddCmd2", objc+1, newObjv); result = Tcl_EvalObjv(interp, objc+1, newObjv, 0); Tcl_DecrRefCount(newObjv[0]); Tcl_DecrRefCount(newObjv[2]); return result; } /* * ------------------------------------------------------------------------ * Itcl_FilterDeleteCmd() * * used to delete filter commands of a class or object * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_FilterDeleteCmd( ClientData dummy, /* unused */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { (void)dummy; ItclShowArgs(1, "Itcl_FilterDeleteCmd", objc, objv); /* Tcl_Namespace *contextNs = Tcl_GetCurrentNamespace(interp); */ Tcl_AppendResult(interp, "::itcl::filter delete command not yet implemented", NULL); return TCL_ERROR; } /* * ------------------------------------------------------------------------ * Itcl_ForwardAddCmd() * * Used to similar to iterp alias to forward the call of a method * to another method within the class * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_ForwardAddCmd( ClientData dummy, /* unused */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *prefixObj; Tcl_Method mPtr; ItclObjectInfo *infoPtr; ItclClass *iclsPtr; (void)dummy; ItclShowArgs(1, "Itcl_ForwardAddCmd", objc, objv); if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, " ? ...?"); return TCL_ERROR; } infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); if (iclsPtr == NULL) { Tcl_HashEntry *hPtr; hPtr = Tcl_FindHashEntry(&infoPtr->nameClasses, (char *)objv[1]); if (hPtr == NULL) { Tcl_AppendResult(interp, "class: \"", Tcl_GetString(objv[1]), "\" not found", NULL); return TCL_ERROR; } iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); } prefixObj = Tcl_NewListObj(objc-2, objv+2); mPtr = Itcl_NewForwardClassMethod(interp, iclsPtr->clsPtr, 1, objv[1], prefixObj); if (mPtr == NULL) { return TCL_ERROR; } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ForwardDeleteCmd() * * used to delete forwarded commands of a class or object * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_ForwardDeleteCmd( ClientData dummy, /* unused */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { (void)dummy; ItclShowArgs(1, "Itcl_ForwardDeleteCmd", objc, objv); /* Tcl_Namespace *contextNs = Tcl_GetCurrentNamespace(interp); */ Tcl_AppendResult(interp, "::itcl::forward delete command not yet implemented", NULL); return TCL_ERROR; } /* * ------------------------------------------------------------------------ * Itcl_MixinAddCmd() * * Used to add the methods of a class to another class without heritance * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_MixinAddCmd( ClientData dummy, /* unused */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj **newObjv; int result; (void)dummy; ItclShowArgs(1, "Itcl_MixinAddCmd", objc, objv); if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, " ? ...?"); return TCL_ERROR; } newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+1)); newObjv[0] = Tcl_NewStringObj("::oo::define", -1); Tcl_IncrRefCount(newObjv[0]); newObjv[1] = objv[1]; newObjv[2] = Tcl_NewStringObj("mixin", -1); Tcl_IncrRefCount(newObjv[2]); memcpy(newObjv+3, objv+2, sizeof(Tcl_Obj *)*(objc-2)); ItclShowArgs(1, "Itcl_MixinAddCmd2", objc+1, newObjv); result = Tcl_EvalObjv(interp, objc+1, newObjv, 0); Tcl_DecrRefCount(newObjv[0]); Tcl_DecrRefCount(newObjv[2]); return result; } /* * ------------------------------------------------------------------------ * Itcl_MixinDeleteCmd() * * Used to delete the methods of a class to another class without heritance * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_MixinDeleteCmd( ClientData dummy, /* unused */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { (void)dummy; ItclShowArgs(1, "Itcl_MixinDeleteCmd", objc, objv); /* Tcl_Namespace *contextNs = Tcl_GetCurrentNamespace(interp); */ Tcl_AppendResult(interp, "::itcl::mixin delete command not yet implemented", NULL); return TCL_ERROR; } /* * ------------------------------------------------------------------------ * Itcl_NWidgetCmd() * * Used to build an [incr Tcl] nwidget * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_NWidgetCmd( ClientData clientData, /* infoPtr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclClass *iclsPtr; int result; iclsPtr = NULL; ItclShowArgs(0, "Itcl_NWidgetCmd", objc-1, objv); result = ItclClassBaseCmd(clientData, interp, ITCL_ECLASS|ITCL_NWIDGET, objc, objv, &iclsPtr); if (result != TCL_OK) { return result; } if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Itcl_NWidgetCmd!iclsPtr == NULL\n", NULL); result = TCL_ERROR; } return result; } /* * ------------------------------------------------------------------------ * Itcl_AddOptionCmd() * * Used to build an option to an [incr Tcl] nwidget/eclass * * Syntax: ::itcl::addoption * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_AddOptionCmd( ClientData clientData, /* infoPtr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_HashEntry *hPtr; ItclObjectInfo *infoPtr; ItclClass *iclsPtr; const char *protectionStr; int pLevel; int result; result = TCL_OK; infoPtr = (ItclObjectInfo *)clientData; ItclShowArgs(1, "Itcl_AddOptionCmd", objc, objv); if (objc < 4) { Tcl_WrongNumArgs(interp, 1, objv, "className protection option optionName ..."); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&infoPtr->nameClasses, (char *)objv[1]); if (hPtr == NULL) { Tcl_AppendResult(interp, "class \"", Tcl_GetString(objv[1]), "\" not found", NULL); return TCL_ERROR; } iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); protectionStr = Tcl_GetString(objv[2]); pLevel = -1; if (strcmp(protectionStr, "public") == 0) { pLevel = ITCL_PUBLIC; } if (strcmp(protectionStr, "protected") == 0) { pLevel = ITCL_PROTECTED; } if (strcmp(protectionStr, "private") == 0) { pLevel = ITCL_PRIVATE; } if (pLevel == -1) { Tcl_AppendResult(interp, "bad protection \"", protectionStr, "\"", NULL); return TCL_ERROR; } Itcl_PushStack(iclsPtr, &infoPtr->clsStack); result = Itcl_ClassOptionCmd(clientData, interp, objc-2, objv+2); Itcl_PopStack(&infoPtr->clsStack); if (result != TCL_OK) { return result; } result = DelegatedOptionsInstall(interp, iclsPtr); return result; } /* * ------------------------------------------------------------------------ * Itcl_AddObjectOptionCmd() * * Used to build an option for an [incr Tcl] object * * Syntax: ::itcl::addobjectoption option * ?-default ? * ?-configuremethod ? * ?-validatemethod ? * ?-cgetmethod ? * ?-configuremethodvar ? * ?-validatemethodvar ? * ?-cgetmethodvar ? * ?-readonly? * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_AddObjectOptionCmd( ClientData clientData, /* infoPtr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_HashEntry *hPtr; Tcl_Command cmd; Tcl_Obj *objPtr; ItclObjectInfo *infoPtr; ItclObject *ioPtr; ItclOption *ioptPtr; const char *protectionStr; int pLevel; int isNew; ioptPtr = NULL; infoPtr = (ItclObjectInfo *)clientData; ItclShowArgs(1, "Itcl_AddObjectOptionCmd", objc, objv); if (objc < 4) { Tcl_WrongNumArgs(interp, 1, objv, "objectName protection option optionName ..."); return TCL_ERROR; } cmd = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL, 0); if (cmd == NULL) { Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), "\" not found", NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&infoPtr->objectCmds, (char *)cmd); if (hPtr == NULL) { Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), "\" not found", NULL); return TCL_ERROR; } ioPtr = (ItclObject *)Tcl_GetHashValue(hPtr); protectionStr = Tcl_GetString(objv[2]); pLevel = -1; if (strcmp(protectionStr, "public") == 0) { pLevel = ITCL_PUBLIC; } if (strcmp(protectionStr, "protected") == 0) { pLevel = ITCL_PROTECTED; } if (strcmp(protectionStr, "private") == 0) { pLevel = ITCL_PRIVATE; } if (pLevel == -1) { Tcl_AppendResult(interp, "bad protection \"", protectionStr, "\"", NULL); return TCL_ERROR; } infoPtr->protection = pLevel; if (ItclParseOption(infoPtr, interp, objc-3, objv+3, NULL, ioPtr, &ioptPtr) != TCL_OK) { return TCL_ERROR; } objPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, ioPtr->accessCmd, objPtr); ioptPtr->fullNamePtr = Tcl_NewStringObj( Tcl_GetString(ioPtr->namePtr), -1); Tcl_AppendToObj(ioptPtr->fullNamePtr, "::", 2); Tcl_AppendToObj(ioptPtr->fullNamePtr, Tcl_GetString(ioptPtr->namePtr), -1); Tcl_IncrRefCount(ioptPtr->fullNamePtr); hPtr = Tcl_CreateHashEntry(&ioPtr->objectOptions, (char *)ioptPtr->namePtr, &isNew); Tcl_SetHashValue(hPtr, ioptPtr); ItclSetInstanceVar(interp, "itcl_options", Tcl_GetString(ioptPtr->namePtr), Tcl_GetString(ioptPtr->defaultValuePtr), ioPtr, NULL); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_AddDelegatedOptionCmd() * * Used to build an option to an [incr Tcl] nwidget/eclass * * Syntax: ::itcl::adddelegatedoption * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_AddDelegatedOptionCmd( ClientData clientData, /* infoPtr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_HashEntry *hPtr; Tcl_Command cmd; ItclObjectInfo *infoPtr; ItclObject *ioPtr; ItclDelegatedOption *idoPtr; int isNew; int result; result = TCL_OK; infoPtr = (ItclObjectInfo *)clientData; ItclShowArgs(1, "Itcl_AddDelegatedOptionCmd", objc, objv); if (objc < 4) { Tcl_WrongNumArgs(interp, 1, objv, "className protection option optionName ..."); return TCL_ERROR; } cmd = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL, 0); if (cmd == NULL) { Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), "\" not found", NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&infoPtr->objectCmds, (char *)cmd); if (hPtr == NULL) { Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), "\" not found", NULL); return TCL_ERROR; } ioPtr = (ItclObject *)Tcl_GetHashValue(hPtr); result = Itcl_HandleDelegateOptionCmd(interp, ioPtr, NULL, &idoPtr, objc-3, objv+3); if (result != TCL_OK) { return result; } hPtr = Tcl_CreateHashEntry(&ioPtr->objectDelegatedOptions, (char *)idoPtr->namePtr, &isNew); Tcl_SetHashValue(hPtr, idoPtr); return result; } /* * ------------------------------------------------------------------------ * Itcl_AddDelegatedFunctionCmd() * * Used to build an function to an [incr Tcl] nwidget/eclass * * Syntax: ::itcl::adddelegatedfunction ... * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_AddDelegatedFunctionCmd( ClientData clientData, /* infoPtr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_HashEntry *hPtr; Tcl_Command cmd; Tcl_Obj *componentNamePtr; ItclObjectInfo *infoPtr; ItclObject *ioPtr; ItclClass *iclsPtr; ItclDelegatedFunction *idmPtr; ItclHierIter hier; const char *val; int isNew; int result; result = TCL_OK; infoPtr = (ItclObjectInfo *)clientData; ItclShowArgs(1, "Itcl_AddDelegatedFunctionCmd", objc, objv); if (objc < 4) { Tcl_WrongNumArgs(interp, 1, objv, "className protection method/proc functionName ..."); return TCL_ERROR; } cmd = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL, 0); if (cmd == NULL) { Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), "\" not found", NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&infoPtr->objectCmds, (char *)cmd); if (hPtr == NULL) { Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), "\" not found", NULL); return TCL_ERROR; } ioPtr = (ItclObject *)Tcl_GetHashValue(hPtr); result = Itcl_HandleDelegateMethodCmd(interp, ioPtr, NULL, &idmPtr, objc-3, objv+3); if (result != TCL_OK) { return result; } componentNamePtr = idmPtr->icPtr->namePtr; Itcl_InitHierIter(&hier, ioPtr->iclsPtr); while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FindHashEntry(&iclsPtr->components, (char *) componentNamePtr); if (hPtr != NULL) { break; } } Itcl_DeleteHierIter(&hier); val = Itcl_GetInstanceVar(interp, Tcl_GetString(componentNamePtr), ioPtr, iclsPtr); componentNamePtr = Tcl_NewStringObj(val, -1); Tcl_IncrRefCount(componentNamePtr); DelegateFunction(interp, ioPtr, ioPtr->iclsPtr, componentNamePtr, idmPtr); hPtr = Tcl_CreateHashEntry(&ioPtr->objectDelegatedFunctions, (char *)idmPtr->namePtr, &isNew); Tcl_DecrRefCount(componentNamePtr); Tcl_SetHashValue(hPtr, idmPtr); return result; } /* * ------------------------------------------------------------------------ * Itcl_AddComponentCmd() * * Used to add a component to an [incr Tcl] nwidget/eclass * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_AddComponentCmd( ClientData dummy, /* infoPtr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_HashEntry *hPtr; Tcl_DString buffer; Tcl_DString buffer2; Tcl_Namespace *varNsPtr; Tcl_Namespace *nsPtr; Tcl_CallFrame frame; Tcl_Var varPtr; ItclVarLookup *vlookup; ItclObject *contextIoPtr; ItclClass *contextIclsPtr; ItclComponent *icPtr; ItclVariable *ivPtr; const char *varName; int isNew; int result; (void)dummy; result = TCL_OK; contextIoPtr = NULL; ItclShowArgs(1, "Itcl_AddComponentCmd", objc, objv); if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "objectName componentName"); return TCL_ERROR; } if (Itcl_FindObject(interp, Tcl_GetString(objv[1]), &contextIoPtr) != TCL_OK) { return TCL_ERROR; } if (contextIoPtr == NULL) { Tcl_AppendResult(interp, "Itcl_AddComponentCmd contextIoPtr " "for \"", Tcl_GetString(objv[1]), "\" == NULL", NULL); return TCL_ERROR; } contextIclsPtr = contextIoPtr->iclsPtr; hPtr = Tcl_CreateHashEntry(&contextIoPtr->objectComponents, (char *)objv[2], &isNew); if (!isNew) { Tcl_AppendResult(interp, "Itcl_AddComponentCmd component \"", Tcl_GetString(objv[2]), "\" already exists for object \"", Tcl_GetString(objv[1]), "\"", NULL); return TCL_ERROR; } if (ItclCreateComponent(interp, contextIclsPtr, objv[2], /* not common */0, &icPtr) != TCL_OK) { return TCL_ERROR; } ItclAddClassComponentDictInfo(interp, contextIclsPtr, icPtr); contextIclsPtr->numVariables++; Tcl_SetHashValue(hPtr, icPtr); Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace(contextIoPtr->oPtr))->fullName, -1); Tcl_DStringAppend(&buffer, contextIclsPtr->nsPtr->fullName, -1); varNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), NULL, 0); hPtr = Tcl_FindHashEntry(&contextIclsPtr->variables, (char *)objv[2]); if (hPtr == NULL) { Tcl_AppendResult(interp, "Itcl_AddComponentCmd cannot find component", " \"", Tcl_GetString(objv[2]), "\"in class variables", NULL); return TCL_ERROR; } ivPtr = (ItclVariable *)Tcl_GetHashValue(hPtr); /* add entry to the virtual tables */ vlookup = (ItclVarLookup *)ckalloc(sizeof(ItclVarLookup)); vlookup->ivPtr = ivPtr; vlookup->usage = 0; vlookup->leastQualName = NULL; /* * If this variable is PRIVATE to another class scope, * then mark it as "inaccessible". */ vlookup->accessible = (ivPtr->protection != ITCL_PRIVATE || ivPtr->iclsPtr == contextIclsPtr); vlookup->varNum = contextIclsPtr->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, Tcl_GetString(ivPtr->namePtr), -1); nsPtr = contextIclsPtr->nsPtr; Tcl_DStringInit(&buffer2); while (1) { hPtr = Tcl_CreateHashEntry(&contextIclsPtr->resolveVars, Tcl_DStringValue(&buffer), &isNew); if (isNew) { Tcl_SetHashValue(hPtr, vlookup); vlookup->usage++; if (!vlookup->leastQualName) { vlookup->leastQualName = (char *) Tcl_GetHashKey(&contextIclsPtr->resolveVars, hPtr); } } 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; } Tcl_DStringFree(&buffer2); Tcl_DStringFree(&buffer); varName = Tcl_GetString(ivPtr->namePtr); /* now initialize the variable */ if (Itcl_PushCallFrame(interp, &frame, varNsPtr, /*isProcCallFrame*/0) != TCL_OK) { return TCL_ERROR; } if (Tcl_SetVar2(interp, varName, NULL, "", TCL_NAMESPACE_ONLY) == NULL) { Tcl_AppendResult(interp, "INTERNAL ERROR cannot set", " variable \"", varName, "\"\n", NULL); result = TCL_ERROR; } Itcl_PopCallFrame(interp); varPtr = Tcl_NewNamespaceVar(interp, varNsPtr, Tcl_GetString(ivPtr->namePtr)); hPtr = Tcl_CreateHashEntry(&contextIoPtr->objectVariables, (char *)ivPtr, &isNew); if (isNew) { Itcl_PreserveVar(varPtr); Tcl_SetHashValue(hPtr, varPtr); } else { } return result; } /* * ------------------------------------------------------------------------ * Itcl_SetComponentCmd() * * Used to set a component for an [incr Tcl] nwidget/eclass * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_SetComponentCmd( ClientData dummy, /* infoPtr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; ItclClass *iclsPtr; ItclObject *contextIoPtr; ItclClass *contextIclsPtr; ItclComponent *icPtr; ItclDelegatedOption *idoPtr; ItclHierIter hier; const char *name; const char *val; int result; (void)dummy; result = TCL_OK; contextIoPtr = NULL; ItclShowArgs(1, "Itcl_SetComponentCmd", objc, objv); if (objc < 4) { Tcl_WrongNumArgs(interp, 1, objv, "objectName componentName value"); return TCL_ERROR; } name = Tcl_GetString(objv[1]); if (Itcl_FindObject(interp, name, &contextIoPtr) != TCL_OK) { return TCL_ERROR; } if (contextIoPtr == NULL) { Tcl_AppendResult(interp, "Itcl_SetComponentCmd contextIoPtr " "for \"", Tcl_GetString(objv[1]), "\" == NULL", NULL); return TCL_ERROR; } Itcl_InitHierIter(&hier, contextIoPtr->iclsPtr); hPtr = NULL; while ((contextIclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FindHashEntry(&contextIclsPtr->components, (char *)objv[2]); if (hPtr != NULL) { break; } } Itcl_DeleteHierIter(&hier); if (hPtr == NULL) { Tcl_AppendResult(interp, "object \"", Tcl_GetString(objv[1]), "\" has no component \"", Tcl_GetString(objv[2]), "\"", NULL); return TCL_ERROR; } icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr), NULL, contextIoPtr, contextIclsPtr); if ((val != NULL) && (strlen(val) != 0)) { /* delete delegated options to the old component here !! */ Itcl_InitHierIter(&hier, contextIoPtr->iclsPtr); while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) { FOREACH_HASH_VALUE(idoPtr, &iclsPtr->delegatedOptions) { if (strcmp(Tcl_GetString(idoPtr->icPtr->namePtr), Tcl_GetString(objv[2])) == 0) { Tcl_DeleteHashEntry(hPtr); } } } Itcl_DeleteHierIter(&hier); } if (ItclSetInstanceVar(interp, Tcl_GetString(icPtr->namePtr), NULL, Tcl_GetString(objv[3]), contextIoPtr, contextIclsPtr) == NULL) { return TCL_ERROR; } val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr), NULL, contextIoPtr, contextIclsPtr); return result; } /* * ------------------------------------------------------------------------ * Itcl_ExtendedClassCmd() * * Used to create an [incr Tcl] extended class. * An extended class is like a class with additional functionality/ * commands * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_ExtendedClassCmd( ClientData clientData, /* infoPtr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclClass *iclsPtr; int result; ItclShowArgs(1, "Itcl_ExtendedClassCmd", objc-1, objv); result = ItclClassBaseCmd(clientData, interp, ITCL_ECLASS, objc, objv, &iclsPtr); if ((iclsPtr == NULL) && (result == TCL_OK)) { ItclShowArgs(0, "Itcl_ExtendedClassCmd iclsPtr == NULL", objc-1, objv); return TCL_ERROR; } return result; } /* * ------------------------------------------------------------------------ * Itcl_TypeClassCmd() * * Used to create an [incr Tcl] type class. * An type class is like a class with additional functionality/ * commands. it has no methods and vars but only the equivalent * of proc and common namely typemethod and typevariable * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_TypeClassCmd( ClientData clientData, /* infoPtr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *objPtr; ItclClass *iclsPtr; int result; ItclShowArgs(1, "Itcl_TypeClassCmd", objc-1, objv); result = ItclClassBaseCmd(clientData, interp, ITCL_TYPE, objc, objv, &iclsPtr); if ((iclsPtr == NULL) && (result == TCL_OK)) { ItclShowArgs(0, "Itcl_TypeClassCmd iclsPtr == NULL", objc-1, objv); return TCL_ERROR; } if (result != TCL_OK) { return result; } /* we handle create by ourself !! */ objPtr = Tcl_NewStringObj("oo::objdefine ", -1); Tcl_AppendToObj(objPtr, iclsPtr->nsPtr->fullName, -1); Tcl_AppendToObj(objPtr, " unexport create", -1); Tcl_IncrRefCount(objPtr); result = Tcl_EvalObjEx(interp, objPtr, 0); Tcl_DecrRefCount(objPtr); objPtr = Tcl_NewStringObj(iclsPtr->nsPtr->fullName, -1); Tcl_SetObjResult(interp, objPtr); return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassHullTypeCmd() * * Used to set a hulltype for a widget * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_ClassHullTypeCmd( ClientData clientData, /* infoPtr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclClass *iclsPtr; ItclObjectInfo *infoPtr; const char *hullTypeName; int correctArg; infoPtr = (ItclObjectInfo *)clientData; iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); ItclShowArgs(1, "Itcl_ClassHullTypeCmd", objc-1, objv); if (iclsPtr->flags & ITCL_TYPE) { Tcl_AppendResult(interp, "can't set hulltype for ::itcl::type", NULL); return TCL_ERROR; } if (iclsPtr->flags & ITCL_WIDGETADAPTOR) { Tcl_AppendResult(interp, "can't set hulltype for ", "::itcl::widgetadaptor", NULL); return TCL_ERROR; } if (objc != 2) { Tcl_AppendResult(interp, "wrong # args should be: hulltype ", "", NULL); return TCL_ERROR; } if (iclsPtr->flags & ITCL_WIDGET) { hullTypeName = Tcl_GetString(objv[1]); if (iclsPtr->hullTypePtr != NULL) { Tcl_AppendResult(interp, "too many hulltype statements", NULL); return TCL_ERROR; } correctArg = 0; if (strcmp(hullTypeName, "frame") == 0) { iclsPtr->flags |= ITCL_WIDGET_FRAME; correctArg = 1; } if (strcmp(hullTypeName, "labelframe") == 0) { iclsPtr->flags |= ITCL_WIDGET_LABEL_FRAME; correctArg = 1; } if (strcmp(hullTypeName, "toplevel") == 0) { iclsPtr->flags |= ITCL_WIDGET_TOPLEVEL; correctArg = 1; } if (strcmp(hullTypeName, "ttk::frame") == 0) { iclsPtr->flags |= ITCL_WIDGET_TTK_FRAME; correctArg = 1; } if (strcmp(hullTypeName, "ttk::labelframe") == 0) { iclsPtr->flags |= ITCL_WIDGET_TTK_LABEL_FRAME; correctArg = 1; } if (strcmp(hullTypeName, "ttk::toplevel") == 0) { iclsPtr->flags |= ITCL_WIDGET_TTK_TOPLEVEL; correctArg = 1; } if (!correctArg) { Tcl_AppendResult(interp, "syntax: must be hulltype frame|toplevel|labelframe|", "ttk::frame|ttk::toplevel|ttk::labelframe", NULL); return TCL_ERROR; } iclsPtr->hullTypePtr = Tcl_NewStringObj(hullTypeName, -1); Tcl_IncrRefCount(iclsPtr->hullTypePtr); return TCL_OK; } Tcl_AppendResult(interp, "invalid command name \"hulltype\"", NULL); return TCL_ERROR; } /* * ------------------------------------------------------------------------ * Itcl_ClassWidgetClassCmd() * * Used to set a widgetclass for a widget * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_ClassWidgetClassCmd( ClientData clientData, /* infoPtr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclClass *iclsPtr; ItclObjectInfo *infoPtr; const char *widgetClassName; infoPtr = (ItclObjectInfo *)clientData; iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); ItclShowArgs(1, "Itcl_ClassWidgetClassCmd", objc-1, objv); if (iclsPtr->flags & ITCL_TYPE) { Tcl_AppendResult(interp, "can't set widgetclass for ::itcl::type", NULL); return TCL_ERROR; } if (iclsPtr->flags & ITCL_WIDGETADAPTOR) { Tcl_AppendResult(interp, "can't set widgetclass for ", "::itcl::widgetadaptor", NULL); return TCL_ERROR; } if (objc != 2) { Tcl_AppendResult(interp, "wrong # args should be: widgetclass ", "", NULL); return TCL_ERROR; } if (iclsPtr->flags & ITCL_WIDGET) { widgetClassName = Tcl_GetString(objv[1]); if (!isupper(UCHAR(*widgetClassName))) { Tcl_AppendResult(interp, "widgetclass \"", widgetClassName, "\" does not begin with an uppercase letter", NULL); return TCL_ERROR; } if (iclsPtr->widgetClassPtr != NULL) { Tcl_AppendResult(interp, "too many widgetclass statements", NULL); return TCL_ERROR; } iclsPtr->widgetClassPtr = Tcl_NewStringObj(widgetClassName, -1); Tcl_IncrRefCount(iclsPtr->widgetClassPtr); return TCL_OK; } Tcl_AppendResult(interp, "invalid command name \"widgetclass\"", NULL); return TCL_ERROR; }