/* * ------------------------------------------------------------------------ * 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 char initHullCmdsScript[] = "namespace eval ::itcl {\n" " proc _find_hull_init {} {\n" " global env tcl_library\n" " variable library\n" " variable patchLevel\n" " rename _find_hull_init {}\n" " if {[info exists library]} {\n" " lappend dirs $library\n" " } else {\n" " set dirs {}\n" " if {[info exists env(ITCL_LIBRARY)]} {\n" " lappend dirs $env(ITCL_LIBRARY)\n" " }\n" " lappend dirs [file join [file dirname $tcl_library] itcl$patchLevel]\n" " set bindir [file dirname [info nameofexecutable]]\n" " lappend dirs [file join . library]\n" " lappend dirs [file join $bindir .. lib itcl$patchLevel]\n" " lappend dirs [file join $bindir .. library]\n" " lappend dirs [file join $bindir .. .. library]\n" " lappend dirs [file join $bindir .. .. itcl library]\n" " lappend dirs [file join $bindir .. .. .. itcl library]\n" " lappend dirs [file join $bindir .. .. itcl-ng itcl library]\n" " # On MacOSX, check the directories in the tcl_pkgPath\n" " if {[string equal $::tcl_platform(platform) \"unix\"] && " " [string equal $::tcl_platform(os) \"Darwin\"]} {\n" " foreach d $::tcl_pkgPath {\n" " lappend dirs [file join $d itcl$patchLevel]\n" " }\n" " }\n" " # On *nix, check the directories in the tcl_pkgPath\n" " if {[string equal $::tcl_platform(platform) \"unix\"]} {\n" " foreach d $::tcl_pkgPath {\n" " lappend dirs $d\n" " lappend dirs [file join $d itcl$patchLevel]\n" " }\n" " }\n" " }\n" " foreach i $dirs {\n" " set library $i\n" " set itclfile [file join $i itclHullCmds.tcl]\n" " if {![catch {uplevel #0 [list source -encoding utf-8 $itclfile]} msg]} {\n" " return\n" " }\n" "puts stderr \"MSG!$msg!\"\n" " }\n" " set msg \"Can't find a usable itclHullCmds.tcl in the following directories:\n\"\n" " append msg \" $dirs\n\"\n" " append msg \"This probably means that Itcl/Tcl weren't installed properly.\n\"\n" " append msg \"If you know where the Itcl library directory was installed,\n\"\n" " append msg \"you can set the environment variable ITCL_LIBRARY to point\n\"\n" " append msg \"to the library directory.\n\"\n" " error $msg\n" " }\n" " _find_hull_init\n" "}"; static Tcl_ObjCmdProc Itcl_BiDestroyCmd; static Tcl_ObjCmdProc ItclExtendedConfigure; static Tcl_ObjCmdProc ItclExtendedCget; static Tcl_ObjCmdProc ItclExtendedSetGet; static Tcl_ObjCmdProc Itcl_BiCreateHullCmd; static Tcl_ObjCmdProc Itcl_BiSetupComponentCmd; static Tcl_ObjCmdProc Itcl_BiKeepComponentOptionCmd; static Tcl_ObjCmdProc Itcl_BiIgnoreComponentOptionCmd; static Tcl_ObjCmdProc Itcl_BiInitOptionsCmd; /* * FORWARD DECLARATIONS */ static Tcl_Obj* ItclReportPublicOpt(Tcl_Interp *interp, ItclVariable *ivPtr, ItclObject *contextIoPtr); static Tcl_ObjCmdProc ItclBiClassUnknownCmd; /* * Standard list of built-in methods for all objects. */ typedef struct BiMethod { const char* name; /* method name */ const char* usage; /* string describing usage */ const char* registration;/* registration name for C proc */ Tcl_ObjCmdProc *proc; /* implementation C proc */ int flags; /* flag for which type of class to be used */ } BiMethod; static const BiMethod BiMethodList[] = { { "callinstance", "", "@itcl-builtin-callinstance", Itcl_BiCallInstanceCmd, ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR }, { "getinstancevar", "", "@itcl-builtin-getinstancevar", Itcl_BiGetInstanceVarCmd, ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR }, { "cget", "-option", "@itcl-builtin-cget", Itcl_BiCgetCmd, ITCL_CLASS|ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR }, { "configure", "?-option? ?value -option value...?", "@itcl-builtin-configure", Itcl_BiConfigureCmd, ITCL_CLASS|ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR }, {"createhull", "widgetType widgetPath ?-class className? ?optionName value ...?", "@itcl-builtin-createhull", Itcl_BiCreateHullCmd, ITCL_ECLASS }, { "destroy", "", "@itcl-builtin-destroy", Itcl_BiDestroyCmd, ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR }, { "installcomponent", " using ?-option value...?", "@itcl-builtin-installcomponent", Itcl_BiInstallComponentCmd, ITCL_WIDGET }, { "itcl_hull", "", "@itcl-builtin-itcl_hull", Itcl_BiItclHullCmd, ITCL_WIDGET|ITCL_WIDGETADAPTOR }, { "isa", "className", "@itcl-builtin-isa", Itcl_BiIsaCmd, ITCL_CLASS|ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET }, {"itcl_initoptions", "?optionName value ...?", "@itcl-builtin-initoptions", Itcl_BiInitOptionsCmd, ITCL_ECLASS }, { "mymethod", "", "@itcl-builtin-mymethod", Itcl_BiMyMethodCmd, ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR }, { "myvar", "", "@itcl-builtin-myvar", Itcl_BiMyVarCmd, ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR }, { "myproc", "", "@itcl-builtin-myproc", Itcl_BiMyProcCmd, ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR }, { "mytypemethod", "", "@itcl-builtin-mytypemethod", Itcl_BiMyTypeMethodCmd, ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR }, { "mytypevar", "", "@itcl-builtin-mytypevar", Itcl_BiMyTypeVarCmd, ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR }, { "setget", "varName ?value?", "@itcl-builtin-setget", ItclExtendedSetGet, ITCL_ECLASS }, { "unknown", "", "@itcl-builtin-classunknown", ItclBiClassUnknownCmd, ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR }, {"keepcomponentoption", "componentName optionName ?optionName ...?", "@itcl-builtin-keepcomponentoption", Itcl_BiKeepComponentOptionCmd, ITCL_ECLASS }, {"ignorecomponentoption", "componentName optionName ?optionName ...?", "@itcl-builtin-ignorecomponentoption", Itcl_BiIgnoreComponentOptionCmd, ITCL_ECLASS }, /* the next 3 are defined in library/itclHullCmds.tcl */ {"addoptioncomponent", "componentName optionName ?optionName ...?", "@itcl-builtin-addoptioncomponent", NULL, ITCL_ECLASS }, {"ignoreoptioncomponent", "componentName optionName ?optionName ...?", "@itcl-builtin-ignoreoptioncomponent", NULL, ITCL_ECLASS }, {"renameoptioncomponent", "componentName optionName ?optionName ...?", "@itcl-builtin-renameoptioncomponent", NULL, ITCL_ECLASS }, {"setupcomponent", "componentName using widgetType widgetPath ?optionName value ...?", "@itcl-builtin-setupcomponent", Itcl_BiSetupComponentCmd, ITCL_ECLASS }, }; static int BiMethodListLen = sizeof(BiMethodList)/sizeof(BiMethod); /* * ------------------------------------------------------------------------ * ItclRestoreInfoVars() * * Delete callback to restore original "info" ensemble (revert inject of Itcl) * * ------------------------------------------------------------------------ */ void ItclRestoreInfoVars( void *clientData) { ItclObjectInfo *infoPtr = (ItclObjectInfo *)clientData; Tcl_Interp *interp = infoPtr->interp; Tcl_Command cmd; Tcl_Obj *mapDict; cmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); if (cmd == NULL || !Tcl_IsEnsemble(cmd)) { goto done; } Tcl_GetEnsembleMappingDict(NULL, cmd, &mapDict); if (mapDict == NULL) { goto done; } if (infoPtr->infoVarsPtr == NULL || infoPtr->infoVars4Ptr == NULL) { /* Safety */ goto done; } Tcl_DictObjPut(NULL, mapDict, infoPtr->infoVars4Ptr, infoPtr->infoVarsPtr); Tcl_SetEnsembleMappingDict(interp, cmd, mapDict); done: if (infoPtr->infoVarsPtr) { Tcl_DecrRefCount(infoPtr->infoVarsPtr); infoPtr->infoVarsPtr = NULL; } if (infoPtr->infoVars4Ptr) { Tcl_DecrRefCount(infoPtr->infoVars4Ptr); infoPtr->infoVars4Ptr = NULL; } } /* * ------------------------------------------------------------------------ * Itcl_BiInit() * * Creates a namespace full of built-in methods/procs for [incr Tcl] * classes. This includes things like the "isa" method and "info" * for querying class info. Usually invoked by Itcl_Init() when * [incr Tcl] is first installed into an interpreter. * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ int Itcl_BiInit( Tcl_Interp *interp, /* current interpreter */ ItclObjectInfo *infoPtr) { Tcl_Namespace *itclBiNs; Tcl_DString buffer; Tcl_Obj *mapDict; Tcl_Command infoCmd; int result; int i; /* * "::itcl::builtin" commands. * These commands are imported into each class * just before the class definition is parsed. */ Tcl_DStringInit(&buffer); for (i=0; i < BiMethodListLen; i++) { Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, "::itcl::builtin::", TCL_INDEX_NONE); Tcl_DStringAppend(&buffer, BiMethodList[i].name, TCL_INDEX_NONE); Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), BiMethodList[i].proc, infoPtr, NULL); } Tcl_DStringFree(&buffer); Tcl_CreateObjCommand(interp, "::itcl::builtin::chain", Itcl_BiChainCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::itcl::builtin::classunknown", ItclBiClassUnknownCmd, infoPtr, NULL); ItclInfoInit(interp, infoPtr); /* * Export all commands in the built-in namespace so we can * import them later on. */ itclBiNs = Tcl_FindNamespace(interp, "::itcl::builtin", NULL, TCL_LEAVE_ERR_MSG); if ((itclBiNs == NULL) || Tcl_Export(interp, itclBiNs, "[a-z]*", /* resetListFirst */ 1) != TCL_OK) { return TCL_ERROR; } /* * Install into the [info] ensemble. */ infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); if (infoCmd != NULL && Tcl_IsEnsemble(infoCmd)) { Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); if (mapDict != NULL) { infoPtr->infoVars4Ptr = Tcl_NewStringObj("vars", TCL_INDEX_NONE); Tcl_IncrRefCount(infoPtr->infoVars4Ptr); result = Tcl_DictObjGet(NULL, mapDict, infoPtr->infoVars4Ptr, &infoPtr->infoVarsPtr); if (result == TCL_OK && infoPtr->infoVarsPtr) { Tcl_IncrRefCount(infoPtr->infoVarsPtr); Tcl_DictObjPut(NULL, mapDict, infoPtr->infoVars4Ptr, Tcl_NewStringObj("::itcl::builtin::Info::vars", TCL_INDEX_NONE)); Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); /* * Note that ItclRestoreInfoVars is called in callback * if built-in Itcl command info::vars or the ensemble get * deleted (see ItclInfoInit registering that). */ } else { Tcl_DecrRefCount(infoPtr->infoVars4Ptr); infoPtr->infoVars4Ptr = NULL; } } } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_InstallBiMethods() * * Invoked when a class is first created, just after the class * definition has been parsed, to add definitions for built-in * methods to the class. If a method already exists in the class * with the same name as the built-in, then the built-in is skipped. * Otherwise, a method definition for the built-in method is added. * * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter) if anything goes wrong. * ------------------------------------------------------------------------ */ int Itcl_InstallBiMethods( Tcl_Interp *interp, /* current interpreter */ ItclClass *iclsPtr) /* class definition to be updated */ { int result = TCL_OK; int i; ItclHierIter hier; ItclClass *superPtr; /* * Scan through all of the built-in methods and see if * that method already exists in the class. If not, add * it in. * * TRICKY NOTE: The virtual tables haven't been built yet, * so look for existing methods the hard way--by scanning * through all classes. */ Tcl_Obj *objPtr = Tcl_NewStringObj("", 0); for (i=0; i < BiMethodListLen; i++) { Tcl_HashEntry *hPtr = NULL; Itcl_InitHierIter(&hier, iclsPtr); Tcl_SetStringObj(objPtr, BiMethodList[i].name, TCL_INDEX_NONE); superPtr = Itcl_AdvanceHierIter(&hier); while (superPtr) { hPtr = Tcl_FindHashEntry(&superPtr->functions, (char *)objPtr); if (hPtr) { break; } superPtr = Itcl_AdvanceHierIter(&hier); } Itcl_DeleteHierIter(&hier); if (!hPtr) { if (iclsPtr->flags & BiMethodList[i].flags) { result = Itcl_CreateMethod(interp, iclsPtr, Tcl_NewStringObj(BiMethodList[i].name, TCL_INDEX_NONE), BiMethodList[i].usage, BiMethodList[i].registration); if (result != TCL_OK) { break; } } } } /* * Every Itcl class gets an info method installed so that each has * a proper context for the subcommands to do their context senstive * work. */ if (result == TCL_OK && (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR))) { result = Itcl_CreateMethod(interp, iclsPtr, Tcl_NewStringObj("info", TCL_INDEX_NONE), NULL, "@itcl-builtin-info"); } Tcl_DecrRefCount(objPtr); return result; } /* * ------------------------------------------------------------------------ * Itcl_BiIsaCmd() * * Invoked whenever the user issues the "isa" method for an object. * Handles the following syntax: * * isa * * Checks to see if the object has the given anywhere * in its heritage. Returns 1 if so, and 0 otherwise. * ------------------------------------------------------------------------ */ int Itcl_BiIsaCmd( TCL_UNUSED(void *), /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclClass *iclsPtr; const char *token; ItclClass *contextIclsPtr; ItclObject *contextIoPtr; /* * Make sure that this command is being invoked in the proper * context. */ contextIclsPtr = NULL; if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) { return TCL_ERROR; } if (contextIoPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "improper usage: should be \"object isa className\"", NULL); return TCL_ERROR; } if (objc != 2) { token = Tcl_GetString(objv[0]); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"object ", token, " className\"", NULL); return TCL_ERROR; } /* * Look for the requested class. If it is not found, then * try to autoload it. If it absolutely cannot be found, * signal an error. */ token = Tcl_GetString(objv[1]); iclsPtr = Itcl_FindClass(interp, token, /* autoload */ 1); if (iclsPtr == NULL) { return TCL_ERROR; } if (Itcl_ObjectIsa(contextIoPtr, iclsPtr)) { Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 1); } else { Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 0); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiConfigureCmd() * * Invoked whenever the user issues the "configure" method for an object. * Handles the following syntax: * * configure ?-