3850 lines
123 KiB
C
3850 lines
123 KiB
C
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* 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 $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",
|
|||
|
|
"<instancename>",
|
|||
|
|
"@itcl-builtin-callinstance",
|
|||
|
|
Itcl_BiCallInstanceCmd,
|
|||
|
|
ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR
|
|||
|
|
},
|
|||
|
|
{ "getinstancevar",
|
|||
|
|
"<instancename>",
|
|||
|
|
"@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",
|
|||
|
|
"<componentName> using <classname> <winpath> ?-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(
|
|||
|
|
ClientData 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::", -1);
|
|||
|
|
Tcl_DStringAppend(&buffer, BiMethodList[i].name, -1);
|
|||
|
|
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", -1);
|
|||
|
|
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", -1));
|
|||
|
|
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, -1);
|
|||
|
|
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, -1),
|
|||
|
|
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", -1), 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:
|
|||
|
|
*
|
|||
|
|
* <objName> isa <className>
|
|||
|
|
*
|
|||
|
|
* Checks to see if the object has the given <className> anywhere
|
|||
|
|
* in its heritage. Returns 1 if so, and 0 otherwise.
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
int
|
|||
|
|
Itcl_BiIsaCmd(
|
|||
|
|
void *dummy, /* 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;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* 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:
|
|||
|
|
*
|
|||
|
|
* <objName> configure ?-<option>? ?<value> -<option> <value>...?
|
|||
|
|
*
|
|||
|
|
* Allows access to public variables as if they were configuration
|
|||
|
|
* options. With no arguments, this command returns the current
|
|||
|
|
* list of public variable options. If -<option> is specified,
|
|||
|
|
* this returns the information for just one option:
|
|||
|
|
*
|
|||
|
|
* -<optionName> <initVal> <currentVal>
|
|||
|
|
*
|
|||
|
|
* Otherwise, the list of arguments is parsed, and values are
|
|||
|
|
* assigned to the various public variable options. When each
|
|||
|
|
* option changes, a big of "config" code associated with the option
|
|||
|
|
* is executed, to bring the object up to date.
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
int
|
|||
|
|
Itcl_BiConfigureCmd(
|
|||
|
|
void *dummy, /* class definition */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
|
|||
|
|
Tcl_Obj *resultPtr;
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
Tcl_DString buffer;
|
|||
|
|
Tcl_DString buffer2;
|
|||
|
|
Tcl_HashSearch place;
|
|||
|
|
Tcl_HashEntry *hPtr;
|
|||
|
|
Tcl_Namespace *saveNsPtr;
|
|||
|
|
Tcl_Obj * const *unparsedObjv;
|
|||
|
|
ItclClass *iclsPtr;
|
|||
|
|
ItclVariable *ivPtr;
|
|||
|
|
ItclVarLookup *vlookup;
|
|||
|
|
ItclMemberCode *mcode;
|
|||
|
|
ItclHierIter hier;
|
|||
|
|
ItclObjectInfo *infoPtr;
|
|||
|
|
const char *lastval;
|
|||
|
|
const char *token;
|
|||
|
|
char *varName;
|
|||
|
|
int i;
|
|||
|
|
int unparsedObjc;
|
|||
|
|
int result;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
ItclShowArgs(1, "Itcl_BiConfigureCmd", objc, objv);
|
|||
|
|
vlookup = NULL;
|
|||
|
|
token = NULL;
|
|||
|
|
hPtr = NULL;
|
|||
|
|
unparsedObjc = objc;
|
|||
|
|
unparsedObjv = objv;
|
|||
|
|
Tcl_DStringInit(&buffer);
|
|||
|
|
Tcl_DStringInit(&buffer2);
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* 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 configure ?-option? ?value -option value...?\"",
|
|||
|
|
NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* BE CAREFUL: work in the virtual scope!
|
|||
|
|
*/
|
|||
|
|
if (contextIoPtr != NULL) {
|
|||
|
|
contextIclsPtr = contextIoPtr->iclsPtr;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
infoPtr = contextIclsPtr->infoPtr;
|
|||
|
|
if (!(contextIclsPtr->flags & ITCL_CLASS)) {
|
|||
|
|
/* first check if it is an option */
|
|||
|
|
if (objc > 1) {
|
|||
|
|
hPtr = Tcl_FindHashEntry(&contextIclsPtr->options,
|
|||
|
|
(char *) objv[1]);
|
|||
|
|
}
|
|||
|
|
result = ItclExtendedConfigure(contextIclsPtr, interp, objc, objv);
|
|||
|
|
if (result != TCL_CONTINUE) {
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
if (infoPtr->unparsedObjc > 0) {
|
|||
|
|
unparsedObjc = infoPtr->unparsedObjc;
|
|||
|
|
unparsedObjv = infoPtr->unparsedObjv;
|
|||
|
|
} else {
|
|||
|
|
unparsedObjc = objc;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
/*
|
|||
|
|
* HANDLE: configure
|
|||
|
|
*/
|
|||
|
|
if (unparsedObjc == 1) {
|
|||
|
|
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->protection == ITCL_PUBLIC) {
|
|||
|
|
objPtr = ItclReportPublicOpt(interp, ivPtr, contextIoPtr);
|
|||
|
|
|
|||
|
|
Tcl_ListObjAppendElement(NULL, resultPtr,
|
|||
|
|
objPtr);
|
|||
|
|
}
|
|||
|
|
hPtr = Tcl_NextHashEntry(&place);
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
Itcl_DeleteHierIter(&hier);
|
|||
|
|
|
|||
|
|
Tcl_SetObjResult(interp, resultPtr);
|
|||
|
|
return TCL_OK;
|
|||
|
|
} else {
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* HANDLE: configure -option
|
|||
|
|
*/
|
|||
|
|
if (unparsedObjc == 2) {
|
|||
|
|
token = Tcl_GetString(unparsedObjv[1]);
|
|||
|
|
if (*token != '-') {
|
|||
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
|||
|
|
"improper usage: should be ",
|
|||
|
|
"\"object configure ?-option? ?value -option value...?\"",
|
|||
|
|
NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
vlookup = NULL;
|
|||
|
|
hPtr = ItclResolveVarEntry(contextIclsPtr, token+1);
|
|||
|
|
if (hPtr) {
|
|||
|
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
|
|||
|
|
|
|||
|
|
if (vlookup->ivPtr->protection != ITCL_PUBLIC) {
|
|||
|
|
vlookup = NULL;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
if (!vlookup) {
|
|||
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
|||
|
|
"unknown option \"", token, "\"",
|
|||
|
|
NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
resultPtr = ItclReportPublicOpt(interp,
|
|||
|
|
vlookup->ivPtr, contextIoPtr);
|
|||
|
|
Tcl_SetObjResult(interp, resultPtr);
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* HANDLE: configure -option value -option value...
|
|||
|
|
*
|
|||
|
|
* Be careful to work in the virtual scope. If this "configure"
|
|||
|
|
* method was defined in a base class, the current namespace
|
|||
|
|
* (from Itcl_ExecMethod()) will be that base class. Activate
|
|||
|
|
* the derived class namespace here, so that instance variables
|
|||
|
|
* are accessed properly.
|
|||
|
|
*/
|
|||
|
|
result = TCL_OK;
|
|||
|
|
|
|||
|
|
for (i=1; i < unparsedObjc; i+=2) {
|
|||
|
|
if (i+1 >= unparsedObjc) {
|
|||
|
|
Tcl_AppendResult(interp, "need option value pair", NULL);
|
|||
|
|
result = TCL_ERROR;
|
|||
|
|
goto configureDone;
|
|||
|
|
}
|
|||
|
|
vlookup = NULL;
|
|||
|
|
token = Tcl_GetString(unparsedObjv[i]);
|
|||
|
|
if (*token == '-') {
|
|||
|
|
hPtr = ItclResolveVarEntry(contextIclsPtr, token+1);
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
hPtr = ItclResolveVarEntry(contextIclsPtr, token);
|
|||
|
|
}
|
|||
|
|
if (hPtr) {
|
|||
|
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
if (!vlookup || (vlookup->ivPtr->protection != ITCL_PUBLIC)) {
|
|||
|
|
Tcl_AppendResult(interp, "unknown option \"", token, "\"",
|
|||
|
|
NULL);
|
|||
|
|
result = TCL_ERROR;
|
|||
|
|
goto configureDone;
|
|||
|
|
}
|
|||
|
|
if (i == unparsedObjc-1) {
|
|||
|
|
Tcl_AppendResult(interp, "value for \"", token, "\" missing",
|
|||
|
|
NULL);
|
|||
|
|
result = TCL_ERROR;
|
|||
|
|
goto configureDone;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
ivPtr = vlookup->ivPtr;
|
|||
|
|
Tcl_DStringSetLength(&buffer2, 0);
|
|||
|
|
if (!(ivPtr->flags & ITCL_COMMON)) {
|
|||
|
|
Tcl_DStringAppend(&buffer2,
|
|||
|
|
Tcl_GetString(contextIoPtr->varNsNamePtr), -1);
|
|||
|
|
}
|
|||
|
|
Tcl_DStringAppend(&buffer2,
|
|||
|
|
Tcl_GetString(ivPtr->iclsPtr->fullNamePtr), -1);
|
|||
|
|
Tcl_DStringAppend(&buffer2, "::", 2);
|
|||
|
|
Tcl_DStringAppend(&buffer2,
|
|||
|
|
Tcl_GetString(ivPtr->namePtr), -1);
|
|||
|
|
varName = Tcl_DStringValue(&buffer2);
|
|||
|
|
lastval = Tcl_GetVar2(interp, varName, NULL, 0);
|
|||
|
|
Tcl_DStringSetLength(&buffer, 0);
|
|||
|
|
Tcl_DStringAppend(&buffer, (lastval) ? lastval : "", -1);
|
|||
|
|
|
|||
|
|
token = Tcl_GetString(unparsedObjv[i+1]);
|
|||
|
|
if (Tcl_SetVar2(interp, varName, NULL, token,
|
|||
|
|
TCL_LEAVE_ERR_MSG) == NULL) {
|
|||
|
|
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
|
|||
|
|
"\n (error in configuration of public variable \"%s\")",
|
|||
|
|
Tcl_GetString(ivPtr->fullNamePtr)));
|
|||
|
|
result = TCL_ERROR;
|
|||
|
|
goto configureDone;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* If this variable has some "config" code, invoke it now.
|
|||
|
|
*
|
|||
|
|
* TRICKY NOTE: Be careful to evaluate the code one level
|
|||
|
|
* up in the call stack, so that it's executed in the
|
|||
|
|
* calling context, and not in the context that we've
|
|||
|
|
* set up for public variable access.
|
|||
|
|
*/
|
|||
|
|
mcode = ivPtr->codePtr;
|
|||
|
|
if (mcode && Itcl_IsMemberCodeImplemented(mcode)) {
|
|||
|
|
if (!ivPtr->iclsPtr->infoPtr->useOldResolvers) {
|
|||
|
|
Itcl_SetCallFrameResolver(interp, contextIoPtr->resolvePtr);
|
|||
|
|
}
|
|||
|
|
saveNsPtr = Tcl_GetCurrentNamespace(interp);
|
|||
|
|
Itcl_SetCallFrameNamespace(interp, ivPtr->iclsPtr->nsPtr);
|
|||
|
|
result = Tcl_EvalObjEx(interp, mcode->bodyPtr, 0);
|
|||
|
|
Itcl_SetCallFrameNamespace(interp, saveNsPtr);
|
|||
|
|
if (result == TCL_OK) {
|
|||
|
|
Tcl_ResetResult(interp);
|
|||
|
|
} else {
|
|||
|
|
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
|
|||
|
|
"\n (error in configuration of public variable \"%s\")",
|
|||
|
|
Tcl_GetString(ivPtr->fullNamePtr)));
|
|||
|
|
Tcl_SetVar2(interp, varName,NULL,
|
|||
|
|
Tcl_DStringValue(&buffer), 0);
|
|||
|
|
|
|||
|
|
goto configureDone;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
configureDone:
|
|||
|
|
if (infoPtr->unparsedObjc > 0) {
|
|||
|
|
while (infoPtr->unparsedObjc-- > 1) {
|
|||
|
|
Tcl_DecrRefCount(infoPtr->unparsedObjv[infoPtr->unparsedObjc]);
|
|||
|
|
}
|
|||
|
|
ckfree ((char *)infoPtr->unparsedObjv);
|
|||
|
|
infoPtr->unparsedObjv = NULL;
|
|||
|
|
infoPtr->unparsedObjc = 0;
|
|||
|
|
}
|
|||
|
|
Tcl_DStringFree(&buffer2);
|
|||
|
|
Tcl_DStringFree(&buffer);
|
|||
|
|
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiCgetCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked whenever the user issues the "cget" method for an object.
|
|||
|
|
* Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* <objName> cget -<option>
|
|||
|
|
*
|
|||
|
|
* Allows access to public variables as if they were configuration
|
|||
|
|
* options. Mimics the behavior of the usual "cget" method for
|
|||
|
|
* Tk widgets. Returns the current value of the public variable
|
|||
|
|
* with name <option>.
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
int
|
|||
|
|
Itcl_BiCgetCmd(
|
|||
|
|
void *dummy, /* class definition */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
|
|||
|
|
Tcl_HashEntry *hPtr;
|
|||
|
|
ItclVarLookup *vlookup;
|
|||
|
|
const char *name;
|
|||
|
|
const char *val;
|
|||
|
|
int result;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
ItclShowArgs(1,"Itcl_BiCgetCmd", objc, objv);
|
|||
|
|
/*
|
|||
|
|
* 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) || objc != 2) {
|
|||
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
|||
|
|
"improper usage: should be \"object cget -option\"",
|
|||
|
|
NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* BE CAREFUL: work in the virtual scope!
|
|||
|
|
*/
|
|||
|
|
if (contextIoPtr != NULL) {
|
|||
|
|
contextIclsPtr = contextIoPtr->iclsPtr;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
if (!(contextIclsPtr->flags & ITCL_CLASS)) {
|
|||
|
|
result = ItclExtendedCget(contextIclsPtr, interp, objc, objv);
|
|||
|
|
if (result != TCL_CONTINUE) {
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
name = Tcl_GetString(objv[1]);
|
|||
|
|
|
|||
|
|
vlookup = NULL;
|
|||
|
|
hPtr = ItclResolveVarEntry(contextIclsPtr, name+1);
|
|||
|
|
if (hPtr) {
|
|||
|
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
if ((vlookup == NULL) || (vlookup->ivPtr->protection != ITCL_PUBLIC)) {
|
|||
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
|||
|
|
"unknown option \"", name, "\"",
|
|||
|
|
NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
val = Itcl_GetInstanceVar(interp,
|
|||
|
|
Tcl_GetString(vlookup->ivPtr->namePtr),
|
|||
|
|
contextIoPtr, vlookup->ivPtr->iclsPtr);
|
|||
|
|
|
|||
|
|
if (val) {
|
|||
|
|
Tcl_SetObjResult(interp, Tcl_NewStringObj(val, -1));
|
|||
|
|
} else {
|
|||
|
|
Tcl_SetObjResult(interp, Tcl_NewStringObj("<undefined>", -1));
|
|||
|
|
}
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* ItclReportPublicOpt()
|
|||
|
|
*
|
|||
|
|
* Returns information about a public variable formatted as a
|
|||
|
|
* configuration option:
|
|||
|
|
*
|
|||
|
|
* -<varName> <initVal> <currentVal>
|
|||
|
|
*
|
|||
|
|
* Used by Itcl_BiConfigureCmd() to report configuration options.
|
|||
|
|
* Returns a Tcl_Obj containing the information.
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
static Tcl_Obj*
|
|||
|
|
ItclReportPublicOpt(
|
|||
|
|
Tcl_Interp *interp, /* interpreter containing the object */
|
|||
|
|
ItclVariable *ivPtr, /* public variable to be reported */
|
|||
|
|
ItclObject *contextIoPtr) /* object containing this variable */
|
|||
|
|
{
|
|||
|
|
const char *val;
|
|||
|
|
ItclClass *iclsPtr;
|
|||
|
|
Tcl_HashEntry *hPtr;
|
|||
|
|
ItclVarLookup *vlookup;
|
|||
|
|
Tcl_DString optName;
|
|||
|
|
Tcl_Obj *listPtr;
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
|
|||
|
|
listPtr = Tcl_NewListObj(0, NULL);
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Determine how the option name should be reported.
|
|||
|
|
* If the simple name can be used to find it in the virtual
|
|||
|
|
* data table, then use the simple name. Otherwise, this
|
|||
|
|
* is a shadowed variable; use the full name.
|
|||
|
|
*/
|
|||
|
|
Tcl_DStringInit(&optName);
|
|||
|
|
Tcl_DStringAppend(&optName, "-", -1);
|
|||
|
|
|
|||
|
|
iclsPtr = (ItclClass*)contextIoPtr->iclsPtr;
|
|||
|
|
hPtr = ItclResolveVarEntry(iclsPtr,
|
|||
|
|
Tcl_GetString(ivPtr->fullNamePtr));
|
|||
|
|
assert(hPtr != NULL);
|
|||
|
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
|
|||
|
|
Tcl_DStringAppend(&optName, vlookup->leastQualName, -1);
|
|||
|
|
|
|||
|
|
objPtr = Tcl_NewStringObj(Tcl_DStringValue(&optName), -1);
|
|||
|
|
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
|
|||
|
|
Tcl_DStringFree(&optName);
|
|||
|
|
|
|||
|
|
|
|||
|
|
if (ivPtr->init) {
|
|||
|
|
objPtr = ivPtr->init;
|
|||
|
|
} else {
|
|||
|
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
|||
|
|
}
|
|||
|
|
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
|
|||
|
|
|
|||
|
|
val = Itcl_GetInstanceVar(interp, Tcl_GetString(ivPtr->namePtr),
|
|||
|
|
contextIoPtr, ivPtr->iclsPtr);
|
|||
|
|
|
|||
|
|
if (val) {
|
|||
|
|
objPtr = Tcl_NewStringObj((const char *)val, -1);
|
|||
|
|
} else {
|
|||
|
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
|||
|
|
}
|
|||
|
|
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
|
|||
|
|
|
|||
|
|
return listPtr;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* ItclReportOption()
|
|||
|
|
*
|
|||
|
|
* Returns information about an option formatted as a
|
|||
|
|
* configuration option:
|
|||
|
|
*
|
|||
|
|
* <optionName> <initVal> <currentVal>
|
|||
|
|
*
|
|||
|
|
* Used by ItclExtendedConfigure() to report configuration options.
|
|||
|
|
* Returns a Tcl_Obj containing the information.
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
static Tcl_Obj*
|
|||
|
|
ItclReportOption(
|
|||
|
|
Tcl_Interp *interp, /* interpreter containing the object */
|
|||
|
|
ItclOption *ioptPtr, /* option to be reported */
|
|||
|
|
ItclObject *contextIoPtr) /* object containing this variable */
|
|||
|
|
{
|
|||
|
|
Tcl_Obj *listPtr;
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
ItclDelegatedOption *idoPtr;
|
|||
|
|
const char *val;
|
|||
|
|
|
|||
|
|
listPtr = Tcl_NewListObj(0, NULL);
|
|||
|
|
idoPtr = ioptPtr->iclsPtr->infoPtr->currIdoPtr;
|
|||
|
|
if (idoPtr != NULL) {
|
|||
|
|
Tcl_ListObjAppendElement(NULL, listPtr, idoPtr->namePtr);
|
|||
|
|
if (idoPtr->resourceNamePtr == NULL) {
|
|||
|
|
Tcl_ListObjAppendElement(NULL, listPtr,
|
|||
|
|
Tcl_NewStringObj("", -1));
|
|||
|
|
/* FIXME possible memory leak */
|
|||
|
|
} else {
|
|||
|
|
Tcl_ListObjAppendElement(NULL, listPtr,
|
|||
|
|
idoPtr->resourceNamePtr);
|
|||
|
|
}
|
|||
|
|
if (idoPtr->classNamePtr == NULL) {
|
|||
|
|
Tcl_ListObjAppendElement(NULL, listPtr,
|
|||
|
|
Tcl_NewStringObj("", -1));
|
|||
|
|
/* FIXME possible memory leak */
|
|||
|
|
} else {
|
|||
|
|
Tcl_ListObjAppendElement(NULL, listPtr,
|
|||
|
|
idoPtr->classNamePtr);
|
|||
|
|
}
|
|||
|
|
} else {
|
|||
|
|
Tcl_ListObjAppendElement(NULL, listPtr, ioptPtr->namePtr);
|
|||
|
|
Tcl_ListObjAppendElement(NULL, listPtr,
|
|||
|
|
ioptPtr->resourceNamePtr);
|
|||
|
|
Tcl_ListObjAppendElement(NULL, listPtr,
|
|||
|
|
ioptPtr->classNamePtr);
|
|||
|
|
}
|
|||
|
|
if (ioptPtr->defaultValuePtr) {
|
|||
|
|
objPtr = ioptPtr->defaultValuePtr;
|
|||
|
|
} else {
|
|||
|
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
|||
|
|
}
|
|||
|
|
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
|
|||
|
|
val = ItclGetInstanceVar(interp, "itcl_options",
|
|||
|
|
Tcl_GetString(ioptPtr->namePtr),
|
|||
|
|
contextIoPtr, ioptPtr->iclsPtr);
|
|||
|
|
if (val) {
|
|||
|
|
objPtr = Tcl_NewStringObj((const char *)val, -1);
|
|||
|
|
} else {
|
|||
|
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
|||
|
|
}
|
|||
|
|
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
|
|||
|
|
return listPtr;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiChainCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked to handle the "chain" command, to access the version of
|
|||
|
|
* a method or proc that exists in a base class. Handles the
|
|||
|
|
* following syntax:
|
|||
|
|
*
|
|||
|
|
* chain ?<arg> <arg>...?
|
|||
|
|
*
|
|||
|
|
* Looks up the inheritance hierarchy for another implementation
|
|||
|
|
* of the method/proc that is currently executing. If another
|
|||
|
|
* implementation is found, it is invoked with the specified
|
|||
|
|
* <arg> arguments. If it is not found, this command does nothing.
|
|||
|
|
* This allows a base class method to be called out in a generic way,
|
|||
|
|
* so the code will not have to change if the base class changes.
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
static int
|
|||
|
|
NRBiChainCmd(
|
|||
|
|
void *dummy, /* not used */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
int result = TCL_OK;
|
|||
|
|
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
|
|||
|
|
const char *cmd;
|
|||
|
|
char *cmd1;
|
|||
|
|
const char *head;
|
|||
|
|
ItclClass *iclsPtr;
|
|||
|
|
ItclHierIter hier;
|
|||
|
|
Tcl_HashEntry *hPtr;
|
|||
|
|
ItclMemberFunc *imPtr;
|
|||
|
|
Tcl_DString buffer;
|
|||
|
|
Tcl_Obj *cmdlinePtr;
|
|||
|
|
Tcl_Obj **newobjv;
|
|||
|
|
Tcl_Obj * const *cObjv;
|
|||
|
|
int cObjc;
|
|||
|
|
int idx;
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
ItclShowArgs(1, "Itcl_BiChainCmd", 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_ResetResult(interp);
|
|||
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
|||
|
|
"cannot chain functions outside of a class context",
|
|||
|
|
NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Try to get the command name from the current call frame.
|
|||
|
|
* If it cannot be determined, do nothing. Otherwise, trim
|
|||
|
|
* off any leading path names.
|
|||
|
|
*/
|
|||
|
|
cObjv = Itcl_GetCallVarFrameObjv(interp);
|
|||
|
|
if (cObjv == NULL) {
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
cObjc = Itcl_GetCallVarFrameObjc(interp);
|
|||
|
|
|
|||
|
|
if ((Itcl_GetCallFrameClientData(interp) == NULL) || (objc == 1)) {
|
|||
|
|
/* that has been a direct call, so no object in front !! */
|
|||
|
|
if (objc == 1 && cObjc >= 2) {
|
|||
|
|
idx = 1;
|
|||
|
|
} else {
|
|||
|
|
idx = 0;
|
|||
|
|
}
|
|||
|
|
} else {
|
|||
|
|
idx = 1;
|
|||
|
|
}
|
|||
|
|
cmd1 = (char *)ckalloc(strlen(Tcl_GetString(cObjv[idx]))+1);
|
|||
|
|
strcpy(cmd1, Tcl_GetString(cObjv[idx]));
|
|||
|
|
Itcl_ParseNamespPath(cmd1, &buffer, &head, &cmd);
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Look for the specified command in one of the base classes.
|
|||
|
|
* If we have an object context, then start from the most-specific
|
|||
|
|
* class and walk up the hierarchy to the current context. If
|
|||
|
|
* there is multiple inheritance, having the entire inheritance
|
|||
|
|
* hierarchy will allow us to jump over to another branch of
|
|||
|
|
* the inheritance tree.
|
|||
|
|
*
|
|||
|
|
* If there is no object context, just start with the current
|
|||
|
|
* class context.
|
|||
|
|
*/
|
|||
|
|
if (contextIoPtr != NULL) {
|
|||
|
|
Itcl_InitHierIter(&hier, contextIoPtr->iclsPtr);
|
|||
|
|
while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) {
|
|||
|
|
if (iclsPtr == contextIclsPtr) {
|
|||
|
|
break;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
} else {
|
|||
|
|
Itcl_InitHierIter(&hier, contextIclsPtr);
|
|||
|
|
Itcl_AdvanceHierIter(&hier); /* skip the current class */
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Now search up the class hierarchy for the next implementation.
|
|||
|
|
* If found, execute it. Otherwise, do nothing.
|
|||
|
|
*/
|
|||
|
|
objPtr = Tcl_NewStringObj(cmd, -1);
|
|||
|
|
ckfree(cmd1);
|
|||
|
|
Tcl_IncrRefCount(objPtr);
|
|||
|
|
while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) {
|
|||
|
|
hPtr = Tcl_FindHashEntry(&iclsPtr->functions, (char *)objPtr);
|
|||
|
|
if (hPtr) {
|
|||
|
|
int my_objc;
|
|||
|
|
imPtr = (ItclMemberFunc*)Tcl_GetHashValue(hPtr);
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* NOTE: Avoid the usual "virtual" behavior of
|
|||
|
|
* methods by passing the full name as
|
|||
|
|
* the command argument.
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
cmdlinePtr = Itcl_CreateArgs(interp,
|
|||
|
|
Tcl_GetString(imPtr->fullNamePtr), objc-1, objv+1);
|
|||
|
|
|
|||
|
|
(void) Tcl_ListObjGetElements(NULL, cmdlinePtr,
|
|||
|
|
&my_objc, &newobjv);
|
|||
|
|
|
|||
|
|
if (imPtr->flags & ITCL_CONSTRUCTOR) {
|
|||
|
|
contextIoPtr = imPtr->iclsPtr->infoPtr->currIoPtr;
|
|||
|
|
}
|
|||
|
|
ItclShowArgs(1, "___chain", objc-1, newobjv+1);
|
|||
|
|
result = Itcl_EvalMemberCode(interp, imPtr, contextIoPtr,
|
|||
|
|
my_objc-1, newobjv+1);
|
|||
|
|
Tcl_DecrRefCount(cmdlinePtr);
|
|||
|
|
break;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
Tcl_DecrRefCount(objPtr);
|
|||
|
|
|
|||
|
|
Tcl_DStringFree(&buffer);
|
|||
|
|
Itcl_DeleteHierIter(&hier);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
int
|
|||
|
|
Itcl_BiChainCmd(
|
|||
|
|
void *clientData,
|
|||
|
|
Tcl_Interp *interp,
|
|||
|
|
int objc,
|
|||
|
|
Tcl_Obj *const *objv)
|
|||
|
|
{
|
|||
|
|
return Tcl_NRCallObjProc(interp, NRBiChainCmd, clientData, objc, objv);
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
static int
|
|||
|
|
CallCreateObject(
|
|||
|
|
void *data[],
|
|||
|
|
Tcl_Interp *interp,
|
|||
|
|
int result)
|
|||
|
|
{
|
|||
|
|
Tcl_CallFrame frame;
|
|||
|
|
Tcl_Namespace *nsPtr;
|
|||
|
|
ItclClass *iclsPtr = (ItclClass *)data[0];
|
|||
|
|
int objc = PTR2INT(data[1]);
|
|||
|
|
Tcl_Obj *const *objv = (Tcl_Obj *const *)data[2];
|
|||
|
|
|
|||
|
|
if (result != TCL_OK) {
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
nsPtr = Itcl_GetUplevelNamespace(interp, 1);
|
|||
|
|
if (Itcl_PushCallFrame(interp, &frame, nsPtr,
|
|||
|
|
/*isProcCallFrame*/0) != TCL_OK) {
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
result = ItclClassCreateObject(iclsPtr->infoPtr, interp, objc, objv);
|
|||
|
|
Itcl_PopCallFrame(interp);
|
|||
|
|
Tcl_DecrRefCount(objv[2]);
|
|||
|
|
Tcl_DecrRefCount(objv[1]);
|
|||
|
|
Tcl_DecrRefCount(objv[0]);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
static int
|
|||
|
|
PrepareCreateObject(
|
|||
|
|
Tcl_Interp *interp,
|
|||
|
|
ItclClass *iclsPtr,
|
|||
|
|
int objc,
|
|||
|
|
Tcl_Obj * const *objv)
|
|||
|
|
{
|
|||
|
|
Tcl_HashEntry *hPtr;
|
|||
|
|
Tcl_Obj **newObjv;
|
|||
|
|
void *callbackPtr;
|
|||
|
|
const char *funcName;
|
|||
|
|
int result;
|
|||
|
|
int offset;
|
|||
|
|
|
|||
|
|
offset = 1;
|
|||
|
|
funcName = Tcl_GetString(objv[1]);
|
|||
|
|
if (strcmp(funcName, "itcl_hull") == 0) {
|
|||
|
|
hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objv[1]);
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
Tcl_AppendResult(interp, "INTERNAL ERROR ",
|
|||
|
|
"cannot find itcl_hull method", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
result = Itcl_ExecProc(Tcl_GetHashValue(hPtr), interp, objc, objv);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
if (strcmp(funcName, "create") == 0) {
|
|||
|
|
/* allow typeClassName create objectName */
|
|||
|
|
offset++;
|
|||
|
|
} else {
|
|||
|
|
/* allow typeClassName objectName */
|
|||
|
|
}
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc+3-offset));
|
|||
|
|
newObjv[0] = objv[0];
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
newObjv[1] = iclsPtr->namePtr;
|
|||
|
|
Tcl_IncrRefCount(newObjv[1]);
|
|||
|
|
newObjv[2] = Tcl_NewStringObj(iclsPtr->nsPtr->fullName, -1);
|
|||
|
|
Tcl_IncrRefCount(newObjv[2]);
|
|||
|
|
memcpy(newObjv+3, objv+offset, (objc-offset) * sizeof(Tcl_Obj *));
|
|||
|
|
callbackPtr = Itcl_GetCurrentCallbackPtr(interp);
|
|||
|
|
ItclShowArgs(1, "CREATE", objc+3-offset, newObjv);
|
|||
|
|
Tcl_NRAddCallback(interp, CallCreateObject, iclsPtr,
|
|||
|
|
INT2PTR(objc+3-offset), newObjv, NULL);
|
|||
|
|
result = Itcl_NRRunCallbacks(interp, callbackPtr);
|
|||
|
|
if (result != TCL_OK) {
|
|||
|
|
if (iclsPtr->infoPtr->currIoPtr != NULL) {
|
|||
|
|
/* we are in a constructor call */
|
|||
|
|
if (iclsPtr->infoPtr->currIoPtr->hadConstructorError == 0) {
|
|||
|
|
iclsPtr->infoPtr->currIoPtr->hadConstructorError = 1;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* ItclBiClassUnknownCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked to handle the "classunknown" command
|
|||
|
|
* this is called whenever an object is called with an unknown method/proc
|
|||
|
|
* following syntax:
|
|||
|
|
*
|
|||
|
|
* classunknown <object> <methodname> ?<arg> <arg>...?
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
static int
|
|||
|
|
ItclBiClassUnknownCmd(
|
|||
|
|
void *clientData, /* 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 **newObjv;
|
|||
|
|
Tcl_Obj **lObjv;
|
|||
|
|
Tcl_Obj *listPtr;
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
Tcl_Obj *resPtr;
|
|||
|
|
Tcl_DString buffer;
|
|||
|
|
ItclClass *iclsPtr;
|
|||
|
|
ItclObjectInfo *infoPtr;
|
|||
|
|
ItclComponent *icPtr;
|
|||
|
|
ItclDelegatedFunction *idmPtr;
|
|||
|
|
ItclDelegatedFunction *idmPtr2;
|
|||
|
|
ItclDelegatedFunction *starIdmPtr;
|
|||
|
|
const char *resStr;
|
|||
|
|
const char *val;
|
|||
|
|
const char *funcName;
|
|||
|
|
int lObjc;
|
|||
|
|
int result;
|
|||
|
|
int offset;
|
|||
|
|
int useComponent;
|
|||
|
|
int isItclHull;
|
|||
|
|
int isTypeMethod;
|
|||
|
|
int isStar;
|
|||
|
|
int isNew;
|
|||
|
|
int idx;
|
|||
|
|
|
|||
|
|
ItclShowArgs(1, "ItclBiClassUnknownCmd", objc, objv);
|
|||
|
|
listPtr = NULL;
|
|||
|
|
useComponent = 1;
|
|||
|
|
isStar = 0;
|
|||
|
|
isTypeMethod = 0;
|
|||
|
|
isItclHull = 0;
|
|||
|
|
starIdmPtr = NULL;
|
|||
|
|
infoPtr = (ItclObjectInfo *)clientData;
|
|||
|
|
hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses,
|
|||
|
|
(char *)Tcl_GetCurrentNamespace(interp));
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
Tcl_AppendResult(interp, "INTERNAL ERROR: ItclBiClassUnknownCmd ",
|
|||
|
|
"cannot find class\n", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr);
|
|||
|
|
funcName = Tcl_GetString(objv[1]);
|
|||
|
|
if (strcmp(funcName, "create") == 0) {
|
|||
|
|
/* check if we have a user method create. If not, it is the builtin
|
|||
|
|
* create method and we don't need to check for delegation
|
|||
|
|
* and components with ITCL_COMPONENT_INHERIT
|
|||
|
|
*/
|
|||
|
|
hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objv[1]);
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
return PrepareCreateObject(interp, iclsPtr, objc, objv);
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
if (strcmp(funcName, "itcl_hull") == 0) {
|
|||
|
|
isItclHull = 1;
|
|||
|
|
}
|
|||
|
|
if (!isItclHull) {
|
|||
|
|
FOREACH_HASH_VALUE(icPtr, &iclsPtr->components) {
|
|||
|
|
if (icPtr->flags & ITCL_COMPONENT_INHERIT) {
|
|||
|
|
val = Tcl_GetVar2(interp, Tcl_GetString(icPtr->namePtr),
|
|||
|
|
NULL, 0);
|
|||
|
|
if ((val != NULL) && (strlen(val) > 0)) {
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc));
|
|||
|
|
newObjv[0] = Tcl_NewStringObj(val, -1);
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
memcpy(newObjv+1, objv+1, sizeof(Tcl_Obj *) * (objc-1));
|
|||
|
|
ItclShowArgs(1, "UK EVAL1", objc, newObjv);
|
|||
|
|
result = Tcl_EvalObjv(interp, objc, newObjv, 0);
|
|||
|
|
Tcl_DecrRefCount(newObjv[0]);
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
/* from a class object only typemethods can be called directly
|
|||
|
|
* if delegated, so check for that, otherwise create an object
|
|||
|
|
* for ITCL_ECLASS we allow calling too
|
|||
|
|
*/
|
|||
|
|
hPtr = NULL;
|
|||
|
|
isTypeMethod = 0;
|
|||
|
|
FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) {
|
|||
|
|
if (strcmp(Tcl_GetString(idmPtr->namePtr), funcName) == 0) {
|
|||
|
|
if (idmPtr->flags & ITCL_TYPE_METHOD) {
|
|||
|
|
isTypeMethod = 1;
|
|||
|
|
}
|
|||
|
|
if (iclsPtr->flags & ITCL_ECLASS) {
|
|||
|
|
isTypeMethod = 1;
|
|||
|
|
}
|
|||
|
|
break;
|
|||
|
|
}
|
|||
|
|
if (strcmp(Tcl_GetString(idmPtr->namePtr), "*") == 0) {
|
|||
|
|
if (idmPtr->flags & ITCL_TYPE_METHOD) {
|
|||
|
|
isTypeMethod = 1;
|
|||
|
|
}
|
|||
|
|
starIdmPtr = idmPtr;
|
|||
|
|
break;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
idmPtr = NULL;
|
|||
|
|
if (isTypeMethod) {
|
|||
|
|
hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *)objv[1]);
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
objPtr = Tcl_NewStringObj("*", -1);
|
|||
|
|
Tcl_IncrRefCount(objPtr);
|
|||
|
|
hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions,
|
|||
|
|
(char *)objPtr);
|
|||
|
|
Tcl_DecrRefCount(objPtr);
|
|||
|
|
if (hPtr != NULL) {
|
|||
|
|
idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr);
|
|||
|
|
isStar = 1;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
if (isStar) {
|
|||
|
|
/* check if the function is in the exceptions */
|
|||
|
|
hPtr2 = Tcl_FindHashEntry(&starIdmPtr->exceptions, (char *)objv[1]);
|
|||
|
|
if (hPtr2 != NULL) {
|
|||
|
|
const char *sep = "";
|
|||
|
|
objPtr = Tcl_NewStringObj("unknown subcommand \"", -1);
|
|||
|
|
Tcl_AppendToObj(objPtr, funcName, -1);
|
|||
|
|
Tcl_AppendToObj(objPtr, "\": must be ", -1);
|
|||
|
|
FOREACH_HASH_VALUE(idmPtr,
|
|||
|
|
&iclsPtr->delegatedFunctions) {
|
|||
|
|
funcName = Tcl_GetString(idmPtr->namePtr);
|
|||
|
|
if (strcmp(funcName, "*") != 0) {
|
|||
|
|
if (strlen(sep) > 0) {
|
|||
|
|
Tcl_AppendToObj(objPtr, sep, -1);
|
|||
|
|
}
|
|||
|
|
Tcl_AppendToObj(objPtr, funcName, -1);
|
|||
|
|
sep = " or ";
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
Tcl_SetObjResult(interp, objPtr);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
if (hPtr != NULL) {
|
|||
|
|
idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr);
|
|||
|
|
val = NULL;
|
|||
|
|
if (idmPtr->icPtr != NULL) {
|
|||
|
|
if (idmPtr->icPtr->ivPtr->flags & ITCL_COMMON) {
|
|||
|
|
val = Tcl_GetVar2(interp,
|
|||
|
|
Tcl_GetString(idmPtr->icPtr->namePtr), NULL, 0);
|
|||
|
|
} else {
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
contextIclsPtr = NULL;
|
|||
|
|
contextIoPtr = NULL;
|
|||
|
|
Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr);
|
|||
|
|
Tcl_DStringInit(&buffer);
|
|||
|
|
Tcl_DStringAppend(&buffer,
|
|||
|
|
Tcl_GetString(contextIoPtr->varNsNamePtr), -1);
|
|||
|
|
Tcl_DStringAppend(&buffer,
|
|||
|
|
Tcl_GetString(idmPtr->icPtr->ivPtr->fullNamePtr),
|
|||
|
|
-1);
|
|||
|
|
val = Tcl_GetVar2(interp, Tcl_DStringValue(&buffer),
|
|||
|
|
NULL, 0);
|
|||
|
|
Tcl_DStringFree(&buffer);
|
|||
|
|
}
|
|||
|
|
if (val == NULL) {
|
|||
|
|
Tcl_AppendResult(interp, "INTERNAL ERROR: ",
|
|||
|
|
"ItclBiClassUnknownCmd contents ",
|
|||
|
|
"of component == NULL\n", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
offset = 1;
|
|||
|
|
lObjc = 0;
|
|||
|
|
if ((idmPtr->asPtr != NULL) || (idmPtr->usingPtr != NULL)) {
|
|||
|
|
offset++;
|
|||
|
|
listPtr = Tcl_NewListObj(0, NULL);
|
|||
|
|
result = ExpandDelegateAs(interp, NULL, iclsPtr,
|
|||
|
|
idmPtr, funcName, listPtr);
|
|||
|
|
if (result != TCL_OK) {
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
result = Tcl_ListObjGetElements(interp, listPtr,
|
|||
|
|
&lObjc, &lObjv);
|
|||
|
|
if (result != TCL_OK) {
|
|||
|
|
Tcl_DecrRefCount(listPtr);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
if (idmPtr->usingPtr != NULL) {
|
|||
|
|
useComponent = 0;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
if (useComponent) {
|
|||
|
|
if ((val == NULL) || (strlen(val) == 0)) {
|
|||
|
|
Tcl_AppendResult(interp, "component \"",
|
|||
|
|
Tcl_GetString(idmPtr->icPtr->namePtr),
|
|||
|
|
"\" is not initialized", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) *
|
|||
|
|
(objc + lObjc - offset + useComponent));
|
|||
|
|
if (useComponent) {
|
|||
|
|
newObjv[0] = Tcl_NewStringObj(val, -1);
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
}
|
|||
|
|
for (idx = 0; idx < lObjc; idx++) {
|
|||
|
|
newObjv[useComponent+idx] = lObjv[idx];
|
|||
|
|
}
|
|||
|
|
if (objc-offset > 0) {
|
|||
|
|
memcpy(newObjv+useComponent+lObjc, objv+offset,
|
|||
|
|
sizeof(Tcl_Obj *) * (objc-offset));
|
|||
|
|
}
|
|||
|
|
ItclShowArgs(1, "OBJ UK EVAL", objc+lObjc-offset+useComponent,
|
|||
|
|
newObjv);
|
|||
|
|
result = Tcl_EvalObjv(interp,
|
|||
|
|
objc+lObjc-offset+useComponent, newObjv, 0);
|
|||
|
|
if (isStar && (result == TCL_OK)) {
|
|||
|
|
if (Tcl_FindHashEntry(&iclsPtr->delegatedFunctions,
|
|||
|
|
(char *)newObjv[1]) == NULL) {
|
|||
|
|
result = ItclCreateDelegatedFunction(interp, iclsPtr,
|
|||
|
|
newObjv[1], idmPtr->icPtr, NULL, NULL,
|
|||
|
|
NULL, &idmPtr2);
|
|||
|
|
if (result == TCL_OK) {
|
|||
|
|
if (isTypeMethod) {
|
|||
|
|
idmPtr2->flags |= ITCL_TYPE_METHOD;
|
|||
|
|
} else {
|
|||
|
|
idmPtr2->flags |= ITCL_METHOD;
|
|||
|
|
}
|
|||
|
|
hPtr2 = Tcl_CreateHashEntry(
|
|||
|
|
&iclsPtr->delegatedFunctions,
|
|||
|
|
(char *)newObjv[1], &isNew);
|
|||
|
|
Tcl_SetHashValue(hPtr2, idmPtr2);
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
if (useComponent) {
|
|||
|
|
Tcl_DecrRefCount(newObjv[0]);
|
|||
|
|
}
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
if (listPtr != NULL) {
|
|||
|
|
Tcl_DecrRefCount(listPtr);
|
|||
|
|
}
|
|||
|
|
if (result == TCL_ERROR) {
|
|||
|
|
resStr = Tcl_GetString(Tcl_GetObjResult(interp));
|
|||
|
|
/* FIXME ugly hack at the moment !! */
|
|||
|
|
if (strncmp(resStr, "wrong # args: should be ", 24) == 0) {
|
|||
|
|
resPtr = Tcl_NewStringObj("", -1);
|
|||
|
|
Tcl_AppendToObj(resPtr, resStr, 25);
|
|||
|
|
resStr += 25;
|
|||
|
|
Tcl_AppendToObj(resPtr, Tcl_GetString(iclsPtr->namePtr),
|
|||
|
|
-1);
|
|||
|
|
resStr += strlen(val);
|
|||
|
|
Tcl_AppendToObj(resPtr, resStr, -1);
|
|||
|
|
Tcl_ResetResult(interp);
|
|||
|
|
Tcl_SetObjResult(interp, resPtr);
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
return PrepareCreateObject(interp, iclsPtr, objc, objv);
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* ItclUnknownGuts()
|
|||
|
|
*
|
|||
|
|
* The unknown method handler of the itcl::Root class -- all Itcl
|
|||
|
|
* objects land here when they cannot find a method.
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
int
|
|||
|
|
ItclUnknownGuts(
|
|||
|
|
ItclObject *ioPtr, /* The ItclObject seeking method */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
FOREACH_HASH_DECLS;
|
|||
|
|
Tcl_HashEntry *hPtr2;
|
|||
|
|
Tcl_Obj **newObjv;
|
|||
|
|
Tcl_Obj **lObjv;
|
|||
|
|
Tcl_Obj *listPtr = NULL;
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
Tcl_Obj *resPtr;
|
|||
|
|
Tcl_DString buffer;
|
|||
|
|
ItclClass *iclsPtr;
|
|||
|
|
ItclComponent *icPtr;
|
|||
|
|
ItclDelegatedFunction *idmPtr;
|
|||
|
|
ItclDelegatedFunction *idmPtr2;
|
|||
|
|
const char *resStr;
|
|||
|
|
const char *val;
|
|||
|
|
const char *funcName;
|
|||
|
|
int lObjc;
|
|||
|
|
int result;
|
|||
|
|
int offset;
|
|||
|
|
int useComponent;
|
|||
|
|
int found;
|
|||
|
|
int isItclHull;
|
|||
|
|
int isStar;
|
|||
|
|
int isTypeMethod;
|
|||
|
|
int isNew;
|
|||
|
|
int idx;
|
|||
|
|
|
|||
|
|
if (objc < 2) {
|
|||
|
|
Tcl_AppendResult(interp, "wrong # args: should be one of...",
|
|||
|
|
NULL);
|
|||
|
|
ItclReportObjectUsage(interp, ioPtr, NULL, NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
iclsPtr = ioPtr->iclsPtr;
|
|||
|
|
lObjc = 0;
|
|||
|
|
offset = 1;
|
|||
|
|
isStar = 0;
|
|||
|
|
found = 0;
|
|||
|
|
isItclHull = 0;
|
|||
|
|
useComponent = 1;
|
|||
|
|
result = TCL_OK;
|
|||
|
|
idmPtr = NULL;
|
|||
|
|
funcName = Tcl_GetString(objv[1]);
|
|||
|
|
if (strcmp(funcName, "itcl_hull") == 0) {
|
|||
|
|
isItclHull = 1;
|
|||
|
|
}
|
|||
|
|
icPtr = NULL;
|
|||
|
|
if (!isItclHull) {
|
|||
|
|
FOREACH_HASH_VALUE(icPtr, &ioPtr->objectComponents) {
|
|||
|
|
if (icPtr->flags & ITCL_COMPONENT_INHERIT) {
|
|||
|
|
val = Itcl_GetInstanceVar(interp,
|
|||
|
|
Tcl_GetString(icPtr->namePtr), ioPtr,
|
|||
|
|
icPtr->ivPtr->iclsPtr);
|
|||
|
|
if ((val != NULL) && (strlen(val) > 0)) {
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) *
|
|||
|
|
(objc));
|
|||
|
|
newObjv[0] = Tcl_NewStringObj(val, -1);
|
|||
|
|
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);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
isTypeMethod = 0;
|
|||
|
|
found = 0;
|
|||
|
|
FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) {
|
|||
|
|
if (strcmp(Tcl_GetString(idmPtr->namePtr), funcName) == 0) {
|
|||
|
|
if (idmPtr->flags & ITCL_TYPE_METHOD) {
|
|||
|
|
isTypeMethod = 1;
|
|||
|
|
}
|
|||
|
|
found = 1;
|
|||
|
|
break;
|
|||
|
|
}
|
|||
|
|
if (strcmp(Tcl_GetString(idmPtr->namePtr), "*") == 0) {
|
|||
|
|
if (idmPtr->flags & ITCL_TYPE_METHOD) {
|
|||
|
|
isTypeMethod = 1;
|
|||
|
|
}
|
|||
|
|
found = 1;
|
|||
|
|
break;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
if (! found) {
|
|||
|
|
idmPtr = NULL;
|
|||
|
|
}
|
|||
|
|
iclsPtr = ioPtr->iclsPtr;
|
|||
|
|
found = 0;
|
|||
|
|
hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *)objv[1]);
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
objPtr = Tcl_NewStringObj("*", -1);
|
|||
|
|
Tcl_IncrRefCount(objPtr);
|
|||
|
|
hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions,
|
|||
|
|
(char *)objPtr);
|
|||
|
|
Tcl_DecrRefCount(objPtr);
|
|||
|
|
if (hPtr != NULL) {
|
|||
|
|
idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr);
|
|||
|
|
isStar = 1;
|
|||
|
|
}
|
|||
|
|
} else {
|
|||
|
|
found = 1;
|
|||
|
|
idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr);
|
|||
|
|
}
|
|||
|
|
if (isStar) {
|
|||
|
|
/* check if the function is in the exceptions */
|
|||
|
|
hPtr2 = Tcl_FindHashEntry(&idmPtr->exceptions, (char *)objv[1]);
|
|||
|
|
if (hPtr2 != NULL) {
|
|||
|
|
const char *sep = "";
|
|||
|
|
objPtr = Tcl_NewStringObj("unknown subcommand \"", -1);
|
|||
|
|
Tcl_AppendToObj(objPtr, funcName, -1);
|
|||
|
|
Tcl_AppendToObj(objPtr, "\": must be ", -1);
|
|||
|
|
FOREACH_HASH_VALUE(idmPtr,
|
|||
|
|
&iclsPtr->delegatedFunctions) {
|
|||
|
|
funcName = Tcl_GetString(idmPtr->namePtr);
|
|||
|
|
if (strcmp(funcName, "*") != 0) {
|
|||
|
|
if (strlen(sep) > 0) {
|
|||
|
|
Tcl_AppendToObj(objPtr, sep, -1);
|
|||
|
|
}
|
|||
|
|
Tcl_AppendToObj(objPtr, funcName, -1);
|
|||
|
|
sep = " or ";
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
Tcl_SetObjResult(interp, objPtr);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
val = NULL;
|
|||
|
|
if ((idmPtr != NULL) && (idmPtr->icPtr != NULL)) {
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
/* we cannot use Itcl_GetInstanceVar here as the object is not
|
|||
|
|
* yet completely built. So use the varNsNamePtr
|
|||
|
|
*/
|
|||
|
|
if (idmPtr->icPtr->ivPtr->flags & ITCL_COMMON) {
|
|||
|
|
objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, -1);
|
|||
|
|
Tcl_AppendToObj(objPtr,
|
|||
|
|
(Tcl_GetObjectNamespace(iclsPtr->oPtr))->fullName, -1);
|
|||
|
|
Tcl_AppendToObj(objPtr, "::", -1);
|
|||
|
|
Tcl_AppendToObj(objPtr,
|
|||
|
|
Tcl_GetString(idmPtr->icPtr->namePtr), -1);
|
|||
|
|
val = Tcl_GetVar2(interp, Tcl_GetString(objPtr), NULL, 0);
|
|||
|
|
Tcl_DecrRefCount(objPtr);
|
|||
|
|
} else {
|
|||
|
|
Tcl_DStringInit(&buffer);
|
|||
|
|
Tcl_DStringAppend(&buffer,
|
|||
|
|
Tcl_GetString(ioPtr->varNsNamePtr), -1);
|
|||
|
|
Tcl_DStringAppend(&buffer,
|
|||
|
|
Tcl_GetString(idmPtr->icPtr->ivPtr->fullNamePtr), -1);
|
|||
|
|
val = Tcl_GetVar2(interp, Tcl_DStringValue(&buffer),
|
|||
|
|
NULL, 0);
|
|||
|
|
Tcl_DStringFree(&buffer);
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
if (val == NULL) {
|
|||
|
|
Tcl_AppendResult(interp, "ItclBiObjectUnknownCmd contents of ",
|
|||
|
|
"component == NULL\n", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
offset = 1;
|
|||
|
|
if (isStar) {
|
|||
|
|
hPtr = Tcl_FindHashEntry(&idmPtr->exceptions, (char *)objv[1]);
|
|||
|
|
/* we have no method name in that case in the caller */
|
|||
|
|
if (hPtr != NULL) {
|
|||
|
|
const char *sep = "";
|
|||
|
|
objPtr = Tcl_NewStringObj("unknown subcommand \"", -1);
|
|||
|
|
Tcl_AppendToObj(objPtr, funcName, -1);
|
|||
|
|
Tcl_AppendToObj(objPtr, "\": must be ", -1);
|
|||
|
|
FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) {
|
|||
|
|
funcName = Tcl_GetString(idmPtr->namePtr);
|
|||
|
|
if (strcmp(funcName, "*") != 0) {
|
|||
|
|
if (strlen(sep) > 0) {
|
|||
|
|
Tcl_AppendToObj(objPtr, sep, -1);
|
|||
|
|
}
|
|||
|
|
Tcl_AppendToObj(objPtr, funcName, -1);
|
|||
|
|
sep = " or ";
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
if (idmPtr == NULL) {
|
|||
|
|
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
|
|||
|
|
"\": should be one of...", NULL);
|
|||
|
|
ItclReportObjectUsage(interp, ioPtr, NULL, NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
lObjc = 0;
|
|||
|
|
if ((idmPtr != NULL) && ((idmPtr->asPtr != NULL) ||
|
|||
|
|
(idmPtr->usingPtr != NULL))) {
|
|||
|
|
offset++;
|
|||
|
|
listPtr = Tcl_NewListObj(0, NULL);
|
|||
|
|
result = ExpandDelegateAs(interp, NULL, iclsPtr,
|
|||
|
|
idmPtr, funcName, listPtr);
|
|||
|
|
if (result != TCL_OK) {
|
|||
|
|
Tcl_DecrRefCount(listPtr);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
result = Tcl_ListObjGetElements(interp, listPtr,
|
|||
|
|
&lObjc, &lObjv);
|
|||
|
|
if (result != TCL_OK) {
|
|||
|
|
Tcl_DecrRefCount(listPtr);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
if (idmPtr->usingPtr != NULL) {
|
|||
|
|
useComponent = 0;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
if (useComponent) {
|
|||
|
|
if ((val == NULL) || (strlen(val) == 0)) {
|
|||
|
|
Tcl_AppendResult(interp, "component \"",
|
|||
|
|
Tcl_GetString(idmPtr->icPtr->namePtr),
|
|||
|
|
"\" is not initialized", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) *
|
|||
|
|
(objc + lObjc - offset + useComponent));
|
|||
|
|
if (useComponent) {
|
|||
|
|
newObjv[0] = Tcl_NewStringObj(val, -1);
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
}
|
|||
|
|
for (idx = 0; idx < lObjc; idx++) {
|
|||
|
|
newObjv[useComponent+idx] = lObjv[idx];
|
|||
|
|
}
|
|||
|
|
if (objc-offset > 0) {
|
|||
|
|
memcpy(newObjv+useComponent+lObjc, objv+offset,
|
|||
|
|
sizeof(Tcl_Obj *) * (objc-offset));
|
|||
|
|
}
|
|||
|
|
ItclShowArgs(1, "UK EVAL2", objc+lObjc-offset+useComponent,
|
|||
|
|
newObjv);
|
|||
|
|
result = Tcl_EvalObjv(interp, objc+lObjc-offset+useComponent,
|
|||
|
|
newObjv, 0);
|
|||
|
|
if (isStar && (result == TCL_OK)) {
|
|||
|
|
if (Tcl_FindHashEntry(&iclsPtr->delegatedFunctions,
|
|||
|
|
(char *)newObjv[1]) == NULL) {
|
|||
|
|
result = ItclCreateDelegatedFunction(interp, iclsPtr,
|
|||
|
|
newObjv[1], idmPtr->icPtr, NULL, NULL,
|
|||
|
|
NULL, &idmPtr2);
|
|||
|
|
if (result == TCL_OK) {
|
|||
|
|
if (isTypeMethod) {
|
|||
|
|
idmPtr2->flags |= ITCL_TYPE_METHOD;
|
|||
|
|
} else {
|
|||
|
|
idmPtr2->flags |= ITCL_METHOD;
|
|||
|
|
}
|
|||
|
|
hPtr2 = Tcl_CreateHashEntry(
|
|||
|
|
&iclsPtr->delegatedFunctions, (char *)newObjv[1],
|
|||
|
|
&isNew);
|
|||
|
|
Tcl_SetHashValue(hPtr2, idmPtr2);
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
if (useComponent) {
|
|||
|
|
Tcl_DecrRefCount(newObjv[0]);
|
|||
|
|
}
|
|||
|
|
if (listPtr != NULL) {
|
|||
|
|
Tcl_DecrRefCount(listPtr);
|
|||
|
|
}
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
if (result == TCL_OK) {
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
resStr = Tcl_GetString(Tcl_GetObjResult(interp));
|
|||
|
|
/* FIXME ugly hack at the moment !! */
|
|||
|
|
if (strncmp(resStr, "wrong # args: should be ", 24) == 0) {
|
|||
|
|
resPtr = Tcl_NewStringObj("", -1);
|
|||
|
|
Tcl_AppendToObj(resPtr, resStr, 25);
|
|||
|
|
resStr += 25;
|
|||
|
|
Tcl_AppendToObj(resPtr, Tcl_GetString(iclsPtr->namePtr), -1);
|
|||
|
|
resStr += strlen(val);
|
|||
|
|
Tcl_AppendToObj(resPtr, resStr, -1);
|
|||
|
|
Tcl_ResetResult(interp);
|
|||
|
|
Tcl_SetObjResult(interp, resPtr);
|
|||
|
|
}
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
static Tcl_Obj *makeAsOptionInfo(
|
|||
|
|
Tcl_Interp *interp,
|
|||
|
|
Tcl_Obj *optNamePtr,
|
|||
|
|
ItclDelegatedOption *idoPtr,
|
|||
|
|
int lObjc2,
|
|||
|
|
Tcl_Obj * const *lObjv2)
|
|||
|
|
{
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
int j;
|
|||
|
|
|
|||
|
|
objPtr = Tcl_NewListObj(0, NULL);
|
|||
|
|
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(
|
|||
|
|
Tcl_GetString(optNamePtr), -1));
|
|||
|
|
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(
|
|||
|
|
Tcl_GetString(idoPtr->resourceNamePtr), -1));
|
|||
|
|
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(
|
|||
|
|
Tcl_GetString(idoPtr->classNamePtr), -1));
|
|||
|
|
for (j = 3; j < lObjc2; j++) {
|
|||
|
|
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(
|
|||
|
|
Tcl_GetString(lObjv2[j]), -1));
|
|||
|
|
}
|
|||
|
|
return objPtr;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* ItclExtendedConfigure()
|
|||
|
|
*
|
|||
|
|
* Invoked whenever the user issues the "configure" method for an object.
|
|||
|
|
* If the class is not ITCL_CLASS
|
|||
|
|
* Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* <objName> configure ?-<option>? ?<value> -<option> <value>...?
|
|||
|
|
*
|
|||
|
|
* Allows access to public variables as if they were configuration
|
|||
|
|
* options. With no arguments, this command returns the current
|
|||
|
|
* list of public variable options. If -<option> is specified,
|
|||
|
|
* this returns the information for just one option:
|
|||
|
|
*
|
|||
|
|
* -<optionName> <initVal> <currentVal>
|
|||
|
|
*
|
|||
|
|
* Otherwise, the list of arguments is parsed, and values are
|
|||
|
|
* assigned to the various public variable options. When each
|
|||
|
|
* option changes, a big of "config" code associated with the option
|
|||
|
|
* is executed, to bring the object up to date.
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
static int
|
|||
|
|
ItclExtendedConfigure(
|
|||
|
|
void *dummy, /* class definition */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
FOREACH_HASH_DECLS;
|
|||
|
|
Tcl_HashTable unique;
|
|||
|
|
Tcl_HashEntry *hPtr2;
|
|||
|
|
Tcl_HashEntry *hPtr3;
|
|||
|
|
Tcl_Object oPtr;
|
|||
|
|
Tcl_Obj *listPtr;
|
|||
|
|
Tcl_Obj *listPtr2;
|
|||
|
|
Tcl_Obj *resultPtr;
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
Tcl_Obj *optNamePtr;
|
|||
|
|
Tcl_Obj *methodNamePtr;
|
|||
|
|
Tcl_Obj *configureMethodPtr;
|
|||
|
|
Tcl_Obj **lObjv;
|
|||
|
|
Tcl_Obj **newObjv;
|
|||
|
|
Tcl_Obj *lObjvOne[1];
|
|||
|
|
Tcl_Obj **lObjv2;
|
|||
|
|
Tcl_Obj **lObjv3;
|
|||
|
|
Tcl_Namespace *saveNsPtr;
|
|||
|
|
Tcl_Namespace *evalNsPtr;
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclClass *iclsPtr2;
|
|||
|
|
ItclComponent *componentIcPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
ItclDelegatedFunction *idmPtr;
|
|||
|
|
ItclDelegatedOption *idoPtr;
|
|||
|
|
ItclDelegatedOption *saveIdoPtr;
|
|||
|
|
ItclObject *ioPtr;
|
|||
|
|
ItclComponent *icPtr;
|
|||
|
|
ItclOption *ioptPtr;
|
|||
|
|
ItclObjectInfo *infoPtr;
|
|||
|
|
const char *val;
|
|||
|
|
int lObjc;
|
|||
|
|
int lObjc2;
|
|||
|
|
int lObjc3;
|
|||
|
|
int i;
|
|||
|
|
int j;
|
|||
|
|
int isNew;
|
|||
|
|
int result;
|
|||
|
|
int isOneOption;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
ItclShowArgs(1, "ItclExtendedConfigure", objc, objv);
|
|||
|
|
ioptPtr = NULL;
|
|||
|
|
optNamePtr = NULL;
|
|||
|
|
/*
|
|||
|
|
* 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 configure ?-option? ?value -option value...?\"",
|
|||
|
|
NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* BE CAREFUL: work in the virtual scope!
|
|||
|
|
*/
|
|||
|
|
if (contextIoPtr != NULL) {
|
|||
|
|
contextIclsPtr = contextIoPtr->iclsPtr;
|
|||
|
|
}
|
|||
|
|
infoPtr = contextIclsPtr->infoPtr;
|
|||
|
|
if (infoPtr->currContextIclsPtr != NULL) {
|
|||
|
|
contextIclsPtr = infoPtr->currContextIclsPtr;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
hPtr = NULL;
|
|||
|
|
/* first check if method configure is delegated */
|
|||
|
|
methodNamePtr = Tcl_NewStringObj("*", -1);
|
|||
|
|
hPtr = Tcl_FindHashEntry(&contextIclsPtr->delegatedFunctions, (char *)
|
|||
|
|
methodNamePtr);
|
|||
|
|
if (hPtr != NULL) {
|
|||
|
|
/* all methods are delegated */
|
|||
|
|
idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr);
|
|||
|
|
Tcl_SetStringObj(methodNamePtr, "configure", -1);
|
|||
|
|
hPtr = Tcl_FindHashEntry(&idmPtr->exceptions, (char *)methodNamePtr);
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
icPtr = idmPtr->icPtr;
|
|||
|
|
val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr),
|
|||
|
|
NULL, contextIoPtr, contextIclsPtr);
|
|||
|
|
if (val != NULL) {
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+5));
|
|||
|
|
newObjv[0] = Tcl_NewStringObj(val, -1);
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
newObjv[1] = Tcl_NewStringObj("configure", -1);
|
|||
|
|
Tcl_IncrRefCount(newObjv[1]);
|
|||
|
|
for(i=1;i<objc;i++) {
|
|||
|
|
newObjv[i+1] = objv[i];
|
|||
|
|
}
|
|||
|
|
objPtr = Tcl_NewStringObj(val, -1);
|
|||
|
|
Tcl_IncrRefCount(objPtr);
|
|||
|
|
oPtr = Tcl_GetObjectFromObj(interp, objPtr);
|
|||
|
|
if (oPtr != NULL) {
|
|||
|
|
ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr,
|
|||
|
|
infoPtr->object_meta_type);
|
|||
|
|
infoPtr->currContextIclsPtr = ioPtr->iclsPtr;
|
|||
|
|
}
|
|||
|
|
ItclShowArgs(1, "EXTENDED CONFIGURE EVAL1", objc+1, newObjv);
|
|||
|
|
result = Tcl_EvalObjv(interp, objc+1, newObjv, TCL_EVAL_DIRECT);
|
|||
|
|
Tcl_DecrRefCount(newObjv[0]);
|
|||
|
|
Tcl_DecrRefCount(newObjv[1]);
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
Tcl_DecrRefCount(objPtr);
|
|||
|
|
if (oPtr != NULL) {
|
|||
|
|
infoPtr->currContextIclsPtr = NULL;
|
|||
|
|
}
|
|||
|
|
Tcl_DecrRefCount(methodNamePtr);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
} else {
|
|||
|
|
/* configure is not delegated, so reset hPtr for checks later on! */
|
|||
|
|
hPtr = NULL;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
Tcl_DecrRefCount(methodNamePtr);
|
|||
|
|
/* now do the hard work */
|
|||
|
|
if (objc == 1) {
|
|||
|
|
Tcl_InitObjHashTable(&unique);
|
|||
|
|
/* plain configure */
|
|||
|
|
listPtr = Tcl_NewListObj(0, NULL);
|
|||
|
|
if (contextIclsPtr->flags & ITCL_ECLASS) {
|
|||
|
|
result = Tcl_EvalEx(interp, "::itcl::builtin::getEclassOptions", -1, 0);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
FOREACH_HASH_VALUE(ioptPtr, &contextIoPtr->objectOptions) {
|
|||
|
|
hPtr2 = Tcl_CreateHashEntry(&unique,
|
|||
|
|
(char *)ioptPtr->namePtr, &isNew);
|
|||
|
|
if (!isNew) {
|
|||
|
|
continue;
|
|||
|
|
}
|
|||
|
|
objPtr = Tcl_NewListObj(0, NULL);
|
|||
|
|
Tcl_ListObjAppendElement(interp, objPtr,
|
|||
|
|
Tcl_NewStringObj(Tcl_GetString(ioptPtr->namePtr), -1));
|
|||
|
|
Tcl_ListObjAppendElement(interp, objPtr,
|
|||
|
|
Tcl_NewStringObj(
|
|||
|
|
Tcl_GetString(ioptPtr->resourceNamePtr), -1));
|
|||
|
|
Tcl_ListObjAppendElement(interp, objPtr,
|
|||
|
|
Tcl_NewStringObj(Tcl_GetString(ioptPtr->classNamePtr), -1));
|
|||
|
|
if (ioptPtr->defaultValuePtr != NULL) {
|
|||
|
|
Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(
|
|||
|
|
Tcl_GetString(ioptPtr->defaultValuePtr), -1));
|
|||
|
|
} else {
|
|||
|
|
Tcl_ListObjAppendElement(interp, objPtr,
|
|||
|
|
Tcl_NewStringObj("", -1));
|
|||
|
|
}
|
|||
|
|
val = ItclGetInstanceVar(interp, "itcl_options",
|
|||
|
|
Tcl_GetString(ioptPtr->namePtr), contextIoPtr,
|
|||
|
|
contextIclsPtr);
|
|||
|
|
if (val == NULL) {
|
|||
|
|
val = "<undefined>";
|
|||
|
|
}
|
|||
|
|
Tcl_ListObjAppendElement(interp, objPtr,
|
|||
|
|
Tcl_NewStringObj(val, -1));
|
|||
|
|
Tcl_ListObjAppendElement(interp, listPtr, objPtr);
|
|||
|
|
}
|
|||
|
|
/* now check for delegated options */
|
|||
|
|
FOREACH_HASH_VALUE(idoPtr, &contextIoPtr->objectDelegatedOptions) {
|
|||
|
|
|
|||
|
|
if (idoPtr->icPtr != NULL) {
|
|||
|
|
icPtr = idoPtr->icPtr;
|
|||
|
|
val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr),
|
|||
|
|
NULL, contextIoPtr, icPtr->ivPtr->iclsPtr);
|
|||
|
|
if ((val != NULL) && (strlen(val) != 0)) {
|
|||
|
|
|
|||
|
|
objPtr = Tcl_NewStringObj(val, -1);
|
|||
|
|
Tcl_IncrRefCount(objPtr);
|
|||
|
|
Tcl_AppendToObj(objPtr, " configure ", -1);
|
|||
|
|
isOneOption = 0;
|
|||
|
|
if (strcmp(Tcl_GetString(idoPtr->namePtr), "*") != 0) {
|
|||
|
|
Tcl_AppendToObj(objPtr, " ", -1);
|
|||
|
|
if (idoPtr->asPtr != NULL) {
|
|||
|
|
Tcl_AppendToObj(objPtr, Tcl_GetString(
|
|||
|
|
idoPtr->asPtr), -1);
|
|||
|
|
} else {
|
|||
|
|
Tcl_AppendToObj(objPtr, Tcl_GetString(
|
|||
|
|
idoPtr->namePtr), -1);
|
|||
|
|
}
|
|||
|
|
isOneOption = 1;
|
|||
|
|
}
|
|||
|
|
result = Tcl_EvalObjEx(interp, objPtr, 0);
|
|||
|
|
Tcl_DecrRefCount(objPtr);
|
|||
|
|
if (result != TCL_OK) {
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
listPtr2 = Tcl_GetObjResult(interp);
|
|||
|
|
if (isOneOption) {
|
|||
|
|
lObjc = 1;
|
|||
|
|
lObjvOne[0] = listPtr2;
|
|||
|
|
lObjv = &lObjvOne[0];
|
|||
|
|
} else {
|
|||
|
|
Tcl_ListObjGetElements(interp, listPtr2,
|
|||
|
|
&lObjc, &lObjv);
|
|||
|
|
}
|
|||
|
|
for (i = 0; i < lObjc; i++) {
|
|||
|
|
objPtr = lObjv[i];
|
|||
|
|
Tcl_ListObjGetElements(interp, objPtr,
|
|||
|
|
&lObjc2, &lObjv2);
|
|||
|
|
optNamePtr = idoPtr->namePtr;
|
|||
|
|
if (lObjc2 == 0) {
|
|||
|
|
hPtr = NULL;
|
|||
|
|
} else {
|
|||
|
|
hPtr = Tcl_FindHashEntry(&idoPtr->exceptions,
|
|||
|
|
(char *)lObjv2[0]);
|
|||
|
|
if (isOneOption) {
|
|||
|
|
/* avoid wrong name where asPtr != NULL */
|
|||
|
|
optNamePtr = idoPtr->namePtr;
|
|||
|
|
} else {
|
|||
|
|
optNamePtr = lObjv2[0];
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
if ((hPtr == NULL) && (lObjc2 > 0)) {
|
|||
|
|
if (icPtr->haveKeptOptions) {
|
|||
|
|
hPtr = Tcl_FindHashEntry(&icPtr->keptOptions,
|
|||
|
|
(char *)optNamePtr);
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
if (idoPtr->asPtr != NULL) {
|
|||
|
|
if (strcmp(Tcl_GetString(idoPtr->asPtr),
|
|||
|
|
Tcl_GetString(lObjv2[0])) == 0) {
|
|||
|
|
hPtr = Tcl_FindHashEntry(
|
|||
|
|
&icPtr->keptOptions,
|
|||
|
|
(char *)optNamePtr);
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
/* not in kept list, so ignore */
|
|||
|
|
continue;
|
|||
|
|
}
|
|||
|
|
objPtr = makeAsOptionInfo(interp,
|
|||
|
|
optNamePtr, idoPtr, lObjc2,
|
|||
|
|
lObjv2);
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
if (hPtr != NULL) {
|
|||
|
|
hPtr2 = Tcl_CreateHashEntry(&unique,
|
|||
|
|
(char *)optNamePtr, &isNew);
|
|||
|
|
if (!isNew) {
|
|||
|
|
continue;
|
|||
|
|
}
|
|||
|
|
/* add the option */
|
|||
|
|
if (idoPtr->asPtr != NULL) {
|
|||
|
|
objPtr = makeAsOptionInfo(interp,
|
|||
|
|
optNamePtr, idoPtr, lObjc2,
|
|||
|
|
lObjv2);
|
|||
|
|
}
|
|||
|
|
Tcl_ListObjAppendElement(interp, listPtr,
|
|||
|
|
objPtr);
|
|||
|
|
}
|
|||
|
|
} else {
|
|||
|
|
Tcl_ListObjGetElements(interp, lObjv2[i],
|
|||
|
|
&lObjc3, &lObjv3);
|
|||
|
|
hPtr2 = Tcl_CreateHashEntry(&unique,
|
|||
|
|
(char *)lObjv3[0], &isNew);
|
|||
|
|
if (!isNew) {
|
|||
|
|
continue;
|
|||
|
|
}
|
|||
|
|
/* add the option */
|
|||
|
|
if (idoPtr->asPtr != NULL) {
|
|||
|
|
objPtr = makeAsOptionInfo(interp,
|
|||
|
|
optNamePtr, idoPtr, lObjc2,
|
|||
|
|
lObjv2);
|
|||
|
|
}
|
|||
|
|
Tcl_ListObjAppendElement(interp, listPtr,
|
|||
|
|
objPtr);
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
Tcl_SetObjResult(interp, listPtr);
|
|||
|
|
Tcl_DeleteHashTable(&unique);
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
hPtr2 = NULL;
|
|||
|
|
/* first handle delegated options */
|
|||
|
|
hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions, (char *)
|
|||
|
|
objv[1]);
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
objPtr = Tcl_NewStringObj("*",1);
|
|||
|
|
Tcl_IncrRefCount(objPtr);
|
|||
|
|
/* check if all options are delegated */
|
|||
|
|
hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions,
|
|||
|
|
(char *)objPtr);
|
|||
|
|
Tcl_DecrRefCount(objPtr);
|
|||
|
|
if (hPtr != NULL) {
|
|||
|
|
/* now check the exceptions */
|
|||
|
|
idoPtr = (ItclDelegatedOption *)Tcl_GetHashValue(hPtr);
|
|||
|
|
hPtr2 = Tcl_FindHashEntry(&idoPtr->exceptions, (char *)objv[1]);
|
|||
|
|
if (hPtr2 != NULL) {
|
|||
|
|
/* found in exceptions, so no delegation for this option */
|
|||
|
|
hPtr = NULL;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
componentIcPtr = NULL;
|
|||
|
|
/* check if it is not a local option defined before delegate option "*"
|
|||
|
|
*/
|
|||
|
|
hPtr2 = Tcl_FindHashEntry(&contextIoPtr->objectOptions,
|
|||
|
|
(char *)objv[1]);
|
|||
|
|
if (hPtr != NULL) {
|
|||
|
|
idoPtr = (ItclDelegatedOption *)Tcl_GetHashValue(hPtr);
|
|||
|
|
icPtr = idoPtr->icPtr;
|
|||
|
|
if (icPtr != NULL) {
|
|||
|
|
if (icPtr->haveKeptOptions) {
|
|||
|
|
hPtr3 = Tcl_FindHashEntry(&icPtr->keptOptions, (char *)objv[1]);
|
|||
|
|
if (hPtr3 != NULL) {
|
|||
|
|
/* ignore if it is an object option only */
|
|||
|
|
ItclHierIter hier;
|
|||
|
|
int found;
|
|||
|
|
|
|||
|
|
found = 0;
|
|||
|
|
Itcl_InitHierIter(&hier, contextIoPtr->iclsPtr);
|
|||
|
|
iclsPtr2 = Itcl_AdvanceHierIter(&hier);
|
|||
|
|
while (iclsPtr2 != NULL) {
|
|||
|
|
if (Tcl_FindHashEntry(&iclsPtr2->options,
|
|||
|
|
(char *)objv[1]) != NULL) {
|
|||
|
|
found = 1;
|
|||
|
|
break;
|
|||
|
|
}
|
|||
|
|
iclsPtr2 = Itcl_AdvanceHierIter(&hier);
|
|||
|
|
}
|
|||
|
|
Itcl_DeleteHierIter(&hier);
|
|||
|
|
if (! found) {
|
|||
|
|
hPtr2 = NULL;
|
|||
|
|
componentIcPtr = icPtr;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
if ((objc <= 3) && (hPtr != NULL) && (hPtr2 == NULL)) {
|
|||
|
|
/* the option is delegated */
|
|||
|
|
idoPtr = (ItclDelegatedOption *)Tcl_GetHashValue(hPtr);
|
|||
|
|
if (componentIcPtr != NULL) {
|
|||
|
|
icPtr = componentIcPtr;
|
|||
|
|
} else {
|
|||
|
|
icPtr = idoPtr->icPtr;
|
|||
|
|
}
|
|||
|
|
val = ItclGetInstanceVar(interp,
|
|||
|
|
Tcl_GetString(icPtr->namePtr),
|
|||
|
|
NULL, contextIoPtr, icPtr->ivPtr->iclsPtr);
|
|||
|
|
if ((val != NULL) && (strlen(val) > 0)) {
|
|||
|
|
if (idoPtr->asPtr != NULL) {
|
|||
|
|
icPtr->ivPtr->iclsPtr->infoPtr->currIdoPtr = idoPtr;
|
|||
|
|
}
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+2));
|
|||
|
|
newObjv[0] = Tcl_NewStringObj(val, -1);
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
newObjv[1] = Tcl_NewStringObj("configure", 9);
|
|||
|
|
Tcl_IncrRefCount(newObjv[1]);
|
|||
|
|
if (idoPtr->asPtr != NULL) {
|
|||
|
|
newObjv[2] = idoPtr->asPtr;
|
|||
|
|
} else {
|
|||
|
|
newObjv[2] = objv[1];
|
|||
|
|
}
|
|||
|
|
Tcl_IncrRefCount(newObjv[2]);
|
|||
|
|
for(i=2;i<objc;i++) {
|
|||
|
|
newObjv[i+1] = objv[i];
|
|||
|
|
}
|
|||
|
|
objPtr = Tcl_NewStringObj(val, -1);
|
|||
|
|
Tcl_IncrRefCount(objPtr);
|
|||
|
|
oPtr = Tcl_GetObjectFromObj(interp, objPtr);
|
|||
|
|
if (oPtr != NULL) {
|
|||
|
|
ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr,
|
|||
|
|
infoPtr->object_meta_type);
|
|||
|
|
infoPtr->currContextIclsPtr = ioPtr->iclsPtr;
|
|||
|
|
}
|
|||
|
|
Tcl_DecrRefCount(objPtr);
|
|||
|
|
ItclShowArgs(1, "extended eval delegated option", objc + 1,
|
|||
|
|
newObjv);
|
|||
|
|
result = Tcl_EvalObjv(interp, objc+1, newObjv, TCL_EVAL_DIRECT);
|
|||
|
|
Tcl_DecrRefCount(newObjv[2]);
|
|||
|
|
Tcl_DecrRefCount(newObjv[1]);
|
|||
|
|
Tcl_DecrRefCount(newObjv[0]);
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
icPtr->ivPtr->iclsPtr->infoPtr->currIdoPtr = NULL;
|
|||
|
|
if (oPtr != NULL) {
|
|||
|
|
infoPtr->currContextIclsPtr = NULL;
|
|||
|
|
}
|
|||
|
|
return result;
|
|||
|
|
} else {
|
|||
|
|
Tcl_AppendResult(interp, "INTERNAL ERROR component \"",
|
|||
|
|
Tcl_GetString(icPtr->namePtr), "\" not found",
|
|||
|
|
" or not set in ItclExtendedConfigure delegated option",
|
|||
|
|
NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
if (objc == 2) {
|
|||
|
|
saveIdoPtr = infoPtr->currIdoPtr;
|
|||
|
|
/* now look if it is an option at all */
|
|||
|
|
if (hPtr2 == NULL) {
|
|||
|
|
hPtr2 = Tcl_FindHashEntry(&contextIclsPtr->options,
|
|||
|
|
(char *) objv[1]);
|
|||
|
|
if (hPtr2 == NULL) {
|
|||
|
|
hPtr2 = Tcl_FindHashEntry(&contextIoPtr->objectOptions,
|
|||
|
|
(char *) objv[1]);
|
|||
|
|
} else {
|
|||
|
|
infoPtr->currIdoPtr = NULL;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
if (hPtr2 == NULL) {
|
|||
|
|
if (contextIclsPtr->flags & ITCL_ECLASS) {
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc));
|
|||
|
|
newObjv[0] = Tcl_NewStringObj("::itcl::builtin::eclassConfigure", -1);
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
for (j = 1; j < objc; j++) {
|
|||
|
|
newObjv[j] = objv[j];
|
|||
|
|
Tcl_IncrRefCount(newObjv[j]);
|
|||
|
|
}
|
|||
|
|
result = Tcl_EvalObjv(interp, objc, newObjv, TCL_EVAL_DIRECT);
|
|||
|
|
for (j = 0; j < objc; j++) {
|
|||
|
|
Tcl_DecrRefCount(newObjv[j]);
|
|||
|
|
}
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
if (result == TCL_OK) {
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
/* no option at all, let the normal configure do the job */
|
|||
|
|
infoPtr->currIdoPtr = saveIdoPtr;
|
|||
|
|
return TCL_CONTINUE;
|
|||
|
|
}
|
|||
|
|
ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr2);
|
|||
|
|
resultPtr = ItclReportOption(interp, ioptPtr, contextIoPtr);
|
|||
|
|
infoPtr->currIdoPtr = saveIdoPtr;
|
|||
|
|
Tcl_SetObjResult(interp, resultPtr);
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
result = TCL_OK;
|
|||
|
|
/* set one or more options */
|
|||
|
|
for (i=1; i < objc; i+=2) {
|
|||
|
|
if (i+1 >= objc) {
|
|||
|
|
Tcl_AppendResult(interp, "need option value pair", NULL);
|
|||
|
|
result = TCL_ERROR;
|
|||
|
|
break;
|
|||
|
|
}
|
|||
|
|
hPtr = Tcl_FindHashEntry(&contextIoPtr->objectOptions,
|
|||
|
|
(char *) objv[i]);
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
if (contextIclsPtr->flags & ITCL_ECLASS) {
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc));
|
|||
|
|
newObjv[0] = Tcl_NewStringObj("::itcl::builtin::eclassConfigure", -1);
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
for (j = 1; j < objc; j++) {
|
|||
|
|
newObjv[j] = objv[j];
|
|||
|
|
Tcl_IncrRefCount(newObjv[j]);
|
|||
|
|
}
|
|||
|
|
result = Tcl_EvalObjv(interp, objc, newObjv, TCL_EVAL_DIRECT);
|
|||
|
|
for (j = 0; j < objc; j++) {
|
|||
|
|
Tcl_DecrRefCount(newObjv[j]);
|
|||
|
|
}
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
if (result == TCL_OK) {
|
|||
|
|
continue;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions,
|
|||
|
|
(char *) objv[i]);
|
|||
|
|
if (hPtr != NULL) {
|
|||
|
|
/* the option is delegated */
|
|||
|
|
idoPtr = (ItclDelegatedOption *)Tcl_GetHashValue(hPtr);
|
|||
|
|
icPtr = idoPtr->icPtr;
|
|||
|
|
val = ItclGetInstanceVar(interp,
|
|||
|
|
Tcl_GetString(icPtr->ivPtr->namePtr),
|
|||
|
|
NULL, contextIoPtr, icPtr->ivPtr->iclsPtr);
|
|||
|
|
if ((val != NULL) && (strlen(val) > 0)) {
|
|||
|
|
if (idoPtr->asPtr != NULL) {
|
|||
|
|
icPtr->ivPtr->iclsPtr->infoPtr->currIdoPtr = idoPtr;
|
|||
|
|
}
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+2));
|
|||
|
|
newObjv[0] = Tcl_NewStringObj(val, -1);
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
newObjv[1] = Tcl_NewStringObj("configure", 9);
|
|||
|
|
Tcl_IncrRefCount(newObjv[1]);
|
|||
|
|
if (idoPtr->asPtr != NULL) {
|
|||
|
|
newObjv[2] = idoPtr->asPtr;
|
|||
|
|
} else {
|
|||
|
|
newObjv[2] = objv[i];
|
|||
|
|
}
|
|||
|
|
Tcl_IncrRefCount(newObjv[2]);
|
|||
|
|
newObjv[3] = objv[i+1];
|
|||
|
|
objPtr = Tcl_NewStringObj(val, -1);
|
|||
|
|
Tcl_IncrRefCount(objPtr);
|
|||
|
|
oPtr = Tcl_GetObjectFromObj(interp, objPtr);
|
|||
|
|
if (oPtr != NULL) {
|
|||
|
|
ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr,
|
|||
|
|
infoPtr->object_meta_type);
|
|||
|
|
infoPtr->currContextIclsPtr = ioPtr->iclsPtr;
|
|||
|
|
}
|
|||
|
|
Tcl_DecrRefCount(objPtr);
|
|||
|
|
ItclShowArgs(1, "extended eval delegated option", 4,
|
|||
|
|
newObjv);
|
|||
|
|
result = Tcl_EvalObjv(interp, 4, newObjv, TCL_EVAL_DIRECT);
|
|||
|
|
Tcl_DecrRefCount(newObjv[2]);
|
|||
|
|
Tcl_DecrRefCount(newObjv[1]);
|
|||
|
|
Tcl_DecrRefCount(newObjv[0]);
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
icPtr->ivPtr->iclsPtr->infoPtr->currIdoPtr = NULL;
|
|||
|
|
if (oPtr != NULL) {
|
|||
|
|
infoPtr->currContextIclsPtr = NULL;
|
|||
|
|
}
|
|||
|
|
continue;
|
|||
|
|
} else {
|
|||
|
|
Tcl_AppendResult(interp, "INTERNAL ERROR component not ",
|
|||
|
|
"found or not set in ItclExtendedConfigure ",
|
|||
|
|
"delegated option", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
infoPtr->unparsedObjc += 2;
|
|||
|
|
if (infoPtr->unparsedObjv == NULL) {
|
|||
|
|
infoPtr->unparsedObjc++; /* keep the first slot for
|
|||
|
|
correct working !! */
|
|||
|
|
infoPtr->unparsedObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)
|
|||
|
|
*(infoPtr->unparsedObjc));
|
|||
|
|
infoPtr->unparsedObjv[0] = objv[0];
|
|||
|
|
} else {
|
|||
|
|
infoPtr->unparsedObjv = (Tcl_Obj **)ckrealloc(
|
|||
|
|
(char *)infoPtr->unparsedObjv, sizeof(Tcl_Obj *)
|
|||
|
|
*(infoPtr->unparsedObjc));
|
|||
|
|
}
|
|||
|
|
infoPtr->unparsedObjv[infoPtr->unparsedObjc-2] = objv[i];
|
|||
|
|
Tcl_IncrRefCount(infoPtr->unparsedObjv[infoPtr->unparsedObjc-2]);
|
|||
|
|
infoPtr->unparsedObjv[infoPtr->unparsedObjc-1] = objv[i+1];
|
|||
|
|
Tcl_IncrRefCount(infoPtr->unparsedObjv[infoPtr->unparsedObjc-1]);
|
|||
|
|
/* check if normal public variable/common ? */
|
|||
|
|
/* FIXME !!! temporary */
|
|||
|
|
continue;
|
|||
|
|
}
|
|||
|
|
ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr);
|
|||
|
|
if (ioptPtr->flags & ITCL_OPTION_READONLY) {
|
|||
|
|
if (infoPtr->currIoPtr == NULL) {
|
|||
|
|
/* allow only setting during instance creation
|
|||
|
|
* infoPtr->currIoPtr != NULL during instance creation
|
|||
|
|
*/
|
|||
|
|
Tcl_AppendResult(interp, "option \"",
|
|||
|
|
Tcl_GetString(ioptPtr->namePtr),
|
|||
|
|
"\" can only be set at instance creation", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
if (ioptPtr->validateMethodPtr != NULL) {
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * 3);
|
|||
|
|
newObjv[0] = ioptPtr->validateMethodPtr;
|
|||
|
|
newObjv[1] = objv[i];
|
|||
|
|
newObjv[2] = objv[i+1];
|
|||
|
|
infoPtr->inOptionHandling = 1;
|
|||
|
|
saveNsPtr = Tcl_GetCurrentNamespace(interp);
|
|||
|
|
Itcl_SetCallFrameNamespace(interp, contextIclsPtr->nsPtr);
|
|||
|
|
ItclShowArgs(1, "EVAL validatemethod", 3, newObjv);
|
|||
|
|
result = Tcl_EvalObjv(interp, 3, newObjv, TCL_EVAL_DIRECT);
|
|||
|
|
Itcl_SetCallFrameNamespace(interp, saveNsPtr);
|
|||
|
|
infoPtr->inOptionHandling = 0;
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
if (result != TCL_OK) {
|
|||
|
|
break;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
configureMethodPtr = NULL;
|
|||
|
|
evalNsPtr = NULL;
|
|||
|
|
if (ioptPtr->configureMethodPtr != NULL) {
|
|||
|
|
configureMethodPtr = ioptPtr->configureMethodPtr;
|
|||
|
|
Tcl_IncrRefCount(configureMethodPtr);
|
|||
|
|
evalNsPtr = ioptPtr->iclsPtr->nsPtr;
|
|||
|
|
}
|
|||
|
|
if (ioptPtr->configureMethodVarPtr != NULL) {
|
|||
|
|
val = ItclGetInstanceVar(interp,
|
|||
|
|
Tcl_GetString(ioptPtr->configureMethodVarPtr), NULL,
|
|||
|
|
contextIoPtr, ioptPtr->iclsPtr);
|
|||
|
|
if (val == NULL) {
|
|||
|
|
Tcl_AppendResult(interp, "configure cannot get value for",
|
|||
|
|
" configuremethodvar \"",
|
|||
|
|
Tcl_GetString(ioptPtr->configureMethodVarPtr),
|
|||
|
|
"\"", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
objPtr = Tcl_NewStringObj(val, -1);
|
|||
|
|
hPtr = Tcl_FindHashEntry(&contextIoPtr->iclsPtr->resolveCmds,
|
|||
|
|
(char *)objPtr);
|
|||
|
|
Tcl_DecrRefCount(objPtr);
|
|||
|
|
if (hPtr != NULL) {
|
|||
|
|
ItclMemberFunc *imPtr;
|
|||
|
|
ItclCmdLookup *clookup;
|
|||
|
|
clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr);
|
|||
|
|
imPtr = clookup->imPtr;
|
|||
|
|
evalNsPtr = imPtr->iclsPtr->nsPtr;
|
|||
|
|
} else {
|
|||
|
|
Tcl_AppendResult(interp, "cannot find method \"",
|
|||
|
|
val, "\" found in configuremethodvar", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
configureMethodPtr = Tcl_NewStringObj(val, -1);
|
|||
|
|
Tcl_IncrRefCount(configureMethodPtr);
|
|||
|
|
}
|
|||
|
|
if (configureMethodPtr != NULL) {
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*3);
|
|||
|
|
newObjv[0] = configureMethodPtr;
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
newObjv[1] = objv[i];
|
|||
|
|
Tcl_IncrRefCount(newObjv[1]);
|
|||
|
|
newObjv[2] = objv[i+1];
|
|||
|
|
Tcl_IncrRefCount(newObjv[2]);
|
|||
|
|
saveNsPtr = Tcl_GetCurrentNamespace(interp);
|
|||
|
|
Itcl_SetCallFrameNamespace(interp, evalNsPtr);
|
|||
|
|
ItclShowArgs(1, "EVAL configuremethod", 3, newObjv);
|
|||
|
|
result = Tcl_EvalObjv(interp, 3, newObjv, TCL_EVAL_DIRECT);
|
|||
|
|
Tcl_DecrRefCount(newObjv[0]);
|
|||
|
|
Tcl_DecrRefCount(newObjv[1]);
|
|||
|
|
Tcl_DecrRefCount(newObjv[2]);
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
Itcl_SetCallFrameNamespace(interp, saveNsPtr);
|
|||
|
|
Tcl_DecrRefCount(configureMethodPtr);
|
|||
|
|
if (result != TCL_OK) {
|
|||
|
|
break;
|
|||
|
|
}
|
|||
|
|
} else {
|
|||
|
|
if (ItclSetInstanceVar(interp, "itcl_options",
|
|||
|
|
Tcl_GetString(objv[i]), Tcl_GetString(objv[i+1]),
|
|||
|
|
contextIoPtr, ioptPtr->iclsPtr) == NULL) {
|
|||
|
|
result = TCL_ERROR;
|
|||
|
|
break;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
Tcl_ResetResult(interp);
|
|||
|
|
result = TCL_OK;
|
|||
|
|
}
|
|||
|
|
if (infoPtr->unparsedObjc > 0) {
|
|||
|
|
if (result == TCL_OK) {
|
|||
|
|
return TCL_CONTINUE;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* ItclExtendedCget()
|
|||
|
|
*
|
|||
|
|
* Invoked whenever the user issues the "cget" method for an object.
|
|||
|
|
* If the class is NOT ITCL_CLASS
|
|||
|
|
* Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* <objName> cget -<option>
|
|||
|
|
*
|
|||
|
|
* Allows access to public variables as if they were configuration
|
|||
|
|
* options. Mimics the behavior of the usual "cget" method for
|
|||
|
|
* Tk widgets. Returns the current value of the public variable
|
|||
|
|
* with name <option>.
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
static int
|
|||
|
|
ItclExtendedCget(
|
|||
|
|
void *dummy, /* class definition */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
Tcl_HashEntry *hPtr;
|
|||
|
|
Tcl_HashEntry *hPtr2;
|
|||
|
|
Tcl_HashEntry *hPtr3;
|
|||
|
|
Tcl_Obj *objPtr2;
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
Tcl_Object oPtr;
|
|||
|
|
Tcl_Obj *methodNamePtr;
|
|||
|
|
Tcl_Obj **newObjv;
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
ItclDelegatedFunction *idmPtr;
|
|||
|
|
ItclDelegatedOption *idoPtr;
|
|||
|
|
ItclComponent *icPtr;
|
|||
|
|
ItclObjectInfo *infoPtr;
|
|||
|
|
ItclOption *ioptPtr;
|
|||
|
|
ItclObject *ioPtr;
|
|||
|
|
const char *val;
|
|||
|
|
int i;
|
|||
|
|
int result;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
ItclShowArgs(1,"ItclExtendedCget", objc, objv);
|
|||
|
|
/*
|
|||
|
|
* 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) || objc != 2) {
|
|||
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
|||
|
|
"improper usage: should be \"object cget -option\"",
|
|||
|
|
NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* BE CAREFUL: work in the virtual scope!
|
|||
|
|
*/
|
|||
|
|
if (contextIoPtr != NULL) {
|
|||
|
|
contextIclsPtr = contextIoPtr->iclsPtr;
|
|||
|
|
}
|
|||
|
|
infoPtr = contextIclsPtr->infoPtr;
|
|||
|
|
if (infoPtr->currContextIclsPtr != NULL) {
|
|||
|
|
contextIclsPtr = infoPtr->currContextIclsPtr;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
hPtr = NULL;
|
|||
|
|
/* first check if method cget is delegated */
|
|||
|
|
methodNamePtr = Tcl_NewStringObj("*", -1);
|
|||
|
|
hPtr = Tcl_FindHashEntry(&contextIclsPtr->delegatedFunctions, (char *)
|
|||
|
|
methodNamePtr);
|
|||
|
|
if (hPtr != NULL) {
|
|||
|
|
idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr);
|
|||
|
|
Tcl_SetStringObj(methodNamePtr, "cget", -1);
|
|||
|
|
hPtr = Tcl_FindHashEntry(&idmPtr->exceptions, (char *)methodNamePtr);
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
icPtr = idmPtr->icPtr;
|
|||
|
|
val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr),
|
|||
|
|
NULL, contextIoPtr, contextIclsPtr);
|
|||
|
|
if (val != NULL) {
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+1));
|
|||
|
|
newObjv[0] = Tcl_NewStringObj(val, -1);
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
newObjv[1] = Tcl_NewStringObj("cget", 4);
|
|||
|
|
Tcl_IncrRefCount(newObjv[1]);
|
|||
|
|
for(i=1;i<objc;i++) {
|
|||
|
|
newObjv[i+1] = objv[i];
|
|||
|
|
}
|
|||
|
|
objPtr = Tcl_NewStringObj(val, -1);
|
|||
|
|
Tcl_IncrRefCount(objPtr);
|
|||
|
|
oPtr = Tcl_GetObjectFromObj(interp, objPtr);
|
|||
|
|
if (oPtr != NULL) {
|
|||
|
|
ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr,
|
|||
|
|
infoPtr->object_meta_type);
|
|||
|
|
infoPtr->currContextIclsPtr = ioPtr->iclsPtr;
|
|||
|
|
}
|
|||
|
|
ItclShowArgs(1, "DELEGATED EVAL", objc+1, newObjv);
|
|||
|
|
result = Tcl_EvalObjv(interp, objc+1, newObjv, TCL_EVAL_DIRECT);
|
|||
|
|
Tcl_DecrRefCount(newObjv[0]);
|
|||
|
|
Tcl_DecrRefCount(newObjv[1]);
|
|||
|
|
Tcl_DecrRefCount(objPtr);
|
|||
|
|
if (oPtr != NULL) {
|
|||
|
|
infoPtr->currContextIclsPtr = NULL;
|
|||
|
|
}
|
|||
|
|
Tcl_DecrRefCount(methodNamePtr);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
Tcl_DecrRefCount(methodNamePtr);
|
|||
|
|
if (objc == 1) {
|
|||
|
|
Tcl_WrongNumArgs(interp, 1, objv, "option");
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
/* now do the hard work */
|
|||
|
|
/* first handle delegated options */
|
|||
|
|
hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions, (char *)
|
|||
|
|
objv[1]);
|
|||
|
|
hPtr3 = Tcl_FindHashEntry(&contextIoPtr->objectOptions, (char *)
|
|||
|
|
objv[1]);
|
|||
|
|
hPtr2 = NULL;
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
objPtr2 = Tcl_NewStringObj("*", -1);
|
|||
|
|
/* check for "*" option delegated */
|
|||
|
|
hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions, (char *)
|
|||
|
|
objPtr2);
|
|||
|
|
Tcl_DecrRefCount(objPtr2);
|
|||
|
|
hPtr2 = Tcl_FindHashEntry(&contextIoPtr->objectOptions, (char *)
|
|||
|
|
objv[1]);
|
|||
|
|
}
|
|||
|
|
if ((hPtr != NULL) && (hPtr2 == NULL) && (hPtr3 == NULL)) {
|
|||
|
|
/* the option is delegated */
|
|||
|
|
idoPtr = (ItclDelegatedOption *)Tcl_GetHashValue(hPtr);
|
|||
|
|
/* if the option is in the exceptions, do nothing */
|
|||
|
|
hPtr = Tcl_FindHashEntry(&idoPtr->exceptions, (char *)
|
|||
|
|
objv[1]);
|
|||
|
|
if (hPtr) {
|
|||
|
|
return TCL_CONTINUE;
|
|||
|
|
}
|
|||
|
|
icPtr = idoPtr->icPtr;
|
|||
|
|
if (icPtr->ivPtr->flags & ITCL_COMMON) {
|
|||
|
|
val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr),
|
|||
|
|
NULL, contextIoPtr, icPtr->ivPtr->iclsPtr);
|
|||
|
|
} else {
|
|||
|
|
val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr),
|
|||
|
|
NULL, contextIoPtr, icPtr->ivPtr->iclsPtr);
|
|||
|
|
}
|
|||
|
|
if ((val != NULL) && (strlen(val) > 0)) {
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+1));
|
|||
|
|
newObjv[0] = Tcl_NewStringObj(val, -1);
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
newObjv[1] = Tcl_NewStringObj("cget", 4);
|
|||
|
|
Tcl_IncrRefCount(newObjv[1]);
|
|||
|
|
for(i=1;i<objc;i++) {
|
|||
|
|
if (strcmp(Tcl_GetString(idoPtr->namePtr),
|
|||
|
|
Tcl_GetString(objv[i])) == 0) {
|
|||
|
|
if (idoPtr->asPtr != NULL) {
|
|||
|
|
newObjv[i+1] = idoPtr->asPtr;
|
|||
|
|
} else {
|
|||
|
|
newObjv[i+1] = objv[i];
|
|||
|
|
}
|
|||
|
|
} else {
|
|||
|
|
newObjv[i+1] = objv[i];
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
objPtr = Tcl_NewStringObj(val, -1);
|
|||
|
|
Tcl_IncrRefCount(objPtr);
|
|||
|
|
oPtr = Tcl_GetObjectFromObj(interp, objPtr);
|
|||
|
|
if (oPtr != NULL) {
|
|||
|
|
ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr,
|
|||
|
|
infoPtr->object_meta_type);
|
|||
|
|
infoPtr->currContextIclsPtr = ioPtr->iclsPtr;
|
|||
|
|
}
|
|||
|
|
ItclShowArgs(1, "ExtendedCget delegated option", objc+1, newObjv);
|
|||
|
|
result = Tcl_EvalObjv(interp, objc+1, newObjv, TCL_EVAL_DIRECT);
|
|||
|
|
Tcl_DecrRefCount(newObjv[0]);
|
|||
|
|
Tcl_DecrRefCount(newObjv[1]);
|
|||
|
|
Tcl_DecrRefCount(objPtr);
|
|||
|
|
if (oPtr != NULL) {
|
|||
|
|
infoPtr->currContextIclsPtr = NULL;
|
|||
|
|
}
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
return result;
|
|||
|
|
} else {
|
|||
|
|
Tcl_ResetResult(interp);
|
|||
|
|
Tcl_AppendResult(interp, "component \"",
|
|||
|
|
Tcl_GetString(icPtr->namePtr),
|
|||
|
|
"\" is undefined, needed for option \"",
|
|||
|
|
Tcl_GetString(objv[1]),
|
|||
|
|
"\"", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/* now look if it is an option at all */
|
|||
|
|
if ((hPtr2 == NULL) && (hPtr3 == NULL)) {
|
|||
|
|
/* no option at all, let the normal configure do the job */
|
|||
|
|
return TCL_CONTINUE;
|
|||
|
|
}
|
|||
|
|
if (hPtr3 != NULL) {
|
|||
|
|
ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr3);
|
|||
|
|
} else {
|
|||
|
|
ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr2);
|
|||
|
|
}
|
|||
|
|
result = TCL_CONTINUE;
|
|||
|
|
if (ioptPtr->cgetMethodPtr != NULL) {
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*2);
|
|||
|
|
newObjv[0] = ioptPtr->cgetMethodPtr;
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
newObjv[1] = objv[1];
|
|||
|
|
Tcl_IncrRefCount(newObjv[1]);
|
|||
|
|
ItclShowArgs(1, "eval cget method", objc, newObjv);
|
|||
|
|
result = Tcl_EvalObjv(interp, objc, newObjv, TCL_EVAL_DIRECT);
|
|||
|
|
Tcl_DecrRefCount(newObjv[1]);
|
|||
|
|
Tcl_DecrRefCount(newObjv[0]);
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
} else {
|
|||
|
|
val = ItclGetInstanceVar(interp, "itcl_options",
|
|||
|
|
Tcl_GetString(ioptPtr->namePtr),
|
|||
|
|
contextIoPtr, ioptPtr->iclsPtr);
|
|||
|
|
if (val) {
|
|||
|
|
Tcl_SetObjResult(interp, Tcl_NewStringObj(val, -1));
|
|||
|
|
} else {
|
|||
|
|
Tcl_SetObjResult(interp, Tcl_NewStringObj("<undefined>", -1));
|
|||
|
|
}
|
|||
|
|
result = TCL_OK;
|
|||
|
|
}
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* ItclExtendedSetGet()
|
|||
|
|
*
|
|||
|
|
* Invoked whenever the user writes to a methodvariable or calls the method
|
|||
|
|
* with the same name as the variable.
|
|||
|
|
* only for not ITCL_CLASS classes
|
|||
|
|
* Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* <objName> setget varName ?<value>?
|
|||
|
|
*
|
|||
|
|
* Allows access to methodvariables as if they hat a setter and getter
|
|||
|
|
* method
|
|||
|
|
* With no arguments, this command returns the current
|
|||
|
|
* value of the variable. If <value> is specified,
|
|||
|
|
* this sets the variable to the value calling a callback if exists:
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
static int
|
|||
|
|
ItclExtendedSetGet(
|
|||
|
|
void *dummy, /* class definition */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
|
|||
|
|
Tcl_HashEntry *hPtr;
|
|||
|
|
Tcl_Obj **newObjv;
|
|||
|
|
ItclMethodVariable *imvPtr;
|
|||
|
|
ItclObjectInfo *infoPtr;
|
|||
|
|
const char *usageStr;
|
|||
|
|
const char *val;
|
|||
|
|
int result;
|
|||
|
|
int setValue;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
ItclShowArgs(1, "ItclExtendedSetGet", objc, objv);
|
|||
|
|
imvPtr = NULL;
|
|||
|
|
result = TCL_OK;
|
|||
|
|
/*
|
|||
|
|
* 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;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
usageStr = "improper usage: should be \"object setget varName ?value?\"";
|
|||
|
|
if (contextIoPtr == NULL) {
|
|||
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
|||
|
|
usageStr, NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* BE CAREFUL: work in the virtual scope!
|
|||
|
|
*/
|
|||
|
|
if (contextIoPtr != NULL) {
|
|||
|
|
contextIclsPtr = contextIoPtr->iclsPtr;
|
|||
|
|
}
|
|||
|
|
infoPtr = contextIclsPtr->infoPtr;
|
|||
|
|
if (infoPtr->currContextIclsPtr != NULL) {
|
|||
|
|
contextIclsPtr = infoPtr->currContextIclsPtr;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
hPtr = NULL;
|
|||
|
|
if (objc < 2) {
|
|||
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
|||
|
|
usageStr, NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
/* look if it is an methodvariable at all */
|
|||
|
|
hPtr = Tcl_FindHashEntry(&contextIoPtr->objectMethodVariables,
|
|||
|
|
(char *) objv[1]);
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
Tcl_AppendResult(interp, "no such methodvariable \"",
|
|||
|
|
Tcl_GetString(objv[1]), "\"", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
imvPtr = (ItclMethodVariable *)Tcl_GetHashValue(hPtr);
|
|||
|
|
if (objc == 2) {
|
|||
|
|
val = ItclGetInstanceVar(interp, Tcl_GetString(objv[1]), NULL,
|
|||
|
|
contextIoPtr, imvPtr->iclsPtr);
|
|||
|
|
if (val == NULL) {
|
|||
|
|
result = TCL_ERROR;
|
|||
|
|
} else {
|
|||
|
|
Tcl_SetObjResult(interp, Tcl_NewStringObj(val, -1));
|
|||
|
|
}
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
imvPtr = (ItclMethodVariable *)Tcl_GetHashValue(hPtr);
|
|||
|
|
result = TCL_OK;
|
|||
|
|
setValue = 1;
|
|||
|
|
if (imvPtr->callbackPtr != NULL) {
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*3);
|
|||
|
|
newObjv[0] = imvPtr->callbackPtr;
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
newObjv[1] = objv[1];
|
|||
|
|
Tcl_IncrRefCount(newObjv[1]);
|
|||
|
|
newObjv[2] = objv[2];
|
|||
|
|
Tcl_IncrRefCount(newObjv[2]);
|
|||
|
|
result = Tcl_EvalObjv(interp, 3, newObjv, TCL_EVAL_DIRECT);
|
|||
|
|
Tcl_DecrRefCount(newObjv[0]);
|
|||
|
|
Tcl_DecrRefCount(newObjv[1]);
|
|||
|
|
Tcl_DecrRefCount(newObjv[2]);
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
}
|
|||
|
|
if (result == TCL_OK) {
|
|||
|
|
Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &setValue);
|
|||
|
|
/* if setValue != 0 set the new value of the variable here */
|
|||
|
|
if (setValue) {
|
|||
|
|
if (ItclSetInstanceVar(interp, Tcl_GetString(objv[1]), NULL,
|
|||
|
|
Tcl_GetString(objv[2]), contextIoPtr,
|
|||
|
|
imvPtr->iclsPtr) == NULL) {
|
|||
|
|
result = TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiInstallComponentCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked whenever the user issues the "installcomponent" method for an
|
|||
|
|
* object.
|
|||
|
|
* Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* installcomponent <componentName> using <widgetClassName> <widgetPathName>
|
|||
|
|
* ?-option value -option value ...?
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
int
|
|||
|
|
Itcl_BiInstallComponentCmd(
|
|||
|
|
void *dummy, /* class definition */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
FOREACH_HASH_DECLS;
|
|||
|
|
Tcl_Obj ** newObjv;
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
ItclDelegatedOption *idoPtr;
|
|||
|
|
const char *usageStr;
|
|||
|
|
const char *componentName;
|
|||
|
|
const char *componentValue;
|
|||
|
|
const char *token;
|
|||
|
|
int numOpts;
|
|||
|
|
int result;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
ItclShowArgs(1, "Itcl_BiInstallComponentCmd", objc, objv);
|
|||
|
|
/*
|
|||
|
|
* 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 installcomponent \"",
|
|||
|
|
NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
if (objc < 5) {
|
|||
|
|
/* FIXME strip off the :: parts here properly*/
|
|||
|
|
token = Tcl_GetString(objv[0])+2;
|
|||
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
|||
|
|
"wrong # args: should be \"", token, " <componentName> using",
|
|||
|
|
" <widgetClassName> <widgetPathName>",
|
|||
|
|
" ?-option value -option value ...?\"",
|
|||
|
|
NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/* get component name and check, if it exists */
|
|||
|
|
token = Tcl_GetString(objv[1]);
|
|||
|
|
if (contextIclsPtr == NULL) {
|
|||
|
|
Tcl_AppendResult(interp, "cannot find context class for object \"",
|
|||
|
|
Tcl_GetCommandName(interp, contextIoPtr->accessCmd), "\"",
|
|||
|
|
NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
if (!(contextIclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR))) {
|
|||
|
|
Tcl_AppendResult(interp, "no such method \"installcomponent\"", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
hPtr = Tcl_FindHashEntry(&contextIclsPtr->components, (char *)objv[1]);
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
numOpts = 0;
|
|||
|
|
FOREACH_HASH_VALUE(idoPtr, &contextIoPtr->objectDelegatedOptions) {
|
|||
|
|
if (idoPtr == NULL) {
|
|||
|
|
/* FIXME need code here !! */
|
|||
|
|
}
|
|||
|
|
numOpts++;
|
|||
|
|
}
|
|||
|
|
if (numOpts == 0) {
|
|||
|
|
/* there are no delegated options, so no problem that the
|
|||
|
|
* component does not exist. We have nothing to do */
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
Tcl_AppendResult(interp, "class \"",
|
|||
|
|
Tcl_GetString(contextIclsPtr->namePtr),
|
|||
|
|
"\" has no component \"",
|
|||
|
|
Tcl_GetString(objv[1]), "\"", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
if (contextIclsPtr->flags & ITCL_TYPE) {
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
usageStr = "usage: installcomponent <componentName> using <widgetType> <widgetPath> ?-option value ...?";
|
|||
|
|
if (objc < 4) {
|
|||
|
|
Tcl_AppendResult(interp, usageStr, NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
if (strcmp(Tcl_GetString(objv[2]), "using") != 0) {
|
|||
|
|
Tcl_AppendResult(interp, usageStr, NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
componentName = Tcl_GetString(objv[1]);
|
|||
|
|
/* as it is no widget, we don't need to check for delegated option */
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc - 3));
|
|||
|
|
memcpy(newObjv, objv + 3, sizeof(Tcl_Obj *) * ((objc - 3)));
|
|||
|
|
ItclShowArgs(1, "BiInstallComponent", objc - 3, newObjv);
|
|||
|
|
result = Tcl_EvalObjv(interp, objc - 3, newObjv, 0);
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
if (result != TCL_OK) {
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
componentValue = Tcl_GetString(Tcl_GetObjResult(interp));
|
|||
|
|
objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, -1);
|
|||
|
|
Tcl_AppendToObj(objPtr,
|
|||
|
|
(Tcl_GetObjectNamespace(contextIclsPtr->oPtr))->fullName, -1);
|
|||
|
|
Tcl_AppendToObj(objPtr, "::", -1);
|
|||
|
|
Tcl_AppendToObj(objPtr, componentName, -1);
|
|||
|
|
|
|||
|
|
Tcl_SetVar2(interp, Tcl_GetString(objPtr), NULL, componentValue, 0);
|
|||
|
|
Tcl_DecrRefCount(objPtr);
|
|||
|
|
|
|||
|
|
} else {
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc + 1));
|
|||
|
|
newObjv[0] = Tcl_NewStringObj("::itcl::builtin::installcomponent", -1);
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
memcpy(newObjv, objv + 1, sizeof(Tcl_Obj *) * ((objc - 1)));
|
|||
|
|
result = Tcl_EvalObjv(interp, objc, newObjv, 0);
|
|||
|
|
Tcl_DecrRefCount(newObjv[0]);
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiDestroyCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked whenever the user issues the "destroy" method for an
|
|||
|
|
* object.
|
|||
|
|
* Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* destroy
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
static int
|
|||
|
|
Itcl_BiDestroyCmd(
|
|||
|
|
void *dummy, /* class definition */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
Tcl_Obj **newObjv;
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
int result;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Make sure that this command is being invoked in the proper
|
|||
|
|
* context.
|
|||
|
|
*/
|
|||
|
|
ItclShowArgs(1, "Itcl_BiDestroyCmd", objc, objv);
|
|||
|
|
contextIoPtr = NULL;
|
|||
|
|
contextIclsPtr = NULL;
|
|||
|
|
if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
if (contextIclsPtr == NULL) {
|
|||
|
|
Tcl_AppendResult(interp, "cannot find context class for object \"",
|
|||
|
|
Tcl_GetCommandName(interp, contextIoPtr->accessCmd), "\"",
|
|||
|
|
NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
if ((objc > 1) || !(contextIclsPtr->flags &
|
|||
|
|
(ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR))) {
|
|||
|
|
/* try to execute destroy in uplevel namespace */
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc + 2));
|
|||
|
|
newObjv[0] = Tcl_NewStringObj("uplevel", -1);
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
newObjv[1] = Tcl_NewStringObj("#0", -1);
|
|||
|
|
Tcl_IncrRefCount(newObjv[1]);
|
|||
|
|
newObjv[2] = Tcl_NewStringObj("destroy", -1);
|
|||
|
|
Tcl_IncrRefCount(newObjv[2]);
|
|||
|
|
memcpy(newObjv + 3, objv + 1, sizeof(Tcl_Obj *) * (objc - 1));
|
|||
|
|
ItclShowArgs(1, "DESTROY", objc + 2, newObjv);
|
|||
|
|
result = Tcl_EvalObjv(interp, objc + 2, newObjv, 0);
|
|||
|
|
Tcl_DecrRefCount(newObjv[2]);
|
|||
|
|
Tcl_DecrRefCount(newObjv[1]);
|
|||
|
|
Tcl_DecrRefCount(newObjv[0]);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
if (objc != 1) {
|
|||
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
|||
|
|
"wrong # args: should be \"", Tcl_GetString(objv[0]), NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
if (contextIoPtr != NULL) {
|
|||
|
|
Tcl_Obj *objPtr = Tcl_NewObj();
|
|||
|
|
Tcl_GetCommandFullName(interp, contextIoPtr->accessCmd, objPtr);
|
|||
|
|
Itcl_RenameCommand(interp, Tcl_GetString(objPtr), "");
|
|||
|
|
Tcl_DecrRefCount(objPtr);
|
|||
|
|
result = TCL_OK;
|
|||
|
|
} else {
|
|||
|
|
result = Itcl_DeleteClass(interp, contextIclsPtr);
|
|||
|
|
}
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiCallInstanceCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked whenever the a script generated by mytypemethod, mymethod or
|
|||
|
|
* myproc is evauated later on:
|
|||
|
|
* Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* callinstance <instanceName> ?arg arg ...?
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
int
|
|||
|
|
Itcl_BiCallInstanceCmd(
|
|||
|
|
void *dummy, /* class definition */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
Tcl_HashEntry *hPtr;
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
Tcl_Obj **newObjv;
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
ItclObject *ioPtr;
|
|||
|
|
const char *token;
|
|||
|
|
int result;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Make sure that this command is being invoked in the proper
|
|||
|
|
* context.
|
|||
|
|
*/
|
|||
|
|
ItclShowArgs(1, "Itcl_BiCallInstanceCmd", objc, objv);
|
|||
|
|
contextIclsPtr = NULL;
|
|||
|
|
if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
if (objc < 2) {
|
|||
|
|
token = Tcl_GetString(objv[0]);
|
|||
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
|||
|
|
"wrong # args: should be \"", token, " <instanceName>",
|
|||
|
|
NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
hPtr = Tcl_FindHashEntry(&contextIclsPtr->infoPtr->instances,
|
|||
|
|
Tcl_GetString(objv[1]));
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
Tcl_AppendResult(interp,
|
|||
|
|
"no such instanceName \"",
|
|||
|
|
Tcl_GetString(objv[1]), "\"", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
ioPtr = (ItclObject *)Tcl_GetHashValue(hPtr);
|
|||
|
|
objPtr =Tcl_NewObj();
|
|||
|
|
Tcl_GetCommandFullName(interp, ioPtr->accessCmd, objPtr);
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * (objc - 1));
|
|||
|
|
newObjv[0] = objPtr;
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2));
|
|||
|
|
result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0);
|
|||
|
|
Tcl_DecrRefCount(newObjv[0]);
|
|||
|
|
ckfree((char *)newObjv);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiGetInstanceVarCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked whenever the a script generated by mytypevar, myvar or
|
|||
|
|
* mycommon is evauated later on:
|
|||
|
|
* Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* getinstancevar <instanceName> ?arg arg ...?
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
int
|
|||
|
|
Itcl_BiGetInstanceVarCmd(
|
|||
|
|
void *dummy, /* class definition */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
Tcl_HashEntry *hPtr;
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
Tcl_Obj **newObjv;
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
ItclObject *ioPtr;
|
|||
|
|
const char *token;
|
|||
|
|
int result;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Make sure that this command is being invoked in the proper
|
|||
|
|
* context.
|
|||
|
|
*/
|
|||
|
|
ItclShowArgs(1, "Itcl_BiGetInstanceVarCmd", objc, objv);
|
|||
|
|
contextIclsPtr = NULL;
|
|||
|
|
if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
if (objc < 2) {
|
|||
|
|
token = Tcl_GetString(objv[0]);
|
|||
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
|||
|
|
"wrong # args: should be \"", token, " <instanceName>",
|
|||
|
|
NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
hPtr = Tcl_FindHashEntry(&contextIclsPtr->infoPtr->instances,
|
|||
|
|
Tcl_GetString(objv[1]));
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
Tcl_AppendResult(interp,
|
|||
|
|
"no such instanceName \"",
|
|||
|
|
Tcl_GetString(objv[1]), "\"", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
ioPtr = (ItclObject *)Tcl_GetHashValue(hPtr);
|
|||
|
|
objPtr = Tcl_NewObj();
|
|||
|
|
Tcl_GetCommandFullName(interp, ioPtr->accessCmd, objPtr);
|
|||
|
|
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * (objc - 1));
|
|||
|
|
newObjv[0] = objPtr;
|
|||
|
|
Tcl_IncrRefCount(newObjv[0]);
|
|||
|
|
memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2));
|
|||
|
|
result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0);
|
|||
|
|
Tcl_DecrRefCount(newObjv[0]);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiMyTypeMethodCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked when a user calls mytypemethod
|
|||
|
|
*
|
|||
|
|
* Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* mytypemethod ?arg arg ...?
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
int
|
|||
|
|
Itcl_BiMyTypeMethodCmd(
|
|||
|
|
void *dummy, /* class definition */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
Tcl_Obj *resultPtr;
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
int i;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Make sure that this command is being invoked in the proper
|
|||
|
|
* context.
|
|||
|
|
*/
|
|||
|
|
ItclShowArgs(1, "Itcl_BiMyTypeMethodCmd", objc, objv);
|
|||
|
|
contextIclsPtr = NULL;
|
|||
|
|
if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
if (objc < 2) {
|
|||
|
|
Tcl_AppendResult(interp, "usage: mytypemethod <name>", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
objPtr = Tcl_NewStringObj(contextIclsPtr->nsPtr->fullName, -1);
|
|||
|
|
resultPtr = Tcl_NewListObj(0, NULL);
|
|||
|
|
Tcl_ListObjAppendElement(interp, resultPtr, objPtr);
|
|||
|
|
|
|||
|
|
for (i = 1; i < objc; i++) {
|
|||
|
|
Tcl_ListObjAppendElement(interp, resultPtr, objv[i]);
|
|||
|
|
}
|
|||
|
|
Tcl_SetObjResult(interp, resultPtr);
|
|||
|
|
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiMyMethodCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked when a user calls mymethod
|
|||
|
|
*
|
|||
|
|
* Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* mymethod ?arg arg ...?
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
int
|
|||
|
|
Itcl_BiMyMethodCmd(
|
|||
|
|
void *dummy, /* class definition */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
Tcl_Obj *resultPtr;
|
|||
|
|
int i;
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Make sure that this command is being invoked in the proper
|
|||
|
|
* context.
|
|||
|
|
*/
|
|||
|
|
ItclShowArgs(1, "Itcl_BiMyMethodCmd", objc, objv);
|
|||
|
|
contextIclsPtr = NULL;
|
|||
|
|
if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
if (contextIoPtr != NULL) {
|
|||
|
|
resultPtr = Tcl_NewListObj(0, NULL);
|
|||
|
|
Tcl_ListObjAppendElement(interp, resultPtr,
|
|||
|
|
Tcl_NewStringObj("::itcl::builtin::callinstance", -1));
|
|||
|
|
Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(
|
|||
|
|
(Tcl_GetObjectNamespace(contextIoPtr->oPtr))->fullName, -1));
|
|||
|
|
for (i = 1; i < objc; i++) {
|
|||
|
|
Tcl_ListObjAppendElement(interp, resultPtr, objv[i]);
|
|||
|
|
}
|
|||
|
|
Tcl_SetObjResult(interp, resultPtr);
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiMyProcCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked when a user calls myproc
|
|||
|
|
*
|
|||
|
|
* Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* myproc ?arg arg ...?
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
int
|
|||
|
|
Itcl_BiMyProcCmd(
|
|||
|
|
void *dummy, /* class definition */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
Tcl_Obj *resultPtr;
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
int i;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Make sure that this command is being invoked in the proper
|
|||
|
|
* context.
|
|||
|
|
*/
|
|||
|
|
ItclShowArgs(1, "Itcl_BiMyProcCmd", objc, objv);
|
|||
|
|
contextIclsPtr = NULL;
|
|||
|
|
if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
if (objc < 2) {
|
|||
|
|
Tcl_AppendResult(interp, "usage: myproc <name>", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
objPtr = Tcl_NewStringObj(contextIclsPtr->nsPtr->fullName, -1);
|
|||
|
|
Tcl_AppendToObj(objPtr, "::", -1);
|
|||
|
|
Tcl_AppendToObj(objPtr, Tcl_GetString(objv[1]), -1);
|
|||
|
|
resultPtr = Tcl_NewListObj(0, NULL);
|
|||
|
|
Tcl_ListObjAppendElement(interp, resultPtr, objPtr);
|
|||
|
|
|
|||
|
|
for (i = 2; i < objc; i++) {
|
|||
|
|
Tcl_ListObjAppendElement(interp, resultPtr, objv[i]);
|
|||
|
|
}
|
|||
|
|
Tcl_SetObjResult(interp, resultPtr);
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiMyTypeVarCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked when a user calls mytypevar
|
|||
|
|
*
|
|||
|
|
* Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* mytypevar ?arg arg ...?
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
int
|
|||
|
|
Itcl_BiMyTypeVarCmd(
|
|||
|
|
void *dummy, /* class definition */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
Tcl_Obj *resultPtr;
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
int i;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Make sure that this command is being invoked in the proper
|
|||
|
|
* context.
|
|||
|
|
*/
|
|||
|
|
ItclShowArgs(1, "Itcl_BiMyTypeVarCmd", objc, objv);
|
|||
|
|
contextIclsPtr = NULL;
|
|||
|
|
if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
if (objc < 2) {
|
|||
|
|
Tcl_AppendResult(interp, "usage: mytypevar <name>", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
objPtr = Tcl_NewStringObj(contextIclsPtr->nsPtr->fullName, -1);
|
|||
|
|
Tcl_AppendToObj(objPtr, "::", -1);
|
|||
|
|
Tcl_AppendToObj(objPtr, Tcl_GetString(objv[1]), -1);
|
|||
|
|
resultPtr = Tcl_NewListObj(0, NULL);
|
|||
|
|
Tcl_ListObjAppendElement(interp, resultPtr, objPtr);
|
|||
|
|
|
|||
|
|
for (i = 2; i < objc; i++) {
|
|||
|
|
Tcl_ListObjAppendElement(interp, resultPtr, objv[i]);
|
|||
|
|
}
|
|||
|
|
Tcl_SetObjResult(interp, resultPtr);
|
|||
|
|
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiMyVarCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked when a user calls myvar
|
|||
|
|
*
|
|||
|
|
* Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* myvar ?arg arg ...?
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
int
|
|||
|
|
Itcl_BiMyVarCmd(
|
|||
|
|
void *dummy, /* class definition */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
Tcl_Obj *resultPtr;
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
(void)dummy;
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Make sure that this command is being invoked in the proper
|
|||
|
|
* context.
|
|||
|
|
*/
|
|||
|
|
ItclShowArgs(1, "Itcl_BiMyVarCmd", objc, objv);
|
|||
|
|
contextIclsPtr = NULL;
|
|||
|
|
if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
if ((contextIoPtr != NULL) && (objc > 1)) {
|
|||
|
|
resultPtr = Tcl_NewStringObj(Tcl_GetString(contextIoPtr->varNsNamePtr),
|
|||
|
|
-1);
|
|||
|
|
Tcl_AppendToObj(resultPtr, "::", -1);
|
|||
|
|
Tcl_AppendToObj(resultPtr, Tcl_GetString(contextIclsPtr->namePtr), -1);
|
|||
|
|
Tcl_AppendToObj(resultPtr, "::", -1);
|
|||
|
|
Tcl_AppendToObj(resultPtr, Tcl_GetString(objv[1]), -1);
|
|||
|
|
Tcl_SetObjResult(interp, resultPtr);
|
|||
|
|
}
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiItclHullCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked when a user calls itcl_hull
|
|||
|
|
*
|
|||
|
|
* Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* itcl_hull ?arg arg ...?
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
/* ARGSUSED */
|
|||
|
|
int
|
|||
|
|
Itcl_BiItclHullCmd(
|
|||
|
|
void *dummy, /* class definition */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
ItclClass *contextIclsPtr;
|
|||
|
|
ItclObject *contextIoPtr;
|
|||
|
|
const char *val;
|
|||
|
|
(void)dummy;
|
|||
|
|
(void)objc;
|
|||
|
|
(void)objv;
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Make sure that this command is being invoked in the proper
|
|||
|
|
* context.
|
|||
|
|
*/
|
|||
|
|
ItclShowArgs(1, "Itcl_BiItclHullCmd", objc, objv);
|
|||
|
|
contextIclsPtr = NULL;
|
|||
|
|
if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
if (contextIoPtr != NULL) {
|
|||
|
|
val = ItclGetInstanceVar(interp, "itcl_hull", NULL,
|
|||
|
|
contextIoPtr, contextIclsPtr);
|
|||
|
|
Tcl_SetObjResult(interp, Tcl_NewStringObj(val, -1));
|
|||
|
|
}
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiCreateHullCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked by Tcl normally during evaluating constructor
|
|||
|
|
* the "createhull" command is invoked to install and setup an
|
|||
|
|
* ::itcl::extendedclass itcl_hull
|
|||
|
|
* for an object. Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* createhull <widget_type> <widget_path> ?-class <widgetClassName>?
|
|||
|
|
* ?<optionName> <optionValue> <optionName> <optionValue> ...?
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
static int
|
|||
|
|
Itcl_BiCreateHullCmd(
|
|||
|
|
void *clientData, /* info for all known objects */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
int result;
|
|||
|
|
ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
|
|||
|
|
|
|||
|
|
ItclShowArgs(1, "Itcl_BiCreateHullCmd", objc, objv);
|
|||
|
|
if (!infoPtr->itclHullCmdsInitted) {
|
|||
|
|
result = Tcl_EvalEx(interp, initHullCmdsScript, -1, 0);
|
|||
|
|
if (result != TCL_OK) {
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
infoPtr->itclHullCmdsInitted = 1;
|
|||
|
|
}
|
|||
|
|
return Tcl_EvalObjv(interp, objc, objv, 0);
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiSetupComponentCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked by Tcl during evaluating constructor whenever
|
|||
|
|
* the "setupcomponent" command is invoked to install and setup an
|
|||
|
|
* ::itcl::extendedclass component
|
|||
|
|
* for an object. Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* setupcomponent <componentName> using <widgetType> <widget_path>
|
|||
|
|
* ?<optionName> <optionValue> <optionName> <optionValue> ...?
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
static int
|
|||
|
|
Itcl_BiSetupComponentCmd(
|
|||
|
|
void *clientData, /* info for all known objects */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
int result;
|
|||
|
|
ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
|
|||
|
|
|
|||
|
|
ItclShowArgs(1, "Itcl_BiSetupComponentCmd", objc, objv);
|
|||
|
|
if (!infoPtr->itclHullCmdsInitted) {
|
|||
|
|
result = Tcl_EvalEx(interp, initHullCmdsScript, -1, 0);
|
|||
|
|
if (result != TCL_OK) {
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
infoPtr->itclHullCmdsInitted = 1;
|
|||
|
|
}
|
|||
|
|
return Tcl_EvalObjv(interp, objc, objv, 0);
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiInitOptionsCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked by Tcl during evaluating constructor whenever
|
|||
|
|
* the "itcl_initoptions" command is invoked to install and setup an
|
|||
|
|
* ::itcl::extendedclass options
|
|||
|
|
* for an object. Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* itcl_initoptions
|
|||
|
|
* ?<optionName> <optionValue> <optionName> <optionValue> ...?
|
|||
|
|
* FIXME !!!! seems no longer been used !!!
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
static int
|
|||
|
|
Itcl_BiInitOptionsCmd(
|
|||
|
|
void *clientData, /* info for all known objects */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
int result;
|
|||
|
|
ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
|
|||
|
|
ItclClass *iclsPtr;
|
|||
|
|
ItclObject *ioPtr;
|
|||
|
|
ItclDelegatedOption *idoptPtr;
|
|||
|
|
ItclOption *ioptPtr;
|
|||
|
|
FOREACH_HASH_DECLS;
|
|||
|
|
|
|||
|
|
/* instead ::itcl::builtin::initoptions in ../library/itclHullCmds.tcl is used !! */
|
|||
|
|
ItclShowArgs(1, "Itcl_BiInitOptionsCmd", objc, objv);
|
|||
|
|
if (!infoPtr->itclHullCmdsInitted) {
|
|||
|
|
result = Tcl_EvalEx(interp, initHullCmdsScript, -1, 0);
|
|||
|
|
if (result != TCL_OK) {
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
infoPtr->itclHullCmdsInitted = 1;
|
|||
|
|
}
|
|||
|
|
result = Tcl_EvalObjv(interp, objc, objv, 0);
|
|||
|
|
iclsPtr = NULL;
|
|||
|
|
if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) {
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
/* first handle delegated options */
|
|||
|
|
FOREACH_HASH_VALUE(idoptPtr, &ioPtr->objectDelegatedOptions) {
|
|||
|
|
fprintf(stderr, "delopt!%s!\n", Tcl_GetString(idoptPtr->namePtr));
|
|||
|
|
}
|
|||
|
|
FOREACH_HASH_VALUE(ioptPtr, &ioPtr->objectOptions) {
|
|||
|
|
fprintf(stderr, "opt!%s!\n", Tcl_GetString(ioptPtr->namePtr));
|
|||
|
|
}
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiKeepComponentOptionCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked by Tcl during evaluating constructor whenever
|
|||
|
|
* the "keepcomponentoption" command is invoked to list the options
|
|||
|
|
* to be kept when and ::itcl::extendedclass component has been setup
|
|||
|
|
* for an object. Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* keepcomponentoption <componentName> <optionName> ?<optionName> ...?
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
static int
|
|||
|
|
Itcl_BiKeepComponentOptionCmd(
|
|||
|
|
void *clientData, /* info for all known objects */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
int result;
|
|||
|
|
ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
|
|||
|
|
|
|||
|
|
ItclShowArgs(1, "Itcl_BiKeepComponentOptionCmd", objc, objv);
|
|||
|
|
if (!infoPtr->itclHullCmdsInitted) {
|
|||
|
|
result = Tcl_EvalEx(interp, initHullCmdsScript, -1, 0);
|
|||
|
|
if (result != TCL_OK) {
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
infoPtr->itclHullCmdsInitted = 1;
|
|||
|
|
}
|
|||
|
|
result = Tcl_EvalObjv(interp, objc, objv, 0);
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
* Itcl_BiIgnoreComponentOptionCmd()
|
|||
|
|
*
|
|||
|
|
* Invoked by Tcl during evaluating constructor whenever
|
|||
|
|
* the "keepcomponentoption" command is invoked to list the options
|
|||
|
|
* to be kept when and ::itcl::extendedclass component has been setup
|
|||
|
|
* for an object. Handles the following syntax:
|
|||
|
|
*
|
|||
|
|
* ignorecomponentoption <componentName> <optionName> ?<optionName> ...?
|
|||
|
|
*
|
|||
|
|
* ------------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
static int
|
|||
|
|
Itcl_BiIgnoreComponentOptionCmd(
|
|||
|
|
void *clientData, /* info for all known objects */
|
|||
|
|
Tcl_Interp *interp, /* current interpreter */
|
|||
|
|
int objc, /* number of arguments */
|
|||
|
|
Tcl_Obj *const objv[]) /* argument objects */
|
|||
|
|
{
|
|||
|
|
Tcl_HashEntry *hPtr;
|
|||
|
|
Tcl_HashEntry *hPtr2;
|
|||
|
|
Tcl_Obj *objPtr;
|
|||
|
|
ItclClass *iclsPtr;
|
|||
|
|
ItclObject *ioPtr;
|
|||
|
|
ItclDelegatedOption *idoPtr;
|
|||
|
|
ItclComponent *icPtr;
|
|||
|
|
const char *val;
|
|||
|
|
int idx;
|
|||
|
|
int isNew;
|
|||
|
|
int result;
|
|||
|
|
ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
|
|||
|
|
|
|||
|
|
ItclShowArgs(0, "Itcl_BiIgnoreComponentOptionCmd", objc, objv);
|
|||
|
|
if (!infoPtr->itclHullCmdsInitted) {
|
|||
|
|
result = Tcl_Eval(interp, initHullCmdsScript);
|
|||
|
|
if (result != TCL_OK) {
|
|||
|
|
return result;
|
|||
|
|
}
|
|||
|
|
infoPtr->itclHullCmdsInitted = 1;
|
|||
|
|
}
|
|||
|
|
iclsPtr = NULL;
|
|||
|
|
if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) {
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
if (objc < 3) {
|
|||
|
|
Tcl_AppendResult(interp, "wrong # args, should be: ",
|
|||
|
|
"ignorecomponentoption component option ?option ...?", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
if (ioPtr != NULL) {
|
|||
|
|
hPtr = Tcl_FindHashEntry(&ioPtr->objectComponents, (char *)objv[1]);
|
|||
|
|
if (hPtr == NULL) {
|
|||
|
|
Tcl_AppendResult(interp,
|
|||
|
|
"ignorecomponentoption cannot find component \"",
|
|||
|
|
Tcl_GetString(objv[1]), "\"", NULL);
|
|||
|
|
return TCL_ERROR;
|
|||
|
|
}
|
|||
|
|
icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr);
|
|||
|
|
icPtr->haveKeptOptions = 1;
|
|||
|
|
for (idx = 2; idx < objc; idx++) {
|
|||
|
|
hPtr = Tcl_CreateHashEntry(&icPtr->keptOptions, (char *)objv[idx],
|
|||
|
|
&isNew);
|
|||
|
|
if (isNew) {
|
|||
|
|
Tcl_SetHashValue(hPtr, objv[idx]);
|
|||
|
|
}
|
|||
|
|
hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectDelegatedOptions,
|
|||
|
|
(char *)objv[idx], &isNew);
|
|||
|
|
if (isNew) {
|
|||
|
|
idoPtr = (ItclDelegatedOption *)ckalloc(sizeof(
|
|||
|
|
ItclDelegatedOption));
|
|||
|
|
memset(idoPtr, 0, sizeof(ItclDelegatedOption));
|
|||
|
|
Tcl_InitObjHashTable(&idoPtr->exceptions);
|
|||
|
|
idoPtr->namePtr = objv[idx];
|
|||
|
|
Tcl_IncrRefCount(idoPtr->namePtr);
|
|||
|
|
idoPtr->resourceNamePtr = NULL;
|
|||
|
|
if (idoPtr->resourceNamePtr != NULL) {
|
|||
|
|
Tcl_IncrRefCount(idoPtr->resourceNamePtr);
|
|||
|
|
}
|
|||
|
|
idoPtr->classNamePtr = NULL;
|
|||
|
|
if (idoPtr->classNamePtr != NULL) {
|
|||
|
|
Tcl_IncrRefCount(idoPtr->classNamePtr);
|
|||
|
|
}
|
|||
|
|
idoPtr->icPtr = icPtr;
|
|||
|
|
idoPtr->ioptPtr = NULL;
|
|||
|
|
Tcl_SetHashValue(hPtr2, idoPtr);
|
|||
|
|
val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr),
|
|||
|
|
NULL, ioPtr, iclsPtr);
|
|||
|
|
if (val != NULL) {
|
|||
|
|
objPtr = Tcl_NewStringObj(val, -1);
|
|||
|
|
Tcl_AppendToObj(objPtr, " cget ", -1);
|
|||
|
|
Tcl_AppendToObj(objPtr, Tcl_GetString(objv[idx]), -1);
|
|||
|
|
Tcl_IncrRefCount(objPtr);
|
|||
|
|
result = Tcl_EvalObjEx(interp, objPtr, 0);
|
|||
|
|
Tcl_DecrRefCount(objPtr);
|
|||
|
|
if (result == TCL_OK) {
|
|||
|
|
ItclSetInstanceVar(interp, "itcl_options",
|
|||
|
|
Tcl_GetString(objv[idx]),
|
|||
|
|
Tcl_GetString(Tcl_GetObjResult(interp)), ioPtr, iclsPtr);
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
ItclAddClassComponentDictInfo(interp, iclsPtr, icPtr);
|
|||
|
|
}
|
|||
|
|
return TCL_OK;
|
|||
|
|
}
|