/* * ------------------------------------------------------------------------ * 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 * * 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 "itclInt.h" static Tcl_ObjCmdProc Itcl_BiInfoClassOptionsCmd; static Tcl_ObjCmdProc Itcl_BiInfoComponentsCmd; static Tcl_ObjCmdProc Itcl_BiInfoDefaultCmd; static Tcl_ObjCmdProc Itcl_BiInfoDelegatedCmd; static Tcl_ObjCmdProc Itcl_BiInfoExtendedClassCmd; static Tcl_ObjCmdProc Itcl_BiInfoInstancesCmd; static Tcl_ObjCmdProc Itcl_BiInfoHullTypeCmd; static Tcl_ObjCmdProc Itcl_BiInfoMethodCmd; static Tcl_ObjCmdProc Itcl_BiInfoMethodsCmd; static Tcl_ObjCmdProc Itcl_BiInfoOptionsCmd; static Tcl_ObjCmdProc Itcl_BiInfoTypeCmd; static Tcl_ObjCmdProc Itcl_BiInfoTypeMethodCmd; static Tcl_ObjCmdProc Itcl_BiInfoTypeMethodsCmd; static Tcl_ObjCmdProc Itcl_BiInfoTypesCmd; static Tcl_ObjCmdProc Itcl_BiInfoTypeVarsCmd; static Tcl_ObjCmdProc Itcl_BiInfoTypeVariableCmd; static Tcl_ObjCmdProc Itcl_BiInfoVariablesCmd; static Tcl_ObjCmdProc Itcl_BiInfoWidgetadaptorCmd; static Tcl_ObjCmdProc Itcl_BiInfoWidgetCmd; static Tcl_ObjCmdProc Itcl_BiInfoDelegatedOptionsCmd; static Tcl_ObjCmdProc Itcl_BiInfoDelegatedMethodsCmd; static Tcl_ObjCmdProc Itcl_BiInfoDelegatedTypeMethodsCmd; static Tcl_ObjCmdProc Itcl_BiInfoDelegatedOptionCmd; static Tcl_ObjCmdProc Itcl_BiInfoDelegatedMethodCmd; static Tcl_ObjCmdProc Itcl_BiInfoDelegatedTypeMethodCmd; static Tcl_ObjCmdProc Itcl_BiInfoDelegatedUnknownCmd; static Tcl_ObjCmdProc Itcl_BiInfoContextCmd; typedef struct InfoMethod { const char* name; /* method name */ const char* usage; /* string describing usage */ Tcl_ObjCmdProc *proc; /* implementation C proc */ int flags; /* which class commands have it */ } InfoMethod; static const InfoMethod InfoMethodList[] = { { "args", "procname", Itcl_BiInfoArgsCmd, ITCL_CLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "body", "procname", Itcl_BiInfoBodyCmd, ITCL_CLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "class", "", Itcl_BiInfoClassCmd, ITCL_CLASS|ITCL_WIDGET|ITCL_ECLASS }, { "classoptions", "?pattern?", Itcl_BiInfoClassOptionsCmd, ITCL_ECLASS }, { "component", "?name? ?-inherit? ?-value?", Itcl_BiInfoComponentCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "context", "", Itcl_BiInfoContextCmd, ITCL_ECLASS }, { "components", "?pattern?", Itcl_BiInfoComponentsCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "default", "method aname varname", Itcl_BiInfoDefaultCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "delegated", "?name? ?-inherit? ?-value?", Itcl_BiInfoDelegatedCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "extendedclass", "", Itcl_BiInfoExtendedClassCmd, ITCL_ECLASS }, { "function", "?name? ?-protection? ?-type? ?-name? ?-args? ?-body?", Itcl_BiInfoFunctionCmd, ITCL_CLASS|ITCL_ECLASS }, { "heritage", "", Itcl_BiInfoHeritageCmd, ITCL_CLASS|ITCL_WIDGET|ITCL_ECLASS }, { "hulltype", "", Itcl_BiInfoHullTypeCmd, ITCL_WIDGET }, { "hulltypes", "?pattern?", Itcl_BiInfoUnknownCmd, ITCL_WIDGETADAPTOR|ITCL_WIDGET }, { "inherit", "", Itcl_BiInfoInheritCmd, ITCL_CLASS|ITCL_WIDGET|ITCL_ECLASS }, { "instances", "?pattern?", Itcl_BiInfoInstancesCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET }, { "method", "?name? ?-protection? ?-type? ?-name? ?-args? ?-body?", Itcl_BiInfoMethodCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "methods", "?pattern?", Itcl_BiInfoMethodsCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "option", "?name? ?-protection? ?-resource? ?-class? ?-name? ?-default? \ ?-cgetmethod? ?-configuremethod? ?-validatemethod? \ ?-cgetmethodvar? ?-configuremethodvar? ?-validatemethodvar? \ ?-value?", Itcl_BiInfoOptionCmd, ITCL_WIDGET|ITCL_ECLASS }, { "options", "?pattern?", Itcl_BiInfoOptionsCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "type", "", Itcl_BiInfoTypeCmd, ITCL_TYPE|ITCL_WIDGET|ITCL_ECLASS }, { "typemethod", "?name? ?-protection? ?-type? ?-name? ?-args? ?-body?", Itcl_BiInfoTypeMethodCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "typemethods", "?pattern?", Itcl_BiInfoTypeMethodsCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "types", "?pattern?", Itcl_BiInfoTypesCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "typevariable", "?name? ?-protection? ?-type? ?-name? ?-init? ?-value?", Itcl_BiInfoTypeVariableCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "typevars", "?pattern?", Itcl_BiInfoTypeVarsCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "variable", "?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope?", Itcl_BiInfoVariableCmd, ITCL_CLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "variables", "?pattern?", Itcl_BiInfoVariablesCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "vars", "?pattern?", Itcl_BiInfoVarsCmd, ITCL_CLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "widget", "", Itcl_BiInfoWidgetCmd, ITCL_WIDGET }, { "widgets", "?pattern?", Itcl_BiInfoUnknownCmd, ITCL_WIDGET }, { "widgetclasses", "?pattern?", Itcl_BiInfoUnknownCmd, ITCL_WIDGET }, { "widgetadaptor", "", Itcl_BiInfoWidgetadaptorCmd, ITCL_WIDGETADAPTOR }, { "widgetadaptors", "?pattern?", Itcl_BiInfoUnknownCmd, ITCL_WIDGETADAPTOR }, { NULL, NULL, NULL, 0 } }; struct NameProcMap2 { const char* name; /* method name */ const char* usage; /* string describing usage */ Tcl_ObjCmdProc *proc; /* implementation C proc */ int flags; /* which class commands have it */ }; static const struct NameProcMap2 infoCmdsDelegated2[] = { { "::itcl::builtin::Info::delegated::methods", "?pattern?", Itcl_BiInfoDelegatedMethodsCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "::itcl::builtin::Info::delegated::typemethods", "?pattern?", Itcl_BiInfoDelegatedTypeMethodsCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "::itcl::builtin::Info::delegated::options", "?pattern?", Itcl_BiInfoDelegatedOptionsCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { "::itcl::builtin::Info::delegated::method", "methodName", Itcl_BiInfoDelegatedMethodCmd, ITCL_ECLASS }, { "::itcl::builtin::Info::delegated::typemethod", "methodName", Itcl_BiInfoDelegatedTypeMethodCmd, ITCL_ECLASS }, { "::itcl::builtin::Info::delegated::option", "methodName", Itcl_BiInfoDelegatedOptionCmd, ITCL_ECLASS }, { "::itcl::builtin::Info::delegated::unknown", "", Itcl_BiInfoDelegatedUnknownCmd, ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS }, { NULL, NULL, NULL, 0 } }; static void ItclGetInfoUsage(Tcl_Interp *interp, Tcl_Obj*objPtr, ItclObjectInfo *infoPtr, ItclClass *iclsPtr); /* * ------------------------------------------------------------------------ * ItclInfoInit() * * Creates a namespace full of built-in methods/procs for [incr Tcl] * classes. This includes things like the "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. * ------------------------------------------------------------------------ */ static int InfoGutsFinish( void *data[], TCL_UNUSED(Tcl_Interp *), int result) { Tcl_CallFrame *framePtr = (Tcl_CallFrame *) data[0]; ItclObjectInfo *infoPtr = (ItclObjectInfo *) data[1]; ItclCallContext *cPtr = (ItclCallContext *) data[2]; ItclCallContext *popped; Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&infoPtr->frameContext, (char *) framePtr); Itcl_Stack *stackPtr = (Itcl_Stack *) Tcl_GetHashValue(hPtr); popped = (ItclCallContext *)Itcl_PopStack(stackPtr); if (Itcl_GetStackSize(stackPtr) == 0) { Itcl_DeleteStack(stackPtr); ckfree((char *)stackPtr); Tcl_DeleteHashEntry(hPtr); } if (cPtr != popped) { Tcl_Panic("Context stack mismatch!"); } ckfree((char *) cPtr); return result; } int ItclInfoGuts( ItclObject *ioPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { ItclObjectInfo *infoPtr = ioPtr->infoPtr; Tcl_CmdInfo info; ItclCallContext *cPtr; Tcl_CallFrame *framePtr; Tcl_HashEntry *hPtr; Itcl_Stack *stackPtr; int isNew; if (objc == 2) { /* * No subcommand passed. Give good usage message. NOT the * default message of a Tcl ensemble. */ Tcl_Obj *objPtr = Tcl_NewStringObj( "wrong # args: should be one of...\n", TCL_INDEX_NONE); ItclGetInfoUsage(interp, objPtr, infoPtr, ioPtr->iclsPtr); Tcl_SetObjResult(interp, objPtr); return TCL_ERROR; } framePtr = Itcl_GetUplevelCallFrame(interp, 0); hPtr = Tcl_CreateHashEntry(&infoPtr->frameContext, (char *)framePtr, &isNew); if (isNew) { stackPtr = (Itcl_Stack *) ckalloc(sizeof(Itcl_Stack)); Itcl_InitStack(stackPtr); Tcl_SetHashValue(hPtr, stackPtr); } else { stackPtr = (Itcl_Stack *) Tcl_GetHashValue(hPtr); } cPtr = (ItclCallContext *) ckalloc(sizeof(ItclCallContext)); cPtr->objectFlags = ITCL_OBJECT_ROOT_METHOD; cPtr->nsPtr = NULL; cPtr->ioPtr = ioPtr; cPtr->imPtr = NULL; cPtr->refCount = 1; Itcl_PushStack(cPtr, stackPtr); Tcl_NRAddCallback(interp, InfoGutsFinish, framePtr, infoPtr, cPtr, NULL); Tcl_GetCommandInfoFromToken(infoPtr->infoCmd, &info); #if TCL_MAJOR_VERSION > 8 if (info.isNativeObjectProc == 2) { return Tcl_NRCallObjProc2(interp, info.objProc2, info.objClientData2, objc-1, objv+1); } #endif return Tcl_NRCallObjProc(interp, info.objProc, info.objClientData, objc-1, objv+1); } static int NRInfoWrap( void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_CmdInfo info; ItclObjectInfo *infoPtr = (ItclObjectInfo *)clientData; if (!infoPtr->infoCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "itcl info-subsystem is deleted", TCL_INDEX_NONE)); return TCL_ERROR; } if (objc == 1) { /* * No subcommand passed. Give good usage message. NOT the * default message of a Tcl ensemble. */ Tcl_Obj *objPtr = Tcl_NewStringObj( "wrong # args: should be one of...\n", TCL_INDEX_NONE); ItclGetInfoUsage(interp, objPtr, infoPtr, NULL); Tcl_SetObjResult(interp, objPtr); return TCL_ERROR; } /* Have a subcommand. Pass on to the ensemble */ Tcl_GetCommandInfoFromToken(infoPtr->infoCmd, &info); #if TCL_MAJOR_VERSION > 8 if (info.isNativeObjectProc == 2) { return Tcl_NRCallObjProc2(interp, info.objProc2, info.objClientData2, objc, objv); } #endif return Tcl_NRCallObjProc(interp, info.objProc, info.objClientData, objc, objv); } static int InfoWrap( void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { return Tcl_NRCallObjProc(interp, NRInfoWrap, clientData, objc, objv); } static void InfoCmdDelete( void *clientData) { ItclObjectInfo *infoPtr = (ItclObjectInfo *)clientData; infoPtr->infoCmd = NULL; } int ItclInfoInit( Tcl_Interp *interp, /* current interpreter */ ItclObjectInfo *infoPtr) { Tcl_Namespace *nsPtr; Tcl_Command token; Tcl_CmdInfo info; Tcl_Obj *unkObjPtr; Tcl_Obj *ensObjPtr; int result; int i; /* * Build the ensemble used to implement [info]. */ nsPtr = Tcl_CreateNamespace(interp, "::itcl::builtin::Info", NULL, NULL); if (nsPtr == NULL) { Tcl_Panic("ITCL: error in creating namespace: ::itcl::builtin::Info \n"); } if (infoPtr->infoCmd) { Tcl_Panic("Double init of info ensemble"); } token = Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX); infoPtr->infoCmd = token; token = Tcl_NRCreateCommand(interp, "::itcl::builtin::info", InfoWrap, NRInfoWrap, infoPtr, InfoCmdDelete); Tcl_GetCommandInfoFromToken(token, &info); /* * Make the C implementation of the "info" ensemble available as * a method body. This makes all [$object info] become the * equivalent of [::itcl::builtin::Info] without any need for * tailcall to restore the right frame [87a1bc6e82]. */ Itcl_RegisterObjC(interp, "itcl-builtin-info", info.objProc, info.objClientData, NULL); Tcl_Export(interp, nsPtr, "[a-z]*", 1); ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info", TCL_INDEX_NONE); for (i=0 ; InfoMethodList[i].name!=NULL ; i++) { Tcl_Obj *cmdObjPtr = Tcl_DuplicateObj(ensObjPtr); Tcl_AppendToObj(cmdObjPtr, "::", 2); Tcl_AppendToObj(cmdObjPtr, InfoMethodList[i].name, TCL_INDEX_NONE); Tcl_CreateObjCommand(interp, Tcl_GetString(cmdObjPtr), InfoMethodList[i].proc, infoPtr, InfoMethodList[i].proc == Itcl_BiInfoVarsCmd ? ItclRestoreInfoVars : NULL); Tcl_DecrRefCount(cmdObjPtr); } unkObjPtr = Tcl_NewStringObj("::itcl::builtin::Info::unknown", TCL_INDEX_NONE); Tcl_CreateObjCommand(interp, Tcl_GetString(unkObjPtr), Itcl_BiInfoUnknownCmd, infoPtr, NULL); if (Tcl_SetEnsembleUnknownHandler(NULL, Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG), unkObjPtr) != TCL_OK) { Tcl_DecrRefCount(unkObjPtr); Tcl_DecrRefCount(ensObjPtr); return TCL_ERROR; } Tcl_DecrRefCount(ensObjPtr); /* * Build the ensemble used to implement [info delegated]. */ nsPtr = Tcl_CreateNamespace(interp, "::itcl::builtin::Info::delegated", NULL, NULL); if (nsPtr == NULL) { Tcl_Panic("ITCL: error in creating namespace: ::itcl::builtin::Info::delegated \n"); } Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX); Tcl_Export(interp, nsPtr, "[a-z]*", 1); for (i=0 ; infoCmdsDelegated2[i].name!=NULL ; i++) { Tcl_CreateObjCommand(interp, infoCmdsDelegated2[i].name, infoCmdsDelegated2[i].proc, infoPtr, NULL); } ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info::delegated", TCL_INDEX_NONE); unkObjPtr = Tcl_NewStringObj( "::itcl::builtin::Info::delegated::unknown", TCL_INDEX_NONE); result = TCL_OK; if (Tcl_SetEnsembleUnknownHandler(NULL, Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG), unkObjPtr) != TCL_OK) { result = TCL_ERROR; } Tcl_DecrRefCount(ensObjPtr); return result; } /* * ------------------------------------------------------------------------ * ItclGetInfoUsage() * * ------------------------------------------------------------------------ */ void ItclGetInfoUsage( Tcl_Interp *interp, Tcl_Obj *objPtr, /* returns: summary of usage info */ TCL_UNUSED(ItclObjectInfo *), ItclClass *iclsPtr) { const char *spaces = " "; int i; ItclObject *ioPtr; if (iclsPtr == NULL) { if (TCL_ERROR == Itcl_GetContext(interp, &iclsPtr, &ioPtr)) { return; } } for (i=0; InfoMethodList[i].name != NULL; i++) { if (strcmp(InfoMethodList[i].name, "vars") == 0) { /* we don't report that, as it is a special case * it is only adding the protected and private commons * to the ::info vars command */ continue; } if (iclsPtr->flags & InfoMethodList[i].flags) { Tcl_AppendToObj(objPtr, spaces, TCL_INDEX_NONE); Tcl_AppendToObj(objPtr, "info ", TCL_INDEX_NONE); Tcl_AppendToObj(objPtr, InfoMethodList[i].name, TCL_INDEX_NONE); if (strlen(InfoMethodList[i].usage) > 0) { Tcl_AppendToObj(objPtr, " ", TCL_INDEX_NONE); Tcl_AppendToObj(objPtr, InfoMethodList[i].usage, TCL_INDEX_NONE); } spaces = "\n "; } } Tcl_AppendToObj(objPtr, "\n...and others described on the man page", TCL_INDEX_NONE); } /* * ------------------------------------------------------------------------ * ItclGetInfoDelegatedUsage() * * ------------------------------------------------------------------------ */ static void ItclGetInfoDelegatedUsage( Tcl_Interp *interp, Tcl_Obj *objPtr, /* returns: summary of usage info */ TCL_UNUSED(ItclObjectInfo *)) { ItclClass *iclsPtr; const char *name; const char *lastName; const char *spaces = " "; int i; ItclObject *ioPtr; if (TCL_ERROR == Itcl_GetContext(interp, &iclsPtr, &ioPtr)) { return; } for (i=0; infoCmdsDelegated2[i].name != NULL; i++) { name = infoCmdsDelegated2[i].name; lastName = name; while (name != NULL) { name = strstr(name, "::"); if (name == NULL) { break; } name += 2; lastName = name; } name = lastName; if (strcmp(name, "unknown") == 0) { /* we don't report that, as it is a special case */ continue; } if (iclsPtr->flags & infoCmdsDelegated2[i].flags) { Tcl_AppendToObj(objPtr, spaces, TCL_INDEX_NONE); Tcl_AppendToObj(objPtr, "info ", TCL_INDEX_NONE); Tcl_AppendToObj(objPtr, name, TCL_INDEX_NONE); if (strlen(infoCmdsDelegated2[i].usage) > 0) { Tcl_AppendToObj(objPtr, " ", TCL_INDEX_NONE); Tcl_AppendToObj(objPtr, infoCmdsDelegated2[i].usage, TCL_INDEX_NONE); } spaces = "\n "; } } Tcl_AppendToObj(objPtr, "\n...and others described on the man page", TCL_INDEX_NONE); } /* * ------------------------------------------------------------------------ * Itcl_BiInfoClassCmd() * * Returns information regarding the class for an object. This command * can be invoked with or without an object context: * * info class <= returns most-specific class name * info class <= returns active namespace name * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ int Itcl_BiInfoClassCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Namespace *contextNs = NULL; ItclClass *contextIclsPtr = NULL; ItclObject *contextIoPtr; char *name; ItclShowArgs(1, "Itcl_BiInfoClassCmd", objc, objv); if (objc != 1) { /* TODO: convert to NR-enabled fallback to [::info] */ Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } /* * If this command is not invoked within a class namespace, * signal an error. */ if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { /* try it the hard way */ void *clientData; ItclObjectInfo *infoPtr; Tcl_Object oPtr; clientData = Itcl_GetCallFrameClientData(interp); infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); if (clientData != NULL) { oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)clientData); contextIoPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, infoPtr->object_meta_type); contextIclsPtr = contextIoPtr->iclsPtr; } if ((contextIoPtr == NULL) || (contextIclsPtr == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " \ "\n namespace eval className { info class }", TCL_INDEX_NONE)); return TCL_ERROR; } } /* * If there is an object context, then return the most-specific * class for the object. Otherwise, return the class namespace * name. Use normal class names when possible. */ if (contextIoPtr) { contextNs = contextIoPtr->iclsPtr->nsPtr; } else { assert(contextIclsPtr != NULL); assert(contextIclsPtr->nsPtr != NULL); contextNs = contextIclsPtr->nsPtr; } assert(contextNs); name = contextNs->fullName; Tcl_SetObjResult(interp, Tcl_NewStringObj(name, TCL_INDEX_NONE)); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoClassOptionsCmd() * * Returns information regarding the options for a class. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoClassOptionsCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_HashEntry *hPtr2; Tcl_Obj *listPtr; Tcl_Obj *listPtr2; Tcl_Obj *objPtr; Tcl_Obj **lObjv; Tcl_HashTable *tablePtr; ItclObject *ioPtr; ItclClass *iclsPtr; ItclOption *ioptPtr; ItclDelegatedOption *idoPtr; const char *name; const char *val; const char *pattern; Tcl_Size lObjc; int result; Tcl_Size i; ItclShowArgs(1, "Itcl_BiInfoClassOptionsCmd", objc, objv); iclsPtr = NULL; pattern = NULL; if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { Tcl_AppendResult(interp, "cannot get context ", NULL); return TCL_ERROR; } if (objc > 2) { Tcl_AppendResult(interp, "wrong # args should be: info options ", "?pattern?", NULL); return TCL_ERROR; } if (objc == 2) { pattern = Tcl_GetString(objv[1]); } listPtr = Tcl_NewListObj(0, NULL); tablePtr = &iclsPtr->options; FOREACH_HASH_VALUE(ioptPtr, tablePtr) { name = Tcl_GetString(ioptPtr->namePtr); if ((pattern == NULL) || Tcl_StringCaseMatch(name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(ioptPtr->namePtr), TCL_INDEX_NONE)); } } tablePtr = &iclsPtr->delegatedOptions; FOREACH_HASH_VALUE(idoPtr, tablePtr) { name = Tcl_GetString(idoPtr->namePtr); if (strcmp(name, "*") != 0) { if ((pattern == NULL) || Tcl_StringCaseMatch(name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(idoPtr->namePtr), TCL_INDEX_NONE)); } } else { if (idoPtr->icPtr == NULL) { Tcl_AppendResult(interp, "component \"", Tcl_GetString(idoPtr->namePtr), "\" is not initialized", NULL); return TCL_ERROR; } val = ItclGetInstanceVar(interp, Tcl_GetString(idoPtr->icPtr->namePtr), NULL, ioPtr, ioPtr->iclsPtr); if ((val != NULL) && (strlen(val) != 0)) { objPtr = Tcl_NewStringObj(val, TCL_INDEX_NONE); Tcl_AppendToObj(objPtr, " configure", TCL_INDEX_NONE); Tcl_IncrRefCount(objPtr); result = Tcl_EvalObjEx(interp, objPtr, 0); Tcl_DecrRefCount(objPtr); if (result != TCL_OK) { return TCL_ERROR; } listPtr2 = Tcl_GetObjResult(interp); Tcl_ListObjGetElements(interp, listPtr2, &lObjc, &lObjv); for (i = 0; i < lObjc; i++) { Tcl_ListObjIndex(interp, lObjv[i], 0, &objPtr); hPtr2 = Tcl_FindHashEntry(&idoPtr->exceptions, (char *)objPtr); if (hPtr2 == NULL) { name = Tcl_GetString(objPtr); if ((pattern == NULL) || Tcl_StringCaseMatch(name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, objPtr); } } } } } } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoContextCmd() * * Returns information regarding the context object and class. This command * can only be invoked with an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoContextCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *listPtr; Tcl_Obj *objPtr; ItclObject *ioPtr = NULL; ItclClass *iclsPtr; ItclShowArgs(1, "Itcl_BiInfoContextCmd", objc, objv); iclsPtr = NULL; if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { return TCL_ERROR; } if (ioPtr == NULL) { Tcl_AppendResult(interp, "cannot get object context ", NULL); return TCL_ERROR; } listPtr = Tcl_NewListObj(0, NULL); objPtr = Tcl_NewStringObj(Tcl_GetString(iclsPtr->namePtr), TCL_INDEX_NONE); Tcl_ListObjAppendElement(interp, listPtr, objPtr); objPtr = Tcl_NewStringObj(Tcl_GetString(ioPtr->namePtr), TCL_INDEX_NONE); Tcl_ListObjAppendElement(interp, listPtr, objPtr); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoInheritCmd() * * Returns the list of base classes for the current class context. * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ int Itcl_BiInfoInheritCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclClass *contextIclsPtr = NULL; ItclObject *contextIoPtr = NULL; Itcl_ListElem *elem; Tcl_Obj *listPtr; ItclShowArgs(2, "Itcl_BiInfoInheritCmd", objc, objv); if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } /* * If this command is not invoked within a class namespace, * signal an error. */ if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info inherit }", TCL_INDEX_NONE)); return TCL_ERROR; } /* * Return the list of base classes. */ listPtr = Tcl_NewListObj(0, NULL); elem = Itcl_FirstListElem(&contextIclsPtr->bases); while (elem) { Tcl_Obj *objPtr; ItclClass *iclsPtr = (ItclClass*)Itcl_GetListValue(elem); objPtr = Tcl_NewStringObj(iclsPtr->nsPtr->fullName, TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); elem = Itcl_NextListElem(elem); } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoHeritageCmd() * * Returns the entire derivation hierarchy for this class, presented * in the order that classes are traversed for finding data members * and member functions. * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ int Itcl_BiInfoHeritageCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclClass *contextIclsPtr = NULL; ItclObject *contextIoPtr = NULL; ItclHierIter hier; Tcl_Obj *listPtr; Tcl_Obj *objPtr; ItclClass *iclsPtr; ItclShowArgs(2, "Itcl_BiInfoHeritageCmd", objc, objv); if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } /* * If this command is not invoked within a class namespace, * signal an error. */ contextIclsPtr = NULL; if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info heritage }", TCL_INDEX_NONE)); return TCL_ERROR; } /* * Traverse through the derivation hierarchy and return * base class names. */ listPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { if (iclsPtr->nsPtr == NULL) { Tcl_AppendResult(interp, "ITCL: iclsPtr->nsPtr == NULL", Tcl_GetString(iclsPtr->fullNamePtr), NULL); return TCL_ERROR; } objPtr = Tcl_NewStringObj(iclsPtr->nsPtr->fullName, TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } Itcl_DeleteHierIter(&hier); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoFunctionCmd() * * Returns information regarding class member functions (methods/procs). * Handles the following syntax: * * info function ?cmdName? ?-protection? ?-type? ?-name? ?-args? ?-body? * * If the ?cmdName? is not specified, then a list of all known * command members is returned. Otherwise, the information for * a specific command is returned. Returns a status TCL_OK/TCL_ERROR * to indicate success/failure. * ------------------------------------------------------------------------ */ int Itcl_BiInfoFunctionCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { char *cmdName = NULL; Tcl_Obj *resultPtr = NULL; Tcl_Obj *objPtr = NULL; static const char *options[] = { "-args", "-body", "-name", "-protection", "-type", NULL }; enum BIfIdx { BIfArgsIdx, BIfBodyIdx, BIfNameIdx, BIfProtectIdx, BIfTypeIdx } *iflist, iflistStorage[5]; static enum BIfIdx DefInfoFunction[5] = { BIfProtectIdx, BIfTypeIdx, BIfNameIdx, BIfArgsIdx, BIfBodyIdx }; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; ItclClass *iclsPtr; int i; int result; const char *val; Tcl_HashSearch place; Tcl_HashEntry *entry; ItclMemberFunc *imPtr; ItclMemberCode *mcode; ItclHierIter hier; ItclShowArgs(2, "Itcl_InfoFunctionCmd", objc, objv); /* * If this command is not invoked within a class namespace, * signal an error. */ contextIclsPtr = NULL; if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info function ... }", TCL_INDEX_NONE)); return TCL_ERROR; } if (contextIoPtr != NULL) { contextIclsPtr = contextIoPtr->iclsPtr; } /* * Process args: * ?cmdName? ?-protection? ?-type? ?-name? ?-args? ?-body? */ objv++; /* skip over command name */ objc--; if (objc > 0) { cmdName = Tcl_GetString(*objv); objc--; objv++; } /* * Return info for a specific command. */ if (cmdName) { ItclCmdLookup *clookup; objPtr = Tcl_NewStringObj(cmdName, TCL_INDEX_NONE); entry = Tcl_FindHashEntry(&contextIclsPtr->resolveCmds, (char *)objPtr); Tcl_DecrRefCount(objPtr); objPtr = NULL; if (entry == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a member function in class \"", contextIclsPtr->nsPtr->fullName, "\"", NULL); return TCL_ERROR; } clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry); imPtr = clookup->imPtr; mcode = imPtr->codePtr; /* * By default, return everything. */ if (objc == 0) { objc = 5; iflist = DefInfoFunction; } else { /* * Otherwise, scan through all remaining flags and * figure out what to return. */ iflist = &iflistStorage[0]; for (i=0 ; i < objc; i++) { result = Tcl_GetIndexFromObjStruct(interp, objv[i], options, sizeof(char *), "option", 0, (int*)(&iflist[i])); if (result != TCL_OK) { return TCL_ERROR; } } } if (objc > 1) { resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { switch (iflist[i]) { case BIfArgsIdx: if (mcode && mcode->argListPtr) { if (imPtr->usagePtr == NULL) { objPtr = Tcl_NewStringObj( Tcl_GetString(mcode->usagePtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj( Tcl_GetString(imPtr->usagePtr), TCL_INDEX_NONE); } } else { if ((imPtr->flags & ITCL_ARG_SPEC) != 0) { if (imPtr->usagePtr == NULL) { objPtr = Tcl_NewStringObj( Tcl_GetString(mcode->usagePtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj( Tcl_GetString(imPtr->usagePtr), TCL_INDEX_NONE); } } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } } break; case BIfBodyIdx: if (mcode && Itcl_IsMemberCodeImplemented(mcode)) { objPtr = Tcl_NewStringObj( Tcl_GetString(mcode->bodyPtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BIfNameIdx: objPtr = Tcl_NewStringObj( Tcl_GetString(imPtr->fullNamePtr), TCL_INDEX_NONE); break; case BIfProtectIdx: val = Itcl_ProtectionStr(imPtr->protection); objPtr = Tcl_NewStringObj(val, TCL_INDEX_NONE); break; case BIfTypeIdx: val = ((imPtr->flags & ITCL_COMMON) != 0) ? "proc" : "method"; objPtr = Tcl_NewStringObj(val, TCL_INDEX_NONE); break; } if (objc == 1) { resultPtr = objPtr; } else { Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } Tcl_SetObjResult(interp, resultPtr); } else { /* * Return the list of available commands. */ resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { entry = Tcl_FirstHashEntry(&iclsPtr->functions, &place); while (entry) { int useIt = 1; imPtr = (ItclMemberFunc*)Tcl_GetHashValue(entry); if (imPtr->codePtr && (imPtr->codePtr->flags & ITCL_BUILTIN)) { if (strcmp(Tcl_GetString(imPtr->namePtr), "info") == 0) { useIt = 0; } if (strcmp(Tcl_GetString(imPtr->namePtr), "setget") == 0) { if (!(imPtr->iclsPtr->flags & ITCL_ECLASS)) { useIt = 0; } } if (strcmp(Tcl_GetString(imPtr->namePtr), "installcomponent") == 0) { if (!(imPtr->iclsPtr->flags & (ITCL_WIDGET|ITCL_WIDGETADAPTOR))) { useIt = 0; } } } if (useIt) { objPtr = Tcl_NewStringObj( Tcl_GetString(imPtr->fullNamePtr), TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } entry = Tcl_NextHashEntry(&place); } } Itcl_DeleteHierIter(&hier); Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoVariableCmd() * * Returns information regarding class data members (variables and * commons). Handles the following syntax: * * info variable ?varName? ?-protection? ?-type? ?-name? * ?-init? ?-config? ?-value? * * If the ?varName? is not specified, then a list of all known * data members is returned. Otherwise, the information for a * specific member is returned. Returns a status TCL_OK/TCL_ERROR * to indicate success/failure. * ------------------------------------------------------------------------ */ /*&&&1*/ int Itcl_BiInfoVariableCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *resultPtr; Tcl_Obj *objPtr; Tcl_HashSearch place; Tcl_HashEntry *entry; ItclClass *iclsPtr; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; ItclVariable *ivPtr; ItclVarLookup *vlookup; ItclHierIter hier; char *varName; const char *val; int i; int result; void *cfClientData; ItclObjectInfo *infoPtr; Tcl_Object oPtr; int doAppend; static const char *options[] = { "-config", "-init", "-name", "-protection", "-type", "-value", "-scope", NULL }; enum BIvIdx { BIvConfigIdx, BIvInitIdx, BIvNameIdx, BIvProtectIdx, BIvTypeIdx, BIvValueIdx, BIvScopeIdx } *ivlist, ivlistStorage[7]; static enum BIvIdx DefInfoVariable[5] = { BIvProtectIdx, BIvTypeIdx, BIvNameIdx, BIvInitIdx, BIvValueIdx }; static enum BIvIdx DefInfoPubVariable[6] = { BIvProtectIdx, BIvTypeIdx, BIvNameIdx, BIvInitIdx, BIvConfigIdx, BIvValueIdx }; ItclShowArgs(1, "Itcl_BiInfoVariableCmd", objc, objv); resultPtr = NULL; objPtr = NULL; varName = NULL; contextIclsPtr = NULL; /* * If this command is not invoked within a class namespace, * signal an error. */ if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info variable ... }", TCL_INDEX_NONE)); return TCL_ERROR; } if (contextIoPtr != NULL) { contextIclsPtr = contextIoPtr->iclsPtr; } /* * Process args: * ?varName? ?-protection? ?-type? ?-name? ?-init? ?-config? ?-value? ?-scope? */ objv++; /* skip over command name */ objc--; if (objc > 0) { varName = Tcl_GetString(*objv); objc--; objv++; } /* * Return info for a specific variable. */ if (varName) { entry = ItclResolveVarEntry(contextIclsPtr, varName); if (entry == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", varName, "\" isn't a variable in class \"", contextIclsPtr->nsPtr->fullName, "\"", NULL); return TCL_ERROR; } vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); ivPtr = vlookup->ivPtr; /* * By default, return everything. */ if (objc == 0) { if (ivPtr->protection == ITCL_PUBLIC && ((ivPtr->flags & ITCL_COMMON) == 0)) { ivlist = DefInfoPubVariable; objc = 6; } else { ivlist = DefInfoVariable; objc = 5; } } else { /* * Otherwise, scan through all remaining flags and * figure out what to return. */ ivlist = &ivlistStorage[0]; for (i=0 ; i < objc; i++) { result = Tcl_GetIndexFromObjStruct(interp, objv[i], options, sizeof(char *), "option", 0, (int*)(&ivlist[i])); if (result != TCL_OK) { return TCL_ERROR; } } } if (objc > 1) { resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { switch (ivlist[i]) { case BIvConfigIdx: if (ivPtr->codePtr && Itcl_IsMemberCodeImplemented(ivPtr->codePtr)) { objPtr = Tcl_NewStringObj( Tcl_GetString(ivPtr->codePtr->bodyPtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BIvInitIdx: /* * If this is the built-in "this" variable, then * report the object name as its initialization string. */ if ((ivPtr->flags & ITCL_THIS_VAR) != 0) { if ((contextIoPtr != NULL) && (contextIoPtr->accessCmd != NULL)) { objPtr = Tcl_NewStringObj(NULL, 0); Tcl_GetCommandFullName( contextIoPtr->iclsPtr->interp, contextIoPtr->accessCmd, objPtr); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } } else { if (vlookup->ivPtr->init) { objPtr = Tcl_NewStringObj( Tcl_GetString(vlookup->ivPtr->init), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } } break; case BIvNameIdx: objPtr = Tcl_NewStringObj( Tcl_GetString(ivPtr->fullNamePtr), TCL_INDEX_NONE); break; case BIvProtectIdx: val = Itcl_ProtectionStr(ivPtr->protection); objPtr = Tcl_NewStringObj((const char *)val, TCL_INDEX_NONE); break; case BIvTypeIdx: val = ((ivPtr->flags & ITCL_COMMON) != 0) ? "common" : "variable"; objPtr = Tcl_NewStringObj((const char *)val, TCL_INDEX_NONE); break; case BIvValueIdx: if ((ivPtr->flags & ITCL_COMMON) != 0) { val = Itcl_GetCommonVar(interp, Tcl_GetString(ivPtr->fullNamePtr), ivPtr->iclsPtr); } else { if (contextIoPtr == NULL) { if (objc > 1) { Tcl_DecrRefCount(resultPtr); } Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot access object-specific info ", "without an object context", NULL); return TCL_ERROR; } else { val = Itcl_GetInstanceVar(interp, Tcl_GetString(ivPtr->namePtr), contextIoPtr, ivPtr->iclsPtr); } } if (val == NULL) { val = ""; } objPtr = Tcl_NewStringObj((const char *)val, TCL_INDEX_NONE); break; case BIvScopeIdx: entry = Tcl_FindHashEntry(&contextIclsPtr->resolveVars, varName); if (!entry) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "variable \"", varName, "\" not found in class \"", Tcl_GetString(contextIclsPtr->fullNamePtr), "\"", (char*)NULL); return TCL_ERROR; } vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); if (vlookup->ivPtr->flags & ITCL_COMMON) { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); if (vlookup->ivPtr->protection != ITCL_PUBLIC) { Tcl_AppendToObj(objPtr, ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE); } Tcl_AppendToObj(objPtr, Tcl_GetString(vlookup->ivPtr->fullNamePtr), TCL_INDEX_NONE); } else { /* * 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; cfClientData = Itcl_GetCallFrameClientData(interp); if (cfClientData != NULL) { oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)cfClientData); 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 \"", varName, "\": missing object context", (char*)NULL); return TCL_ERROR; } doAppend = 1; if (contextIclsPtr->flags & ITCL_ECLASS) { if (strcmp(varName, "itcl_options") == 0) { doAppend = 0; } } objPtr = Tcl_NewStringObj((char*)NULL, 0); Tcl_IncrRefCount(objPtr); Tcl_AppendToObj(objPtr, ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE); Tcl_AppendToObj(objPtr, (Tcl_GetObjectNamespace(contextIoPtr->oPtr))->fullName, TCL_INDEX_NONE); if (doAppend) { Tcl_AppendToObj(objPtr, Tcl_GetString(vlookup->ivPtr->fullNamePtr), TCL_INDEX_NONE); } else { Tcl_AppendToObj(objPtr, "::", TCL_INDEX_NONE); Tcl_AppendToObj(objPtr, Tcl_GetString(vlookup->ivPtr->namePtr), TCL_INDEX_NONE); } } break; } if (objc == 1) { resultPtr = objPtr; } else { Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_GetString(resultPtr), NULL); Tcl_DecrRefCount(resultPtr); } else { /* * Return the list of available variables. Report the built-in * "this" variable only once, for the most-specific class. */ resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { entry = Tcl_FirstHashEntry(&iclsPtr->variables, &place); while (entry) { ivPtr = (ItclVariable*)Tcl_GetHashValue(entry); if ((ivPtr->flags & ITCL_THIS_VAR) != 0) { if (iclsPtr == contextIclsPtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(ivPtr->fullNamePtr), TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } else { objPtr = Tcl_NewStringObj( Tcl_GetString(ivPtr->fullNamePtr), TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } entry = Tcl_NextHashEntry(&place); } } Itcl_DeleteHierIter(&hier); Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoVarsCmd() * * Returns information regarding variables * * info vars ?pattern? * uses ::info vars and adds Itcl common variables!! * * Returns a status TCL_OK/TCL_ERROR * to indicate success/failure. * ------------------------------------------------------------------------ */ int Itcl_BiInfoVarsCmd( void *clientData, /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_Obj *listPtr; Tcl_Obj **newObjv; Tcl_Namespace *nsPtr; ItclObjectInfo *infoPtr; ItclClass *iclsPtr = NULL; ItclVariable *ivPtr; const char *pattern; const char *name; int useGlobalInfo; int result; ItclObject *ioPtr; ItclShowArgs(1, "Itcl_BiInfoVars", objc, objv); result = TCL_OK; useGlobalInfo = 1; pattern = NULL; infoPtr = (ItclObjectInfo *)clientData; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, " ?pattern?"); return TCL_ERROR; } if (TCL_OK != Itcl_GetContext(interp, &iclsPtr, &ioPtr)) { /* Clear the error message */ Tcl_ResetResult(interp); } if (iclsPtr) { if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET)) { /* don't use the ::tcl::info::vars command */ useGlobalInfo = 0; if (objc == 2) { pattern = Tcl_GetString(objv[1]); } } } if (useGlobalInfo) { newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc)); newObjv[0] = Tcl_NewStringObj("::tcl::info::vars", TCL_INDEX_NONE); Tcl_IncrRefCount(newObjv[0]); memcpy(newObjv+1, objv+1, sizeof(Tcl_Obj *)*(objc-1)); result = Tcl_EvalObjv(interp, objc, newObjv, 0); Tcl_DecrRefCount(newObjv[0]); ckfree((char *)newObjv); } else { listPtr = Tcl_NewListObj(0, NULL); FOREACH_HASH_VALUE(ivPtr, &iclsPtr->variables) { if ((ivPtr->flags & ITCL_VARIABLE) != 0) { name = Tcl_GetString(ivPtr->namePtr); if ((pattern == NULL) || Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, ivPtr->namePtr); } } } /* always add the itcl_options variable */ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("itcl_options", TCL_INDEX_NONE)); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } if (objc < 2) { return result; } if (result == TCL_OK) { Tcl_DString buffer; const char *head; const char *tail; /* check if the pattern contains a class namespace * and if yes add the common private and protected vars * and remove the ___DO_NOT_DELETE_THIS_VARIABLE var */ Itcl_ParseNamespPath(Tcl_GetString(objv[1]), &buffer, &head, &tail); if (head == NULL) { nsPtr = Tcl_GetCurrentNamespace(interp); } else { nsPtr = Tcl_FindNamespace(interp, head, NULL, 0); } hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); if (hPtr != NULL) { Itcl_List varList; Tcl_Obj *resultListPtr; Tcl_Obj *namePtr; Itcl_InitList(&varList); iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); resultListPtr = Tcl_GetObjResult(interp); /* FIXME !! should perhaps skip ___DO_NOT_DELETE_THIS_VARIABLE here !! */ FOREACH_HASH_VALUE(ivPtr, &iclsPtr->variables) { if ((ivPtr->flags & ITCL_VARIABLE) != 0) { if (head != NULL) { namePtr = Tcl_NewStringObj( Tcl_GetString(ivPtr->fullNamePtr), TCL_INDEX_NONE); } else { namePtr = Tcl_NewStringObj( Tcl_GetString(ivPtr->namePtr), TCL_INDEX_NONE); } Tcl_ListObjAppendElement(interp, resultListPtr, namePtr); } if ((ivPtr->flags & ITCL_COMMON) != 0) { if (ivPtr->protection != ITCL_PUBLIC) { if (head != NULL) { namePtr = Tcl_NewStringObj( Tcl_GetString(ivPtr->fullNamePtr), TCL_INDEX_NONE); } else { namePtr = Tcl_NewStringObj( Tcl_GetString(ivPtr->namePtr), TCL_INDEX_NONE); } Tcl_ListObjAppendElement(interp, resultListPtr, namePtr); } } } } } return result; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoUnknownCmd() * * the unknown handler for the ::itcl::builtin::Info ensemble * ------------------------------------------------------------------------ */ int Itcl_BiInfoUnknownCmd( void *clientData, /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *objPtr, *listObj; int usage = 1; int code = TCL_ERROR; ItclShowArgs(1, "Itcl_BiInfoUnknownCmd", objc, objv); if (objc < 2) { /* Namespace ensemble unknown callbacks never do this. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "unknown callback should not be called directly", TCL_INDEX_NONE)); return TCL_ERROR; } /* Redirect to the [::info] command. */ objPtr = Tcl_NewStringObj("::info", TCL_INDEX_NONE); listObj = Tcl_NewListObj(1, &objPtr); Tcl_IncrRefCount(listObj); if (Tcl_GetCommandFromObj(interp, objPtr)) { usage = 0; Tcl_ListObjReplace(NULL, listObj, 1, 0, objc-2, objv+2); code = Tcl_EvalObjEx(interp, listObj, 0); if (code == TCL_ERROR) { /* Redirection to [::info] failed, but why? */ Tcl_Obj *optDict = Tcl_GetReturnOptions(interp, code); Tcl_Obj *key = Tcl_NewStringObj("-errorcode", TCL_INDEX_NONE); Tcl_Obj *val, *elem; Tcl_DictObjGet(NULL, optDict, key, &val); Tcl_DecrRefCount(key); Tcl_ListObjIndex(NULL, val, 0, &elem); if (elem && !strcmp(Tcl_GetString(elem), "TCL")) { Tcl_ListObjIndex(NULL, val, 1, &elem); if (elem && !strcmp(Tcl_GetString(elem), "LOOKUP")) { Tcl_ListObjIndex(NULL, val, 2, &elem); if (elem && !strcmp(Tcl_GetString(elem), "SUBCOMMAND")) { /* [::info didn't have that subcommand] */ usage = 1; Tcl_ResetResult(interp); } } } } } Tcl_DecrRefCount(listObj); if (usage) { /* produce usage message */ objPtr = Tcl_NewStringObj( "wrong # args: should be one of...\n", TCL_INDEX_NONE); ItclGetInfoUsage(interp, objPtr, (ItclObjectInfo *)clientData, NULL); Tcl_SetObjResult(interp, objPtr); } if (code == TCL_ERROR) { return TCL_ERROR; } /* Return a command to replicate the non-error redirect outcome */ listObj = Tcl_NewStringObj( "::apply {{o m args} {::tailcall ::return -options $o $m}}", TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, listObj, Tcl_GetReturnOptions(interp,code)); Tcl_ListObjAppendElement(NULL, listObj, Tcl_GetObjResult(interp)); Tcl_SetObjResult(interp, listObj); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoBodyCmd() * * Handles the usual "info body" request, returning the body for a * specific proc. Included here for backward compatibility, since * otherwise Tcl would complain that class procs are not real "procs". * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ int Itcl_BiInfoBodyCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_HashEntry *hPtr; ItclClass *contextIclsPtr = NULL; ItclObject *contextIoPtr; const char *what = "procedure"; if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { int code; Tcl_Obj *script; /* * We lack the context for any specialized Itcl meaning for * [info body], so fallback to Tcl's. */ fallback: script = Tcl_NewStringObj("::info body", TCL_INDEX_NONE); if (objc == 2) { Tcl_ListObjAppendElement(NULL, script, objv[1]); } Tcl_IncrRefCount(script); code = Tcl_EvalObjEx(interp, script, 0); Tcl_DecrRefCount(script); if (code == TCL_ERROR && what) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" isn't a %s", Tcl_GetString(objv[1]), what)); } return code; } if (contextIoPtr != NULL) { contextIclsPtr = contextIoPtr->iclsPtr; } what = "function"; if (contextIclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS)) { what = "method"; } if (objc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"info body ", what, "\"", NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveCmds, (char *)objv[1]); if (hPtr) { ItclCmdLookup *clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); ItclMemberFunc *imPtr = clookup->imPtr; ItclMemberCode *mcode = imPtr->codePtr; /* * Return a string describing the implementation. */ if (mcode && Itcl_IsMemberCodeImplemented(mcode)) { Tcl_SetObjResult(interp, mcode->bodyPtr); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj("", TCL_INDEX_NONE)); } return TCL_OK; } if (contextIclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS)) { hPtr = Tcl_FindHashEntry(&contextIclsPtr->delegatedFunctions, (char *)objv[1]); } if (hPtr) { ItclDelegatedFunction *idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); Tcl_Obj *objPtr = Tcl_NewStringObj("delegated ", TCL_INDEX_NONE); if (idmPtr->flags & ITCL_TYPE_METHOD) { what = "typemethod"; } Tcl_AppendToObj(objPtr, what, TCL_INDEX_NONE); Tcl_AppendToObj(objPtr, " \"", TCL_INDEX_NONE); Tcl_AppendObjToObj(objPtr, objv[1]); Tcl_AppendToObj(objPtr, "\"", TCL_INDEX_NONE); Tcl_SetObjResult(interp, objPtr); return TCL_ERROR; } goto fallback; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoArgsCmd() * * Handles the usual "info args" request, returning the argument list * for a specific proc. Included here for backward compatibility, since * otherwise Tcl would complain that class procs are not real "procs". * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ int Itcl_BiInfoArgsCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_HashEntry *hPtr = NULL; ItclClass *contextIclsPtr = NULL; ItclObject *contextIoPtr; const char *what = NULL; if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK && objc > 1) { int code; Tcl_Obj *script; /* * We lack the context for any specialized Itcl meaning for * [info args], so fallback to Tcl's. */ fallback: script = Tcl_NewStringObj("::info args", TCL_INDEX_NONE); if (objc == 2) { Tcl_ListObjAppendElement(NULL, script, objv[1]); } Tcl_IncrRefCount(script); code = Tcl_EvalObjEx(interp, script, 0); Tcl_DecrRefCount(script); if (code == TCL_ERROR && what) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" isn't a %s", Tcl_GetString(objv[1]), what)); } return code; } if (contextIoPtr != NULL) { contextIclsPtr = contextIoPtr->iclsPtr; } what = "function"; if ((contextIclsPtr != NULL) && (contextIclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET))) { what = "method"; } if (objc != 2) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "wrong # args: should be \"info args %s\"", what)); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveCmds, (char *)objv[1]); if (hPtr) { ItclCmdLookup *clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); ItclMemberFunc *imPtr = clookup->imPtr; ItclMemberCode *mcode = imPtr->codePtr; /* * Return a string describing the argument list. */ if ((mcode && mcode->argListPtr != NULL) || ((imPtr->flags & ITCL_ARG_SPEC) != 0)) { Tcl_SetObjResult(interp, mcode->usagePtr); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj("", TCL_INDEX_NONE)); } return TCL_OK; } if (contextIclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS)) { hPtr = Tcl_FindHashEntry(&contextIclsPtr->delegatedFunctions, (char *)objv[1]); } if (hPtr) { ItclDelegatedFunction *idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); Tcl_Obj *objPtr = Tcl_NewStringObj("delegated ", TCL_INDEX_NONE); if (idmPtr->flags & ITCL_TYPE_METHOD) { what = "typemethod"; } Tcl_AppendToObj(objPtr, what, TCL_INDEX_NONE); Tcl_AppendToObj(objPtr, " \"", TCL_INDEX_NONE); Tcl_AppendObjToObj(objPtr, objv[1]); Tcl_AppendToObj(objPtr, "\"", TCL_INDEX_NONE); Tcl_SetObjResult(interp, objPtr); return TCL_ERROR; } goto fallback; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoOptionCmd() * * Returns information regarding class options. * Handles the following syntax: * * info option ?optionName? ?-protection? ?-name? ?-resource? ?-class? * ?-default? ?-configmethod? ?-cgetmethod? ?-validatemethod? ?-value? * * If the ?optionName? is not specified, then a list of all known * data members is returned. Otherwise, the information for a * specific member is returned. Returns a status TCL_OK/TCL_ERROR * to indicate success/failure. * ------------------------------------------------------------------------ */ int Itcl_BiInfoOptionCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { char *optionName = NULL; Tcl_Obj *resultPtr = NULL; Tcl_Obj *objPtr = NULL; Tcl_Obj *optionNamePtr; static const char *options[] = { "-cgetmethod", "-cgetmethodvar","-class", "-configuremethod", "-configuremethodvar", "-default", "-name", "-protection", "-resource", "-validatemethod", "-validatemethodvar", "-value", NULL }; enum BOptIdx { BOptCgetMethodIdx, BOptCgetMethodVarIdx, BOptClassIdx, BOptConfigureMethodIdx, BOptConfigureMethodVarIdx, BOptDefaultIdx, BOptNameIdx, BOptProtectIdx, BOptResourceIdx, BOptValidateMethodIdx, BOptValidateMethodVarIdx, BOptValueIdx } *ioptlist, ioptlistStorage[12]; static enum BOptIdx DefInfoOption[12] = { BOptProtectIdx, BOptNameIdx, BOptResourceIdx, BOptClassIdx, BOptDefaultIdx, BOptCgetMethodIdx, BOptCgetMethodVarIdx, BOptConfigureMethodIdx, BOptConfigureMethodVarIdx, BOptValidateMethodIdx, BOptValidateMethodVarIdx, BOptValueIdx }; Tcl_HashSearch place; Tcl_HashEntry *hPtr; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; ItclOption *ioptPtr; ItclHierIter hier; ItclClass *iclsPtr; const char *val; int i; int result; ItclShowArgs(1, "Itcl_BiInfoOptionCmd", objc, objv); /* * If this command is not invoked within a class namespace, * signal an error. */ contextIclsPtr = NULL; if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info option ... }", TCL_INDEX_NONE)); return TCL_ERROR; } if (contextIoPtr != NULL) { contextIclsPtr = contextIoPtr->iclsPtr; } /* * Process args: * ?optionName? ?-protection? ?-name? ?-resource? ?-class? * ?-default? ?-cgetmethod? ?-cgetmethodvar? ?-configuremethod? * ?-configuremethodvar? ?-validatemethod? ?-validatemethodvar? ?-value? */ objv++; /* skip over command name */ objc--; if (objc > 0) { optionName = Tcl_GetString(*objv); objc--; objv++; } /* * Return info for a specific option. */ if (optionName) { if (contextIoPtr == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot access object-specific info ", "without an object context", NULL); return TCL_ERROR; } optionNamePtr = Tcl_NewStringObj(optionName, TCL_INDEX_NONE); hPtr = Tcl_FindHashEntry(&contextIoPtr->objectOptions, (char *)optionNamePtr); Tcl_DecrRefCount(optionNamePtr); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", optionName, "\" isn't a option in object \"", Tcl_GetString(contextIoPtr->namePtr), "\"", NULL); return TCL_ERROR; } ioptPtr = (ItclOption*)Tcl_GetHashValue(hPtr); /* * By default, return everything. */ if (objc == 0) { ioptlist = DefInfoOption; objc = 9; } else { /* * Otherwise, scan through all remaining flags and * figure out what to return. */ ioptlist = &ioptlistStorage[0]; for (i=0 ; i < objc; i++) { result = Tcl_GetIndexFromObjStruct(interp, objv[i], options, sizeof(char *), "option", 0, (int*)(&ioptlist[i])); if (result != TCL_OK) { return TCL_ERROR; } } } if (objc > 1) { resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { switch (ioptlist[i]) { case BOptCgetMethodIdx: if (ioptPtr->cgetMethodPtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(ioptPtr->cgetMethodPtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptCgetMethodVarIdx: if (ioptPtr->cgetMethodVarPtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(ioptPtr->cgetMethodVarPtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptConfigureMethodIdx: if (ioptPtr->configureMethodPtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(ioptPtr->configureMethodPtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptConfigureMethodVarIdx: if (ioptPtr->configureMethodVarPtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(ioptPtr->configureMethodVarPtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptValidateMethodIdx: if (ioptPtr->validateMethodPtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(ioptPtr->validateMethodPtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptValidateMethodVarIdx: if (ioptPtr->validateMethodVarPtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(ioptPtr->validateMethodVarPtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptResourceIdx: if (ioptPtr->resourceNamePtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(ioptPtr->resourceNamePtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptClassIdx: if (ioptPtr->classNamePtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(ioptPtr->classNamePtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptDefaultIdx: if (ioptPtr->defaultValuePtr != NULL) { objPtr = Tcl_NewStringObj( Tcl_GetString(ioptPtr->defaultValuePtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptNameIdx: objPtr = Tcl_NewStringObj( Tcl_GetString(ioptPtr->fullNamePtr), TCL_INDEX_NONE); break; case BOptProtectIdx: val = Itcl_ProtectionStr(ioptPtr->protection); objPtr = Tcl_NewStringObj((const char *)val, TCL_INDEX_NONE); break; case BOptValueIdx: if (contextIoPtr == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot access object-specific info ", "without an object context", NULL); return TCL_ERROR; } else { val = ItclGetInstanceVar(interp, "itcl_options", Tcl_GetString(ioptPtr->namePtr), contextIoPtr, ioptPtr->iclsPtr); } if (val == NULL) { val = ""; } objPtr = Tcl_NewStringObj((const char *)val, TCL_INDEX_NONE); break; } if (objc == 1) { resultPtr = objPtr; } else { Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } Tcl_SetObjResult(interp, resultPtr); } else { /* * Return the list of available options. */ resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FirstHashEntry(&iclsPtr->options, &place); while (hPtr) { ioptPtr = (ItclOption*)Tcl_GetHashValue(hPtr); objPtr = ioptPtr->namePtr; Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); hPtr = Tcl_NextHashEntry(&place); } } Itcl_DeleteHierIter(&hier); Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoComponentCmd() * * Returns information regarding class components. * Handles the following syntax: * * info component ?componentName? ?-inherit? ?-name? ?-value? * * If the ?componentName? is not specified, then a list of all known * data members is returned. Otherwise, the information for a * specific member is returned. Returns a status TCL_OK/TCL_ERROR * to indicate success/failure. * ------------------------------------------------------------------------ */ int Itcl_BiInfoComponentCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { char *componentName = NULL; Tcl_Obj *resultPtr = NULL; Tcl_Obj *objPtr = NULL; Tcl_Obj *componentNamePtr; static const char *components[] = { "-name", "-inherit", "-value", NULL }; enum BCompIdx { BCompNameIdx, BCompInheritIdx, BCompValueIdx } *icomplist, icomplistStorage[3]; static enum BCompIdx DefInfoComponent[3] = { BCompNameIdx, BCompInheritIdx, BCompValueIdx }; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; ItclObjectInfo *infoPtr; Tcl_HashSearch place; Tcl_HashEntry *hPtr; Tcl_Namespace *nsPtr; ItclComponent *icPtr; ItclHierIter hier; ItclClass *iclsPtr; const char *val; int i; int result; ItclShowArgs(1, "Itcl_BiInfoComponentCmd", objc, objv); /* * If this command is not invoked within a class namespace, * signal an error. */ contextIclsPtr = NULL; if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info component ... }", TCL_INDEX_NONE)); return TCL_ERROR; } if (contextIoPtr != NULL) { contextIclsPtr = contextIoPtr->iclsPtr; } nsPtr = Itcl_GetUplevelNamespace(interp, 1); if (nsPtr->parentPtr == NULL) { /* :: namespace */ nsPtr = contextIclsPtr->nsPtr; } infoPtr = contextIclsPtr->infoPtr; hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); if (hPtr == NULL) { Tcl_AppendResult(interp, "cannot find class name for namespace \"", nsPtr->fullName, "\"", NULL); return TCL_ERROR; } contextIclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); /* * Process args: * ?componentName? ?-inherit? ?-name? ?-value? */ objv++; /* skip over command name */ objc--; if (objc > 0) { componentName = Tcl_GetString(*objv); objc--; objv++; } /* * Return info for a specific component. */ if (componentName) { componentNamePtr = Tcl_NewStringObj(componentName, TCL_INDEX_NONE); if (contextIoPtr != NULL) { Itcl_InitHierIter(&hier, contextIoPtr->iclsPtr); } else { Itcl_InitHierIter(&hier, contextIclsPtr); } while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FindHashEntry(&iclsPtr->components, (char *)componentNamePtr); if (hPtr != NULL) { break; } } Tcl_DecrRefCount(componentNamePtr); Itcl_DeleteHierIter(&hier); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", componentName, "\" isn't a component in class \"", contextIclsPtr->nsPtr->fullName, "\"", NULL); return TCL_ERROR; } icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); /* * By default, return everything. */ if (objc == 0) { icomplist = DefInfoComponent; objc = 3; } else { /* * Otherwise, scan through all remaining flags and * figure out what to return. */ icomplist = &icomplistStorage[0]; for (i=0 ; i < objc; i++) { result = Tcl_GetIndexFromObjStruct(interp, objv[i], components, sizeof(char *), "component", 0, (int*)(&icomplist[i])); if (result != TCL_OK) { return TCL_ERROR; } } } if (objc > 1) { resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { switch (icomplist[i]) { case BCompNameIdx: objPtr = Tcl_NewStringObj( Tcl_GetString(icPtr->ivPtr->fullNamePtr), TCL_INDEX_NONE); break; case BCompInheritIdx: if (icPtr->flags & ITCL_COMPONENT_INHERIT) { val = "1"; } else { val = "0"; } objPtr = Tcl_NewStringObj((const char *)val, TCL_INDEX_NONE); break; case BCompValueIdx: if (contextIoPtr == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot access object-specific info ", "without an object context", NULL); return TCL_ERROR; } else { val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr), NULL, contextIoPtr, icPtr->ivPtr->iclsPtr); } if (val == NULL) { val = ""; } objPtr = Tcl_NewStringObj((const char *)val, TCL_INDEX_NONE); break; } if (objc == 1) { resultPtr = objPtr; } else { Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } Tcl_SetObjResult(interp, resultPtr); } else { /* * Return the list of available components. */ resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FirstHashEntry(&iclsPtr->components, &place); while (hPtr) { icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); objPtr = Tcl_NewStringObj( Tcl_GetString(icPtr->ivPtr->fullNamePtr), TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); hPtr = Tcl_NextHashEntry(&place); } } Itcl_DeleteHierIter(&hier); Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoWidgetCmd() * * Returns information regarding widget classes. * Handles the following syntax: * * info widget ?widgetName? * * If the ?widgetName? is not specified, then a list of all known * data members is returned. Otherwise, the information for a * specific member is returned. Returns a status TCL_OK/TCL_ERROR * to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoWidgetCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Namespace *contextNs = NULL; Tcl_Obj *objPtr; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; char *name; ItclShowArgs(1, "Itcl_BiInfoWidgetCmd", objc, objv); if (objc != 1) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"info widget\"", NULL); return TCL_ERROR; } /* * If this command is not invoked within a class namespace, * signal an error. */ contextIclsPtr = NULL; if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { /* try it the hard way */ void *clientData; ItclObjectInfo *infoPtr; Tcl_Object oPtr; clientData = Itcl_GetCallFrameClientData(interp); infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); if (clientData != NULL) { oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)clientData); contextIoPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, infoPtr->object_meta_type); contextIclsPtr = contextIoPtr->iclsPtr; } if ((contextIoPtr == NULL) || (contextIclsPtr == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info widget ... }", TCL_INDEX_NONE)); return TCL_ERROR; } } /* * If there is an object context, then return the most-specific * class for the object. Otherwise, return the class namespace * name. Use normal class names when possible. */ if (contextIoPtr) { contextNs = contextIoPtr->iclsPtr->nsPtr; } else { assert(contextIclsPtr != NULL); assert(contextIclsPtr->nsPtr != NULL); if (contextIclsPtr->infoPtr->useOldResolvers) { contextNs = contextIclsPtr->nsPtr; } else { contextNs = contextIclsPtr->nsPtr; } } name = contextNs->fullName; if (!(contextIclsPtr->flags & ITCL_WIDGET)) { Tcl_AppendResult(interp, "object or class is no widget", NULL); return TCL_ERROR; } objPtr = Tcl_NewStringObj(name, TCL_INDEX_NONE); Tcl_SetObjResult(interp, objPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoExtendedClassCmd() * * Returns information regarding extendedclasses. * Handles the following syntax: * * info extendedclass ?className? * * If the ?className? is not specified, then a list of all known * data members is returned. Otherwise, the information for a * specific member is returned. Returns a status TCL_OK/TCL_ERROR * to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoExtendedClassCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { #ifdef NOTYET static const char *components[] = { "-name", "-inherit", "-value", NULL }; enum BCompIdx { BCompNameIdx, BCompInheritIdx, BCompValueIdx } *icomplist, icomplistStorage[3]; static enum BCompIdx DefInfoComponent[3] = { BCompNameIdx, BCompInheritIdx, BCompValueIdx }; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; ItclObjectInfo *infoPtr; Tcl_HashSearch place; Tcl_HashEntry *hPtr; Tcl_Namespace *nsPtr; ItclHierIter hier; ItclClass *iclsPtr; const char *name; int result; ItclShowArgs(1, "Itcl_BiInfoExtendedClassCmd", objc, objv); /* * If this command is not invoked within a class namespace, * signal an error. */ contextIclsPtr = NULL; if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info extendedclass ... }", TCL_INDEX_NONE)); return TCL_ERROR; } if (contextIoPtr != NULL) { contextIclsPtr = contextIoPtr->iclsPtr; } nsPtr = Itcl_GetUplevelNamespace(interp, 1); if (nsPtr->parentPtr == NULL) { /* :: namespace */ nsPtr = contextIclsPtr->nsPtr; } infoPtr = contextIclsPtr->infoPtr; hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); if (hPtr == NULL) { Tcl_AppendResult(interp, "cannot find class name for namespace \"", nsPtr->fullName, "\"", NULL); return TCL_ERROR; } contextIclsPtr = Tcl_GetHashValue(hPtr); #else (void)interp; (void)objc; (void)objv; #endif return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoDelegatedCmd() * * Returns information regarding extendedclasses. * Handles the following syntax: * * info extendedclass ?className? * * If the ?className? is not specified, then a list of all known * data members is returned. Otherwise, the information for a * specific member is returned. Returns a status TCL_OK/TCL_ERROR * to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoDelegatedCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { #ifdef NOTYET static const char *components[] = { "-name", "-inherit", "-value", NULL }; enum BCompIdx { BCompNameIdx, BCompInheritIdx, BCompValueIdx } *icomplist, icomplistStorage[3]; static enum BCompIdx DefInfoComponent[3] = { BCompNameIdx, BCompInheritIdx, BCompValueIdx }; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; ItclObjectInfo *infoPtr; Tcl_HashSearch place; Tcl_HashEntry *hPtr; Tcl_Namespace *nsPtr; ItclHierIter hier; ItclClass *iclsPtr; const char *name; int result; ItclShowArgs(1, "Itcl_BiInfoDelegatedCmd", objc, objv); /* * If this command is not invoked within a class namespace, * signal an error. */ contextIclsPtr = NULL; if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info delegated ... }", TCL_INDEX_NONE)); return TCL_ERROR; } if (contextIoPtr != NULL) { contextIclsPtr = contextIoPtr->iclsPtr; } nsPtr = Itcl_GetUplevelNamespace(interp, 1); if (nsPtr->parentPtr == NULL) { /* :: namespace */ nsPtr = contextIclsPtr->nsPtr; } infoPtr = contextIclsPtr->infoPtr; hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); if (hPtr == NULL) { Tcl_AppendResult(interp, "cannot find class name for namespace \"", nsPtr->fullName, "\"", NULL); return TCL_ERROR; } contextIclsPtr = Tcl_GetHashValue(hPtr); #else (void)interp; (void)objc; (void)objv; #endif return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoTypeCmd() * * Returns information regarding the Type for an object. This command * can be invoked with or without an object context: * * info type <= returns most-specific class name * info type <= returns active namespace name * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoTypeCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Namespace *contextNs = NULL; Tcl_Obj *objPtr; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; char *name; ItclShowArgs(1, "Itcl_BiInfoTypeCmd", objc, objv); if (objc != 1) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"info type\"", NULL); return TCL_ERROR; } /* * If this command is not invoked within a class namespace, * signal an error. */ contextIclsPtr = NULL; if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { /* try it the hard way */ void *clientData; ItclObjectInfo *infoPtr; Tcl_Object oPtr; clientData = Itcl_GetCallFrameClientData(interp); infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); if (clientData != NULL) { oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)clientData); contextIoPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, infoPtr->object_meta_type); contextIclsPtr = contextIoPtr->iclsPtr; } if ((contextIoPtr == NULL) || (contextIclsPtr == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info type ...}", TCL_INDEX_NONE)); return TCL_ERROR; } } /* * If there is an object context, then return the most-specific * class for the object. Otherwise, return the class namespace * name. Use normal class names when possible. */ if (contextIoPtr) { contextNs = contextIoPtr->iclsPtr->nsPtr; } else { assert(contextIclsPtr != NULL); assert(contextIclsPtr->nsPtr != NULL); if (contextIclsPtr->infoPtr->useOldResolvers) { contextNs = contextIclsPtr->nsPtr; } else { contextNs = contextIclsPtr->nsPtr; } } name = contextNs->fullName; if (!(contextIclsPtr->flags & ITCL_TYPE)) { Tcl_AppendResult(interp, "object or class is no type", NULL); return TCL_ERROR; } objPtr = Tcl_NewStringObj(name, TCL_INDEX_NONE); Tcl_SetObjResult(interp, objPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoHullTypeCmd() * * Returns information regarding the hulltype for an object. This command * can be invoked with or without an object context: * * info hulltype returns the hulltype name * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoHullTypeCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclClass *contextIclsPtr; ItclObject *contextIoPtr; ItclShowArgs(1, "Itcl_BiInfoHullTypeCmd", objc, objv); if (objc != 1) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"info hulltype\"", NULL); return TCL_ERROR; } /* * If this command is not invoked within a class namespace, * signal an error. */ contextIclsPtr = NULL; if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { /* try it the hard way */ void *clientData; ItclObjectInfo *infoPtr; Tcl_Object oPtr; clientData = Itcl_GetCallFrameClientData(interp); infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); if (clientData != NULL) { oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)clientData); contextIoPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, infoPtr->object_meta_type); contextIclsPtr = contextIoPtr->iclsPtr; } if ((contextIoPtr == NULL) || (contextIclsPtr == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info hulltype ... }", TCL_INDEX_NONE)); return TCL_ERROR; } } if (!(contextIclsPtr->flags & ITCL_WIDGET)) { Tcl_AppendResult(interp, "object or class is no widget.", " Only ::itcl::widget has a hulltype.", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, contextIclsPtr->hullTypePtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoDefaultCmd() * * Returns information regarding the Type for an object. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoDefaultCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; ItclObject *ioPtr; ItclClass *iclsPtr; ItclMemberFunc *imPtr; ItclDelegatedFunction *idmPtr; ItclArgList *argListPtr; const char *methodName; const char *argName; const char *what; int found; ItclShowArgs(1, "Itcl_BiInfoDefaultCmd", objc, objv); iclsPtr = NULL; found = 0; if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { return TCL_ERROR; } if (ioPtr != NULL) { iclsPtr = ioPtr->iclsPtr; } if (objc != 4) { Tcl_AppendResult(interp, "wrong # args, should be info default ", " ", NULL); return TCL_ERROR; } methodName = Tcl_GetString(objv[1]); argName = Tcl_GetString(objv[2]); FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) { if (strcmp(methodName, Tcl_GetString(imPtr->namePtr)) == 0) { found = 1; break; } } if (found) { argListPtr = imPtr->argListPtr; while (argListPtr != NULL) { if (strcmp(argName, Tcl_GetString(argListPtr->namePtr)) == 0) { if (argListPtr->defaultValuePtr != NULL) { if (NULL == Tcl_ObjSetVar2(interp, objv[3], NULL, argListPtr->defaultValuePtr, TCL_LEAVE_ERR_MSG)) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); return TCL_OK; } else { Tcl_AppendResult(interp, "method \"", methodName, "\" has no default value for argument \"", argName, "\"", NULL); return TCL_ERROR; } } argListPtr = argListPtr->nextPtr; } } if (! found) { FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { if (strcmp(methodName, Tcl_GetString(idmPtr->namePtr)) == 0) { what = "method"; if (idmPtr->flags & ITCL_TYPE_METHOD) { what = "typemethod"; } Tcl_AppendResult(interp, "delegated ", what, " \"", methodName, "\"", NULL); return TCL_ERROR; } } } if (! found) { Tcl_AppendResult(interp, "unknown method \"", methodName, "\"", NULL); return TCL_ERROR; } Tcl_AppendResult(interp, "method \"", methodName, "\" has no argument \"", argName, "\"", NULL); return TCL_ERROR; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoMethodCmd() * * Returns information regarding a method for an object. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoMethodCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *resultPtr; Tcl_Obj *objPtr; Tcl_HashSearch place; Tcl_HashEntry *hPtr; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; ItclClass *iclsPtr; ItclMemberFunc *imPtr; ItclMemberCode *mcode; ItclHierIter hier; const char *val; char *cmdName; int i; int result; static const char *options[] = { "-args", "-body", "-name", "-protection", "-type", NULL }; enum BIfIdx { BIfArgsIdx, BIfBodyIdx, BIfNameIdx, BIfProtectIdx, BIfTypeIdx } *iflist, iflistStorage[5]; static enum BIfIdx DefInfoFunction[5] = { BIfProtectIdx, BIfTypeIdx, BIfNameIdx, BIfArgsIdx, BIfBodyIdx }; ItclShowArgs(1, "Itcl_BiInfoMethodCmd", objc, objv); cmdName = NULL; objPtr = NULL; resultPtr = NULL; contextIclsPtr = NULL; /* * If this command is not invoked within a class namespace, * signal an error. */ if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info method ... }", TCL_INDEX_NONE)); return TCL_ERROR; } if (contextIoPtr != NULL) { contextIclsPtr = contextIoPtr->iclsPtr; } /* * Process args: * ?cmdName? ?-protection? ?-type? ?-name? ?-args? ?-body? */ objv++; /* skip over command name */ objc--; if (objc > 0) { cmdName = Tcl_GetString(*objv); objc--; objv++; } /* * Return info for a specific command. */ if (cmdName) { ItclCmdLookup *clookup; objPtr = Tcl_NewStringObj(cmdName, TCL_INDEX_NONE); hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveCmds, (char *)objPtr); Tcl_DecrRefCount(objPtr); objPtr = NULL; if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a method in class \"", contextIclsPtr->nsPtr->fullName, "\"", NULL); return TCL_ERROR; } clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); imPtr = clookup->imPtr; mcode = imPtr->codePtr; if (imPtr->flags & ITCL_COMMON) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a method in class \"", contextIclsPtr->nsPtr->fullName, "\"", NULL); return TCL_ERROR; } /* * By default, return everything. */ if (objc == 0) { objc = 5; iflist = DefInfoFunction; } else { /* * Otherwise, scan through all remaining flags and * figure out what to return. */ iflist = &iflistStorage[0]; for (i=0 ; i < objc; i++) { result = Tcl_GetIndexFromObjStruct(interp, objv[i], options, sizeof(char *), "option", 0, (int*)(&iflist[i])); if (result != TCL_OK) { return TCL_ERROR; } } } if (objc > 1) { resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { switch (iflist[i]) { case BIfArgsIdx: if (mcode && mcode->argListPtr) { if (imPtr->usagePtr == NULL) { objPtr = Tcl_NewStringObj( Tcl_GetString(mcode->usagePtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj( Tcl_GetString(imPtr->usagePtr), TCL_INDEX_NONE); } } else { if ((imPtr->flags & ITCL_ARG_SPEC) != 0) { if (imPtr->usagePtr == NULL) { objPtr = Tcl_NewStringObj( Tcl_GetString(mcode->usagePtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj( Tcl_GetString(imPtr->usagePtr), TCL_INDEX_NONE); } } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } } break; case BIfBodyIdx: if (mcode && Itcl_IsMemberCodeImplemented(mcode)) { objPtr = Tcl_NewStringObj( Tcl_GetString(mcode->bodyPtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BIfNameIdx: objPtr = Tcl_NewStringObj( Tcl_GetString(imPtr->fullNamePtr), TCL_INDEX_NONE); break; case BIfProtectIdx: val = Itcl_ProtectionStr(imPtr->protection); objPtr = Tcl_NewStringObj(val, TCL_INDEX_NONE); break; case BIfTypeIdx: val = "method"; objPtr = Tcl_NewStringObj(val, TCL_INDEX_NONE); break; } if (objc == 1) { resultPtr = objPtr; } else { Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } Tcl_SetObjResult(interp, resultPtr); } else { /* * Return the list of available commands. */ resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FirstHashEntry(&iclsPtr->functions, &place); while (hPtr) { int useIt = 1; imPtr = (ItclMemberFunc*)Tcl_GetHashValue(hPtr); if (!(imPtr->flags & ITCL_METHOD)) { useIt = 0; } if (useIt) { objPtr = Tcl_NewStringObj( Tcl_GetString(imPtr->fullNamePtr), TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } hPtr = Tcl_NextHashEntry(&place); } } Itcl_DeleteHierIter(&hier); Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoMethodsCmd() * * Returns information regarding the methods for an object. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoMethodsCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_Obj *listPtr; ItclObject *ioPtr; ItclClass *iclsPtr; ItclMemberFunc *imPtr; ItclDelegatedFunction *idmPtr; const char *name; const char *pattern; ItclShowArgs(1, "Itcl_BiInfoMethodsCmd", objc, objv); iclsPtr = NULL; pattern = NULL; if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { Tcl_AppendResult(interp, "cannot get context ", NULL); return TCL_ERROR; } if (ioPtr != NULL) { iclsPtr = ioPtr->iclsPtr; } if (objc == 2) { pattern = Tcl_GetString(objv[1]); } listPtr = Tcl_NewListObj(0, NULL); name = "destroy"; if ((pattern == NULL) || Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(name, TCL_INDEX_NONE)); } name = "info"; if ((pattern == NULL) || Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(name, TCL_INDEX_NONE)); } FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) { name = Tcl_GetString(imPtr->namePtr); if (strcmp(name, "*") == 0) { continue; } if (strcmp(name, "destroy") == 0) { continue; } if (strcmp(name, "info") == 0) { continue; } if ((imPtr->flags & ITCL_METHOD) && !(imPtr->flags & ITCL_CONSTRUCTOR) && !(imPtr->flags & ITCL_DESTRUCTOR) && !(imPtr->flags & ITCL_COMMON) && !(imPtr->codePtr->flags & ITCL_BUILTIN)) { if ((pattern == NULL) || Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(imPtr->namePtr), TCL_INDEX_NONE)); } } } FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { name = Tcl_GetString(idmPtr->namePtr); if (strcmp(name, "*") == 0) { continue; } if (strcmp(name, "destroy") == 0) { continue; } if (strcmp(name, "info") == 0) { continue; } if (idmPtr->flags & ITCL_METHOD) { if ((pattern == NULL) || Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(idmPtr->namePtr), TCL_INDEX_NONE)); } } } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoOptionsCmd() * * Returns information regarding the Type for an object. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoOptionsCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_HashEntry *hPtr2; Tcl_Obj *listPtr; Tcl_Obj *listPtr2; Tcl_Obj *objPtr; Tcl_Obj **lObjv; Tcl_HashTable *tablePtr; ItclObject *ioPtr; ItclClass *iclsPtr; ItclOption *ioptPtr; ItclDelegatedOption *idoPtr; const char *name; const char *val; const char *pattern; Tcl_Size lObjc; int result; Tcl_Size i; ItclShowArgs(1, "Itcl_BiInfoOptionsCmd", objc, objv); iclsPtr = NULL; pattern = NULL; if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { Tcl_AppendResult(interp, "cannot get context ", NULL); return TCL_ERROR; } if (ioPtr != NULL) { iclsPtr = ioPtr->iclsPtr; } if (objc > 2) { Tcl_AppendResult(interp, "wrong # args should be: info options ", "?pattern?", NULL); return TCL_ERROR; } if (objc == 2) { pattern = Tcl_GetString(objv[1]); } listPtr = Tcl_NewListObj(0, NULL); if (ioPtr == NULL) { tablePtr = &iclsPtr->options; } else { tablePtr = &ioPtr->objectOptions; } FOREACH_HASH_VALUE(ioptPtr, tablePtr) { name = Tcl_GetString(ioptPtr->namePtr); if ((pattern == NULL) || Tcl_StringCaseMatch(name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(ioptPtr->namePtr), TCL_INDEX_NONE)); } } if (ioPtr == NULL) { tablePtr = &iclsPtr->delegatedOptions; } else { tablePtr = &ioPtr->objectDelegatedOptions; } FOREACH_HASH_VALUE(idoPtr, tablePtr) { name = Tcl_GetString(idoPtr->namePtr); if (strcmp(name, "*") != 0) { if ((pattern == NULL) || Tcl_StringCaseMatch(name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(idoPtr->namePtr), TCL_INDEX_NONE)); } } else { if (idoPtr->icPtr == NULL) { Tcl_AppendResult(interp, "component \"", Tcl_GetString(idoPtr->namePtr), "\" is not initialized", NULL); return TCL_ERROR; } val = ItclGetInstanceVar(interp, Tcl_GetString(idoPtr->icPtr->namePtr), NULL, ioPtr, ioPtr->iclsPtr); if ((val != NULL) && (strlen(val) != 0)) { objPtr = Tcl_NewStringObj(val, TCL_INDEX_NONE); Tcl_AppendToObj(objPtr, " configure", TCL_INDEX_NONE); result = Tcl_EvalObjEx(interp, objPtr, 0); if (result != TCL_OK) { return TCL_ERROR; } listPtr2 = Tcl_GetObjResult(interp); Tcl_ListObjGetElements(interp, listPtr2, &lObjc, &lObjv); for (i = 0; i < lObjc; i++) { Tcl_ListObjIndex(interp, lObjv[i], 0, &objPtr); hPtr2 = Tcl_FindHashEntry(&idoPtr->exceptions, (char *)objPtr); if (hPtr2 == NULL) { name = Tcl_GetString(objPtr); if ((pattern == NULL) || Tcl_StringCaseMatch(name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, objPtr); } } } } } } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoTypesCmd() * * Returns information regarding the Type for an object. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoTypesCmd( void *clientData, /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_Obj *listPtr; ItclObjectInfo *infoPtr; ItclClass *iclsPtr; const char *name; const char *pattern; ItclShowArgs(1, "Itcl_BiInfoTypesCmd", objc, objv); infoPtr = (ItclObjectInfo *)clientData; iclsPtr = NULL; pattern = NULL; if (objc > 2) { Tcl_AppendResult(interp, "wrong # args should be: info types ", "?pattern?", NULL); return TCL_ERROR; } if (objc == 2) { pattern = Tcl_GetString(objv[1]); } listPtr = Tcl_NewListObj(0, NULL); FOREACH_HASH_VALUE(iclsPtr, &infoPtr->nameClasses) { if (iclsPtr->flags & ITCL_TYPE) { name = Tcl_GetString(iclsPtr->namePtr); if ((pattern == NULL) || Tcl_StringCaseMatch(name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(iclsPtr->namePtr), TCL_INDEX_NONE)); } } } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoComponentsCmd() * * Returns information regarding the Components for an object. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoComponentsCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_Obj *listPtr; ItclObject *ioPtr; ItclClass *iclsPtr; ItclComponent *icPtr; ItclHierIter hier; ItclClass *iclsPtr2; const char *name; const char *pattern; ItclShowArgs(1, "Itcl_BiInfoComponentsCmd", objc, objv); iclsPtr = NULL; pattern = NULL; if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { Tcl_AppendResult(interp, "cannot get context ", NULL); return TCL_ERROR; } if (ioPtr != NULL) { iclsPtr = ioPtr->iclsPtr; } if (iclsPtr == NULL) { Tcl_AppendResult(interp, "INTERNAL ERROR in Itcl_BiInfoComponentsCmd", " iclsPtr == NULL", NULL); return TCL_ERROR; } if (objc > 2) { Tcl_AppendResult(interp, "wrong # args should be: info components ", "?pattern?", NULL); return TCL_ERROR; } if (objc == 2) { pattern = Tcl_GetString(objv[1]); } listPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, iclsPtr); iclsPtr2 = Itcl_AdvanceHierIter(&hier); while (iclsPtr2 != NULL) { FOREACH_HASH_VALUE(icPtr, &iclsPtr2->components) { name = Tcl_GetString(icPtr->namePtr); if ((pattern == NULL) || Tcl_StringCaseMatch(name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(icPtr->namePtr), TCL_INDEX_NONE)); } } iclsPtr2 = Itcl_AdvanceHierIter(&hier); } Itcl_DeleteHierIter(&hier); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoTypeMethodCmd() * * Returns information regarding a typemethod for an object. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoTypeMethodCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *resultPtr; Tcl_Obj *objPtr; Tcl_HashSearch place; Tcl_HashEntry *hPtr; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; ItclClass *iclsPtr; ItclMemberFunc *imPtr; ItclMemberCode *mcode; ItclHierIter hier; const char *val; char *cmdName; int i; int result; static const char *options[] = { "-args", "-body", "-name", "-protection", "-type", NULL }; enum BIfIdx { BIfArgsIdx, BIfBodyIdx, BIfNameIdx, BIfProtectIdx, BIfTypeIdx } *iflist, iflistStorage[5]; static enum BIfIdx DefInfoFunction[5] = { BIfProtectIdx, BIfTypeIdx, BIfNameIdx, BIfArgsIdx, BIfBodyIdx }; ItclShowArgs(1, "Itcl_BiInfoTypeMethodCmd", objc, objv); resultPtr = NULL; objPtr = NULL; cmdName = NULL; contextIclsPtr = NULL; /* * If this command is not invoked within a class namespace, * signal an error. */ if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info function ... }", TCL_INDEX_NONE)); return TCL_ERROR; } if (contextIoPtr != NULL) { contextIclsPtr = contextIoPtr->iclsPtr; } /* * Process args: * ?cmdName? ?-protection? ?-type? ?-name? ?-args? ?-body? */ objv++; /* skip over command name */ objc--; if (objc > 0) { cmdName = Tcl_GetString(*objv); objc--; objv++; } /* * Return info for a specific command. */ if (cmdName) { ItclCmdLookup *clookup; objPtr = Tcl_NewStringObj(cmdName, TCL_INDEX_NONE); hPtr = Tcl_FindHashEntry(&contextIclsPtr->resolveCmds, (char *)objPtr); Tcl_DecrRefCount(objPtr); objPtr = NULL; if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a typemethod in class \"", contextIclsPtr->nsPtr->fullName, "\"", NULL); return TCL_ERROR; } clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); imPtr = clookup->imPtr; mcode = imPtr->codePtr; if (!(imPtr->flags & ITCL_TYPE_METHOD)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a typemethod in class \"", contextIclsPtr->nsPtr->fullName, "\"", NULL); return TCL_ERROR; } /* * By default, return everything. */ if (objc == 0) { objc = 5; iflist = DefInfoFunction; } else { /* * Otherwise, scan through all remaining flags and * figure out what to return. */ iflist = &iflistStorage[0]; for (i=0 ; i < objc; i++) { result = Tcl_GetIndexFromObjStruct(interp, objv[i], options, sizeof(char *), "option", 0, (int*)(&iflist[i])); if (result != TCL_OK) { return TCL_ERROR; } } } if (objc > 1) { resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { switch (iflist[i]) { case BIfArgsIdx: if (mcode && mcode->argListPtr) { if (imPtr->usagePtr == NULL) { objPtr = Tcl_NewStringObj( Tcl_GetString(mcode->usagePtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj( Tcl_GetString(imPtr->usagePtr), TCL_INDEX_NONE); } } else { if ((imPtr->flags & ITCL_ARG_SPEC) != 0) { if (imPtr->usagePtr == NULL) { objPtr = Tcl_NewStringObj( Tcl_GetString(mcode->usagePtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj( Tcl_GetString(imPtr->usagePtr), TCL_INDEX_NONE); } } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } } break; case BIfBodyIdx: if (mcode && Itcl_IsMemberCodeImplemented(mcode)) { objPtr = Tcl_NewStringObj( Tcl_GetString(mcode->bodyPtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BIfNameIdx: objPtr = Tcl_NewStringObj( Tcl_GetString(imPtr->fullNamePtr), TCL_INDEX_NONE); break; case BIfProtectIdx: val = Itcl_ProtectionStr(imPtr->protection); objPtr = Tcl_NewStringObj(val, TCL_INDEX_NONE); break; case BIfTypeIdx: val = "typemethod"; objPtr = Tcl_NewStringObj(val, TCL_INDEX_NONE); break; } if (objc == 1) { resultPtr = objPtr; } else { Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } Tcl_SetObjResult(interp, resultPtr); } else { /* * Return the list of available commands. */ resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FirstHashEntry(&iclsPtr->functions, &place); while (hPtr) { int useIt = 1; imPtr = (ItclMemberFunc*)Tcl_GetHashValue(hPtr); if (!(imPtr->flags & ITCL_TYPE_METHOD)) { useIt = 0; } if (useIt) { objPtr = Tcl_NewStringObj( Tcl_GetString(imPtr->fullNamePtr), TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } hPtr = Tcl_NextHashEntry(&place); } } Itcl_DeleteHierIter(&hier); Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoMethodsCmd() * * Returns information regarding the methods for an object. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoTypeMethodsCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_Obj *listPtr; ItclObject *ioPtr; ItclClass *iclsPtr; ItclMemberFunc *imPtr; ItclDelegatedFunction *idmPtr; const char *name; const char *pattern; ItclShowArgs(1, "Itcl_BiInfoTypeMethodsCmd", objc, objv); iclsPtr = NULL; pattern = NULL; if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { Tcl_AppendResult(interp, "cannot get context ", NULL); return TCL_ERROR; } if (ioPtr != NULL) { iclsPtr = ioPtr->iclsPtr; } if (objc > 1) { pattern = Tcl_GetString(objv[1]); } listPtr = Tcl_NewListObj(0, NULL); name = "create"; if ((pattern == NULL) || Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(name, TCL_INDEX_NONE)); } name = "destroy"; if ((pattern == NULL) || Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(name, TCL_INDEX_NONE)); } name = "info"; if ((pattern == NULL) || Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(name, TCL_INDEX_NONE)); } FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) { name = Tcl_GetString(imPtr->namePtr); if (strcmp(name, "*") == 0) { continue; } if (strcmp(name, "create") == 0) { continue; } if (strcmp(name, "destroy") == 0) { continue; } if (strcmp(name, "info") == 0) { continue; } if (imPtr->flags & ITCL_TYPE_METHOD) { if ((pattern == NULL) || Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(imPtr->namePtr), TCL_INDEX_NONE)); } } } FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { name = Tcl_GetString(idmPtr->namePtr); if (strcmp(name, "*") == 0) { continue; } if (strcmp(name, "create") == 0) { continue; } if (strcmp(name, "destroy") == 0) { continue; } if (strcmp(name, "info") == 0) { continue; } if (idmPtr->flags & ITCL_TYPE_METHOD) { if ((pattern == NULL) || Tcl_StringCaseMatch((const char *)name, pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(Tcl_GetString(idmPtr->namePtr), TCL_INDEX_NONE)); } } } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoTypeVarsCmd() * * Returns information regarding variables for an object. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoTypeVarsCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_Obj *listPtr; ItclObject *ioPtr; ItclClass *iclsPtr; ItclVariable *ivPtr; const char *pattern; ItclShowArgs(1, "Itcl_BiInfoTypeVarsCmd", objc, objv); if (objc > 2) { Tcl_AppendResult(interp, "wrong # args should be: info typevars ?pattern?", NULL); return TCL_ERROR; } iclsPtr = NULL; pattern = NULL; if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { Tcl_AppendResult(interp, "cannot get context ", NULL); return TCL_ERROR; } if (ioPtr != NULL) { iclsPtr = ioPtr->iclsPtr; } if (objc == 2) { pattern = Tcl_GetString(objv[1]); } listPtr = Tcl_NewListObj(0, NULL); FOREACH_HASH_VALUE(ivPtr, &iclsPtr->variables) { if ((pattern == NULL) || Tcl_StringCaseMatch(Tcl_GetString(ivPtr->namePtr), pattern, 0)) { if (ivPtr->flags & ITCL_TYPE_VARIABLE) { Tcl_ListObjAppendElement(interp, listPtr, ivPtr->fullNamePtr); } } } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoTypeVariableCmd() * * Returns information regarding a typevariable for an object. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoTypeVariableCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *resultPtr; Tcl_Obj *objPtr; Tcl_HashSearch place; Tcl_HashEntry *hPtr; ItclClass *iclsPtr; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; ItclVariable *ivPtr; ItclVarLookup *vlookup; ItclHierIter hier; char *varName; const char *val; int i; int result; static const char *options[] = { "-init", "-name", "-protection", "-type", "-value", NULL }; enum BIvIdx { BIvInitIdx, BIvNameIdx, BIvProtectIdx, BIvTypeIdx, BIvValueIdx } *ivlist, ivlistStorage[5]; static enum BIvIdx DefInfoVariable[5] = { BIvProtectIdx, BIvTypeIdx, BIvNameIdx, BIvInitIdx, BIvValueIdx }; ItclShowArgs(1, "Itcl_BiInfoTypeVariableCmd", objc, objv); resultPtr = NULL; objPtr = NULL; varName = NULL; contextIclsPtr = NULL; /* * If this command is not invoked within a class namespace, * signal an error. */ if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info typevariable ... }", TCL_INDEX_NONE)); return TCL_ERROR; } if (contextIoPtr != NULL) { contextIclsPtr = contextIoPtr->iclsPtr; } /* * Process args: * ?varName? ?-protection? ?-type? ?-name? ?-init? ?-config? ?-value? */ objv++; /* skip over command name */ objc--; if (objc > 0) { varName = Tcl_GetString(*objv); objc--; objv++; } /* * Return info for a specific variable. */ if (varName) { hPtr = ItclResolveVarEntry(contextIclsPtr, varName); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", varName, "\" isn't a typevariable in class \"", contextIclsPtr->nsPtr->fullName, "\"", NULL); return TCL_ERROR; } vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); ivPtr = vlookup->ivPtr; if (!(ivPtr->flags & ITCL_TYPE_VARIABLE)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", varName, "\" isn't a typevariable in class \"", contextIclsPtr->nsPtr->fullName, "\"", NULL); return TCL_ERROR; } /* * By default, return everything. */ if (objc == 0) { ivlist = DefInfoVariable; objc = 5; } else { /* * Otherwise, scan through all remaining flags and * figure out what to return. */ ivlist = &ivlistStorage[0]; for (i=0 ; i < objc; i++) { result = Tcl_GetIndexFromObjStruct(interp, objv[i], options, sizeof(char *), "option", 0, (int*)(&ivlist[i])); if (result != TCL_OK) { return TCL_ERROR; } } } if (objc > 1) { resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { switch (ivlist[i]) { case BIvInitIdx: /* * If this is the built-in "this" variable, then * report the object name as its initialization string. */ if ((ivPtr->flags & ITCL_THIS_VAR) != 0) { if ((contextIoPtr != NULL) && (contextIoPtr->accessCmd != NULL)) { objPtr = Tcl_NewStringObj(NULL, 0); Tcl_GetCommandFullName( contextIoPtr->iclsPtr->interp, contextIoPtr->accessCmd, objPtr); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } } else { if (vlookup->ivPtr->init) { objPtr = Tcl_NewStringObj( Tcl_GetString(vlookup->ivPtr->init), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } } break; case BIvNameIdx: objPtr = Tcl_NewStringObj( Tcl_GetString(ivPtr->fullNamePtr), TCL_INDEX_NONE); break; case BIvProtectIdx: val = Itcl_ProtectionStr(ivPtr->protection); objPtr = Tcl_NewStringObj((const char *)val, TCL_INDEX_NONE); break; case BIvTypeIdx: val = ((ivPtr->flags & ITCL_COMMON) != 0) ? "common" : "variable"; objPtr = Tcl_NewStringObj((const char *)val, TCL_INDEX_NONE); break; case BIvValueIdx: if ((ivPtr->flags & ITCL_COMMON) != 0) { val = Itcl_GetCommonVar(interp, Tcl_GetString(ivPtr->fullNamePtr), ivPtr->iclsPtr); } else { if (contextIoPtr == NULL) { if (objc > 1) { Tcl_DecrRefCount(resultPtr); } Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot access object-specific info ", "without an object context", NULL); return TCL_ERROR; } else { val = Itcl_GetInstanceVar(interp, Tcl_GetString(ivPtr->namePtr), contextIoPtr, ivPtr->iclsPtr); } } if (val == NULL) { val = ""; } objPtr = Tcl_NewStringObj((const char *)val, TCL_INDEX_NONE); break; } if (objc == 1) { resultPtr = objPtr; } else { Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_GetString(resultPtr), NULL); Tcl_DecrRefCount(resultPtr); } else { /* * Return the list of available variables. Report the built-in * "this" variable only once, for the most-specific class. */ resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FirstHashEntry(&iclsPtr->variables, &place); while (hPtr) { ivPtr = (ItclVariable*)Tcl_GetHashValue(hPtr); if (ivPtr->flags & ITCL_TYPE_VAR) { if ((ivPtr->flags & ITCL_THIS_VAR) != 0) { if (iclsPtr == contextIclsPtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(ivPtr->fullNamePtr), TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } else { objPtr = Tcl_NewStringObj( Tcl_GetString(ivPtr->fullNamePtr), TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } hPtr = Tcl_NextHashEntry(&place); } } Itcl_DeleteHierIter(&hier); Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoVariablesCmd() * * Returns information regarding typevariables for an object. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoVariablesCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclShowArgs(1, "Itcl_BiInfoVariablesCmd", objc, objv); Tcl_AppendResult(interp, "Itcl_BiInfoVariablesCmd not yet implemented\n", NULL); return TCL_ERROR; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoWidgetadaptorCmd() * * Returns information regarding a widgetadaptor. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoWidgetadaptorCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Namespace *contextNs = NULL; Tcl_Obj *objPtr; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; char *name; ItclShowArgs(1, "Itcl_BiInfoWidgetadaptorCmd", objc, objv); if (objc != 1) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"info widgetadaptor\"", NULL); return TCL_ERROR; } /* * If this command is not invoked within a class namespace, * signal an error. */ contextIclsPtr = NULL; if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { /* try it the hard way */ void *clientData; ItclObjectInfo *infoPtr; Tcl_Object oPtr; clientData = Itcl_GetCallFrameClientData(interp); infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); if (clientData != NULL) { oPtr = Tcl_ObjectContextObject((Tcl_ObjectContext)clientData); contextIoPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, infoPtr->object_meta_type); contextIclsPtr = contextIoPtr->iclsPtr; } if ((contextIoPtr == NULL) || (contextIclsPtr == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info widgetadaptor ... }", TCL_INDEX_NONE)); return TCL_ERROR; } } /* * If there is an object context, then return the most-specific * class for the object. Otherwise, return the class namespace * name. Use normal class names when possible. */ if (contextIoPtr) { contextNs = contextIoPtr->iclsPtr->nsPtr; } else { assert(contextIclsPtr != NULL); assert(contextIclsPtr->nsPtr != NULL); if (contextIclsPtr->infoPtr->useOldResolvers) { contextNs = contextIclsPtr->nsPtr; } else { contextNs = contextIclsPtr->nsPtr; } } name = contextNs->fullName; if (!(contextIclsPtr->flags & ITCL_WIDGETADAPTOR)) { Tcl_AppendResult(interp, "object or class is no widgetadaptor", NULL); return TCL_ERROR; } objPtr = Tcl_NewStringObj(name, TCL_INDEX_NONE); Tcl_SetObjResult(interp, objPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoInstancesCmd() * * Returns information regarding instances. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoInstancesCmd( void *clientData, /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_Obj *listPtr; Tcl_Obj *objPtr; ItclObjectInfo *infoPtr; ItclObject *ioPtr; ItclClass *iclsPtr; const char *pattern; ItclShowArgs(1, "Itcl_BiInfoInstancesCmd", objc, objv); if (objc > 2) { Tcl_AppendResult(interp, "wrong # args should be: info instances ?pattern?", NULL); return TCL_ERROR; } iclsPtr = NULL; pattern = NULL; if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { Tcl_AppendResult(interp, "cannot get context ", NULL); return TCL_ERROR; } if (ioPtr != NULL) { iclsPtr = ioPtr->iclsPtr; } if (objc == 2) { pattern = Tcl_GetString(objv[1]); } infoPtr = (ItclObjectInfo *)clientData; listPtr = Tcl_NewListObj(0, NULL); FOREACH_HASH_VALUE(ioPtr, &infoPtr->objects) { /* FIXME need to scan the inheritance too */ if (ioPtr->iclsPtr == iclsPtr) { if (ioPtr->iclsPtr->flags & ITCL_WIDGETADAPTOR) { objPtr = Tcl_NewStringObj(Tcl_GetCommandName(interp, ioPtr->accessCmd), TCL_INDEX_NONE); } else { objPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, ioPtr->accessCmd, objPtr); } if ((pattern == NULL) || Tcl_StringCaseMatch(Tcl_GetString(objPtr), pattern, 0)) { Tcl_ListObjAppendElement(interp, listPtr, objPtr); } else { Tcl_DecrRefCount(objPtr); } } } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoDelegatedOptionsCmd() * * Returns information regarding delegated options. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoDelegatedOptionsCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_Obj *listPtr; Tcl_Obj *objPtr; Tcl_Obj *objPtr2; ItclObject *ioPtr; ItclClass *iclsPtr; ItclDelegatedOption *idoPtr; const char *name; const char *pattern; ItclShowArgs(1, "Itcl_BiInfoDelegatedOptionsCmd", objc, objv); pattern = NULL; if (objc > 2) { Tcl_AppendResult(interp, "wrong # args should be: info delegated ", "options ?pattern?", NULL); return TCL_ERROR; } if (objc == 2) { pattern = Tcl_GetString(objv[1]); } if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { return TCL_ERROR; } if (ioPtr != NULL) { iclsPtr = ioPtr->iclsPtr; } listPtr = Tcl_NewListObj(0, NULL); FOREACH_HASH_VALUE(idoPtr, &iclsPtr->delegatedOptions) { if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS)) { name = Tcl_GetString(idoPtr->namePtr); if ((pattern == NULL) || Tcl_StringCaseMatch(name, pattern, 0)) { objPtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(interp, objPtr, idoPtr->namePtr); if (idoPtr->icPtr != NULL) { Tcl_ListObjAppendElement(interp, objPtr, idoPtr->icPtr->namePtr); } else { objPtr2 = Tcl_NewStringObj("", TCL_INDEX_NONE); Tcl_ListObjAppendElement(interp, objPtr, objPtr2); } Tcl_ListObjAppendElement(interp, listPtr, objPtr); } } } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoDelegatedMethodsCmd() * * Returns information regarding delegated methods. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoDelegatedMethodsCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_Obj *listPtr; Tcl_Obj *objPtr; Tcl_Obj *objPtr2; ItclObject *ioPtr; ItclClass *iclsPtr; ItclDelegatedFunction *idmPtr; const char *name; const char *pattern; ItclShowArgs(1, "Itcl_BiInfoDelegatedMethodsCmd", objc, objv); pattern = NULL; if (objc > 2) { Tcl_AppendResult(interp, "wrong # args should be: info delegated ", "methods ?pattern?", NULL); return TCL_ERROR; } if (objc == 2) { pattern = Tcl_GetString(objv[1]); } if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { return TCL_ERROR; } if (ioPtr != NULL) { iclsPtr = ioPtr->iclsPtr; } listPtr = Tcl_NewListObj(0, NULL); FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS)) { name = Tcl_GetString(idmPtr->namePtr); if ((pattern == NULL) || Tcl_StringCaseMatch(name, pattern, 0)) { if ((idmPtr->flags & ITCL_TYPE_METHOD) == 0) { objPtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(interp, objPtr, idmPtr->namePtr); if (idmPtr->icPtr != NULL) { Tcl_ListObjAppendElement(interp, objPtr, idmPtr->icPtr->namePtr); } else { objPtr2 = Tcl_NewStringObj("", TCL_INDEX_NONE); Tcl_ListObjAppendElement(interp, objPtr, objPtr2); } Tcl_ListObjAppendElement(interp, listPtr, objPtr); } } } } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoTypeMethodsCmd() * * Returns information regarding delegated type methods. This command * can be invoked with or without an object context: * * * Returns a status TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoDelegatedTypeMethodsCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_Obj *listPtr; Tcl_Obj *objPtr; Tcl_Obj *objPtr2; ItclObject *ioPtr; ItclClass *iclsPtr; ItclDelegatedFunction *idmPtr; const char *name; const char *pattern; ItclShowArgs(1, "Itcl_BiInfoDelegatedTypeMethodsCmd", objc, objv); pattern = NULL; if (objc > 2) { Tcl_AppendResult(interp, "wrong # args should be: info delegated ", "typemethods ?pattern?", NULL); return TCL_ERROR; } if (objc == 2) { pattern = Tcl_GetString(objv[1]); } if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) { return TCL_ERROR; } if (ioPtr != NULL) { iclsPtr = ioPtr->iclsPtr; } listPtr = Tcl_NewListObj(0, NULL); FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET|ITCL_ECLASS)) { name = Tcl_GetString(idmPtr->namePtr); if ((pattern == NULL) || Tcl_StringCaseMatch(name, pattern, 0)) { if (idmPtr->flags & ITCL_TYPE_METHOD) { objPtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(interp, objPtr, idmPtr->namePtr); if (idmPtr->icPtr != NULL) { Tcl_ListObjAppendElement(interp, objPtr, idmPtr->icPtr->namePtr); } else { objPtr2 = Tcl_NewStringObj("", TCL_INDEX_NONE); Tcl_ListObjAppendElement(interp, objPtr, objPtr2); } Tcl_ListObjAppendElement(interp, listPtr, objPtr); } } } } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoDelegatedUnknownCmd() * * the unknown handler for the ::itcl::builtin::Info::delagted ensemble * ------------------------------------------------------------------------ */ static int Itcl_BiInfoDelegatedUnknownCmd( void *clientData, /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *objPtr; ItclShowArgs(1, "Itcl_BiInfoDelegatedUnknownCmd", objc, objv); /* produce usage message */ objPtr = Tcl_NewStringObj( "wrong # args: should be one of...\n", TCL_INDEX_NONE); ItclGetInfoDelegatedUsage(interp, objPtr, (ItclObjectInfo *)clientData); Tcl_SetObjResult(interp, objPtr); return TCL_ERROR; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoDelegatedOptionCmd() * * Returns information regarding class options. * Handles the following syntax: * * info delegated option ?optionName? ?-name? ?-resource? ?-class? * ?-component? ?-as? ?-exceptions? * * If the ?optionName? is not specified, then a list of all known * data members is returned. Otherwise, the information for a * specific member is returned. Returns a status TCL_OK/TCL_ERROR * to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoDelegatedOptionCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_HashSearch place; Tcl_Namespace *nsPtr; Tcl_Obj *resultPtr; Tcl_Obj *objPtr; Tcl_Obj *optionNamePtr; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; ItclObjectInfo *infoPtr; ItclDelegatedOption *idoptPtr; ItclHierIter hier; ItclClass *iclsPtr; char *optionName; int i; int result; static const char *options[] = { "-as", "-class", "-component", "-exceptions", "-name", "-resource", NULL }; enum BOptIdx { BOptAsIdx, BOptClassIdx, BOptComponentIdx, BOptExceptionsIdx, BOptNameIdx, BOptResourceIdx } *ioptlist, ioptlistStorage[6]; static enum BOptIdx DefInfoOption[6] = { BOptNameIdx, BOptResourceIdx, BOptClassIdx, BOptComponentIdx, BOptAsIdx, BOptExceptionsIdx }; ItclShowArgs(1, "Itcl_BiInfoDelegatedOptionCmd", objc, objv); optionName = NULL; objPtr = NULL; resultPtr = NULL; contextIclsPtr = NULL; /* * If this command is not invoked within a class namespace, * signal an error. */ if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info delegated option ... }", TCL_INDEX_NONE)); return TCL_ERROR; } if (contextIoPtr != NULL) { contextIclsPtr = contextIoPtr->iclsPtr; } nsPtr = Itcl_GetUplevelNamespace(interp, 1); infoPtr = contextIclsPtr->infoPtr; hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); if (hPtr == NULL) { Tcl_AppendResult(interp, "cannot find class name for namespace \"", nsPtr->fullName, "\"", NULL); return TCL_ERROR; } contextIclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); /* * Process args: * ?optionName? ?-name? ?-resource? ?-class? * ?-as? ?-exceptions? */ objv++; /* skip over command name */ objc--; if (objc > 0) { optionName = Tcl_GetString(*objv); objc--; objv++; } /* * Return info for a specific option. */ if (optionName) { if (contextIoPtr == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot access object-specific info ", "without an object context", NULL); return TCL_ERROR; } optionNamePtr = Tcl_NewStringObj(optionName, TCL_INDEX_NONE); hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions, (char *)optionNamePtr); Tcl_DecrRefCount(optionNamePtr); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", optionName, "\" isn't an option in object \"", Tcl_GetString(contextIoPtr->namePtr), "\"", NULL); return TCL_ERROR; } idoptPtr = (ItclDelegatedOption*)Tcl_GetHashValue(hPtr); /* * By default, return everything. */ if (objc == 0) { ioptlist = DefInfoOption; objc = 6; } else { /* * Otherwise, scan through all remaining flags and * figure out what to return. */ ioptlist = &ioptlistStorage[0]; for (i=0 ; i < objc; i++) { result = Tcl_GetIndexFromObjStruct(interp, objv[i], options, sizeof(char *), "option", 0, (int*)(&ioptlist[i])); if (result != TCL_OK) { return TCL_ERROR; } } } if (objc > 1) { resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { switch (ioptlist[i]) { case BOptAsIdx: if (idoptPtr->asPtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(idoptPtr->asPtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptExceptionsIdx: { Tcl_Obj *entryObj; objPtr = Tcl_NewListObj(0, NULL); FOREACH_HASH_VALUE(entryObj, &idoptPtr->exceptions) { Tcl_ListObjAppendElement(interp, objPtr, entryObj); } } break; case BOptResourceIdx: if (idoptPtr->resourceNamePtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(idoptPtr->resourceNamePtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptClassIdx: if (idoptPtr->classNamePtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(idoptPtr->classNamePtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptComponentIdx: if (idoptPtr->icPtr != NULL) { objPtr = Tcl_NewStringObj( Tcl_GetString(idoptPtr->icPtr->namePtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptNameIdx: objPtr = Tcl_NewStringObj( Tcl_GetString(idoptPtr->namePtr), TCL_INDEX_NONE); break; } if (objc == 1) { resultPtr = objPtr; } else { Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } Tcl_SetObjResult(interp, resultPtr); } else { /* * Return the list of available options. */ resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FirstHashEntry(&iclsPtr->delegatedOptions, &place); while (hPtr) { idoptPtr = (ItclDelegatedOption*)Tcl_GetHashValue(hPtr); objPtr = idoptPtr->namePtr; Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); hPtr = Tcl_NextHashEntry(&place); } } Itcl_DeleteHierIter(&hier); Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoDelegatedMethodCmd() * * Returns information regarding class options. * Handles the following syntax: * * info delegated method ?methodName? ?-name? * ?-component? ?-as? ?-using? ?-exceptions? * * If the ?optionName? is not specified, then a list of all known * data members is returned. Otherwise, the information for a * specific member is returned. Returns a status TCL_OK/TCL_ERROR * to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoDelegatedMethodCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_HashSearch place; Tcl_Obj *resultPtr; Tcl_Obj *objPtr; Tcl_Obj *cmdNamePtr; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; ItclDelegatedFunction *idmPtr; ItclHierIter hier; ItclClass *iclsPtr; char *cmdName; int i; int result; static const char *options[] = { "-as", "-component", "-exceptions", "-name", "-using", NULL }; enum BOptIdx { BOptAsIdx, BOptComponentIdx, BOptExceptionsIdx, BOptNameIdx, BOptUsingIdx } *ioptlist, ioptlistStorage[5]; static enum BOptIdx DefInfoOption[5] = { BOptNameIdx, BOptComponentIdx, BOptAsIdx, BOptUsingIdx, BOptExceptionsIdx }; ItclShowArgs(1, "Itcl_BiInfoDelegatedMethodCmd", objc, objv); cmdName = NULL; objPtr = NULL; resultPtr = NULL; contextIclsPtr = NULL; /* * If this command is not invoked within a class namespace, * signal an error. */ if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info delegated method ... }", TCL_INDEX_NONE)); return TCL_ERROR; } if (contextIoPtr != NULL) { contextIclsPtr = contextIoPtr->iclsPtr; } /* * Process args: * ?methodName? ?-name? ?-using? * ?-as? ?-component? ?-exceptions? */ objv++; /* skip over command name */ objc--; if (objc > 0) { cmdName = Tcl_GetString(*objv); objc--; objv++; } /* * Return info for a specific option. */ if (cmdName) { cmdNamePtr = Tcl_NewStringObj(cmdName, TCL_INDEX_NONE); if (contextIoPtr != NULL) { hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedFunctions, (char *)cmdNamePtr); } else { hPtr = Tcl_FindHashEntry(&contextIclsPtr->delegatedFunctions, (char *)cmdNamePtr); } Tcl_DecrRefCount(cmdNamePtr); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a delegated method in object \"", Tcl_GetString(contextIoPtr->namePtr), "\"", NULL); return TCL_ERROR; } idmPtr = (ItclDelegatedFunction*)Tcl_GetHashValue(hPtr); if (!(idmPtr->flags & ITCL_METHOD)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a delegated method in object \"", Tcl_GetString(contextIoPtr->namePtr), "\"", NULL); return TCL_ERROR; } /* * By default, return everything. */ if (objc == 0) { ioptlist = DefInfoOption; objc = 5; } else { /* * Otherwise, scan through all remaining flags and * figure out what to return. */ ioptlist = &ioptlistStorage[0]; for (i=0 ; i < objc; i++) { result = Tcl_GetIndexFromObjStruct(interp, objv[i], options, sizeof(char *), "option", 0, (int*)(&ioptlist[i])); if (result != TCL_OK) { return TCL_ERROR; } } } if (objc > 1) { resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { switch (ioptlist[i]) { case BOptAsIdx: if (idmPtr->asPtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(idmPtr->asPtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptExceptionsIdx: { Tcl_Obj *entryObj; objPtr = Tcl_NewListObj(0, NULL); FOREACH_HASH_VALUE(entryObj, &idmPtr->exceptions) { Tcl_ListObjAppendElement(interp, objPtr, entryObj); } } break; case BOptUsingIdx: if (idmPtr->usingPtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(idmPtr->usingPtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptComponentIdx: if (idmPtr->icPtr != NULL) { objPtr = Tcl_NewStringObj( Tcl_GetString(idmPtr->icPtr->namePtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptNameIdx: objPtr = Tcl_NewStringObj( Tcl_GetString(idmPtr->namePtr), TCL_INDEX_NONE); break; } if (objc == 1) { resultPtr = objPtr; } else { Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } Tcl_SetObjResult(interp, resultPtr); } else { /* * Return the list of available options. */ resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FirstHashEntry(&iclsPtr->delegatedFunctions, &place); while (hPtr) { idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); if (idmPtr->flags & ITCL_METHOD) { objPtr = idmPtr->namePtr; Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } hPtr = Tcl_NextHashEntry(&place); } } Itcl_DeleteHierIter(&hier); Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiInfoDelegatedTypeMethodCmd() * * Returns information regarding class options. * Handles the following syntax: * * info delegated typemethod ?methodName? ?-name? * ?-component? ?-as? ?-exceptions? * * If the ?optionName? is not specified, then a list of all known * data members is returned. Otherwise, the information for a * specific member is returned. Returns a status TCL_OK/TCL_ERROR * to indicate success/failure. * ------------------------------------------------------------------------ */ static int Itcl_BiInfoDelegatedTypeMethodCmd( TCL_UNUSED(void *), /* ItclObjectInfo Ptr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_HashSearch place; Tcl_Obj *resultPtr; Tcl_Obj *objPtr; Tcl_Obj *cmdNamePtr; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; ItclDelegatedFunction *idmPtr; ItclHierIter hier; ItclClass *iclsPtr; char *cmdName; int i; int result; static const char *options[] = { "-as", "-component", "-exceptions", "-name", "-using", NULL }; enum BOptIdx { BOptAsIdx, BOptComponentIdx, BOptExceptionsIdx, BOptNameIdx, BOptUsingIdx } *ioptlist, ioptlistStorage[5]; static enum BOptIdx DefInfoOption[5] = { BOptNameIdx, BOptComponentIdx, BOptAsIdx, BOptUsingIdx, BOptExceptionsIdx }; ItclShowArgs(1, "Itcl_BiInfoDelegatedTypeMethodCmd", objc, objv); cmdName = NULL; objPtr = NULL; resultPtr = NULL; contextIclsPtr = NULL; /* * If this command is not invoked within a class namespace, * signal an error. */ if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\nget info like this instead: " "\n namespace eval className { info delegated type method ... }", TCL_INDEX_NONE)); return TCL_ERROR; } if (contextIoPtr != NULL) { contextIclsPtr = contextIoPtr->iclsPtr; } /* * Process args: * ?methodName? ?-name? ?-using? * ?-as? ?-component? ?-exceptions? */ objv++; /* skip over command name */ objc--; if (objc > 0) { cmdName = Tcl_GetString(*objv); objc--; objv++; } /* * Return info for a specific option. */ if (cmdName) { cmdNamePtr = Tcl_NewStringObj(cmdName, TCL_INDEX_NONE); if (contextIoPtr != NULL) { hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedFunctions, (char *)cmdNamePtr); } else { hPtr = Tcl_FindHashEntry(&contextIclsPtr->delegatedFunctions, (char *)cmdNamePtr); } Tcl_DecrRefCount(cmdNamePtr); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a delegated typemethod in ", contextIoPtr ? "object \"" : "class \"", contextIoPtr ? Tcl_GetString(contextIoPtr->namePtr) : Tcl_GetString(contextIclsPtr->namePtr), "\"", NULL); return TCL_ERROR; } idmPtr = (ItclDelegatedFunction*)Tcl_GetHashValue(hPtr); if (!(idmPtr->flags & ITCL_TYPE_METHOD)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", cmdName, "\" isn't a delegated typemethod in ", contextIoPtr ? "object \"" : "class \"", contextIoPtr ? Tcl_GetString(contextIoPtr->namePtr) : Tcl_GetString(contextIclsPtr->namePtr), "\"", NULL); return TCL_ERROR; } /* * By default, return everything. */ if (objc == 0) { ioptlist = DefInfoOption; objc = 5; } else { /* * Otherwise, scan through all remaining flags and * figure out what to return. */ ioptlist = &ioptlistStorage[0]; for (i=0 ; i < objc; i++) { result = Tcl_GetIndexFromObjStruct(interp, objv[i], options, sizeof(char *), "option", 0, (int*)(&ioptlist[i])); if (result != TCL_OK) { return TCL_ERROR; } } } if (objc > 1) { resultPtr = Tcl_NewListObj(0, NULL); } for (i=0 ; i < objc; i++) { switch (ioptlist[i]) { case BOptAsIdx: if (idmPtr->asPtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(idmPtr->asPtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptExceptionsIdx: { Tcl_Obj *entryObj; objPtr = Tcl_NewListObj(0, NULL); FOREACH_HASH_VALUE(entryObj, &idmPtr->exceptions) { Tcl_ListObjAppendElement(interp, objPtr, entryObj); } } break; case BOptUsingIdx: if (idmPtr->usingPtr) { objPtr = Tcl_NewStringObj( Tcl_GetString(idmPtr->usingPtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptComponentIdx: if (idmPtr->icPtr != NULL) { objPtr = Tcl_NewStringObj( Tcl_GetString(idmPtr->icPtr->namePtr), TCL_INDEX_NONE); } else { objPtr = Tcl_NewStringObj("", TCL_INDEX_NONE); } break; case BOptNameIdx: objPtr = Tcl_NewStringObj( Tcl_GetString(idmPtr->namePtr), TCL_INDEX_NONE); break; } if (objc == 1) { resultPtr = objPtr; } else { Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } Tcl_SetObjResult(interp, resultPtr); } else { /* * Return the list of available options. */ resultPtr = Tcl_NewListObj(0, NULL); Itcl_InitHierIter(&hier, contextIclsPtr); while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FirstHashEntry(&iclsPtr->delegatedFunctions, &place); while (hPtr) { idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); if (idmPtr->flags & ITCL_TYPE_METHOD) { objPtr = idmPtr->namePtr; Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } hPtr = Tcl_NextHashEntry(&place); } } Itcl_DeleteHierIter(&hier); Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; }