riscv
/
OpenFPGA
mirror of https://github.com/lnis-uofu/OpenFPGA.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
OpenFPGA/libs/EXTERNAL/tcl8.6.12/pkgs/itcl4.2.2/generic/itclParse.c

4307 lines
133 KiB
C
Raw Normal View History

adding Tcl interface to vpr
2022-06-07 11:15:20 -05:00
/*
* ------------------------------------------------------------------------
* PACKAGE: [incr Tcl]
* DESCRIPTION: Object-Oriented Extensions to Tcl
*
* [incr Tcl] provides object-oriented extensions to Tcl, much as
* C++ provides object-oriented extensions to C. It provides a means
* of encapsulating related procedures together with their shared data
* in a local namespace that is hidden from the outside world. It
* promotes code re-use through inheritance. More than anything else,
* it encourages better organization of Tcl applications through the
* object-oriented paradigm, leading to code that is easier to
* understand and maintain.
*
* Procedures in this file support the new syntax for [incr Tcl]
* class definitions:
*
* itcl_class <className> {
* inherit <base-class>...
*
* constructor {<arglist>} ?{<init>}? {<body>}
* destructor {<body>}
*
* method <name> {<arglist>} {<body>}
* proc <name> {<arglist>} {<body>}
* variable <name> ?<init>? ?<config>?
* common <name> ?<init>?
*
* public <thing> ?<args>...?
* protected <thing> ?<args>...?
* private <thing> ?<args>...?
* }
*
* ========================================================================
* 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 const char initWidgetScript[] =
"namespace eval ::itcl {\n"
" proc _find_widget_init {} {\n"
" global env tcl_library\n"
" variable library\n"
" variable patchLevel\n"
" rename _find_widget_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 itclWidget.tcl]\n"
" if {![catch {uplevel #0 [list source $itclfile]} emsg]} {\n"
" return\n"
" }\n"
" }\n"
" set msg \"Can't find a usable itclWidget.tcl in the following directories:\n\"\n"
" append msg \" $dirs\n\"\n"
" append msg \"Last error:\n\"\n"
" append msg \" $emsg\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_widget_init\n"
"}";
/*
* Info needed for public/protected/private commands:
*/
typedef struct ProtectionCmdInfo {
int pLevel; /* protection level */
ItclObjectInfo *infoPtr; /* info regarding all known objects */
} ProtectionCmdInfo;
/*
* FORWARD DECLARATIONS
*/
static Tcl_CmdDeleteProc ItclFreeParserCommandData;
static void ItclDelObjectInfo(char* cdata);
static int ItclInitClassCommon(Tcl_Interp *interp, ItclClass *iclsPtr,
ItclVariable *ivPtr, const char *initStr);
static Tcl_ObjCmdProc Itcl_ClassTypeVariableCmd;
static Tcl_ObjCmdProc Itcl_ClassTypeMethodCmd;
static Tcl_ObjCmdProc Itcl_ClassFilterCmd;
static Tcl_ObjCmdProc Itcl_ClassMixinCmd;
static Tcl_ObjCmdProc Itcl_WidgetCmd;
static Tcl_ObjCmdProc Itcl_WidgetAdaptorCmd;
static Tcl_ObjCmdProc Itcl_ClassComponentCmd;
static Tcl_ObjCmdProc Itcl_ClassTypeComponentCmd;
static Tcl_ObjCmdProc Itcl_ClassDelegateMethodCmd;
static Tcl_ObjCmdProc Itcl_ClassDelegateOptionCmd;
static Tcl_ObjCmdProc Itcl_ClassDelegateTypeMethodCmd;
static Tcl_ObjCmdProc Itcl_ClassForwardCmd;
static Tcl_ObjCmdProc Itcl_ClassMethodVariableCmd;
static Tcl_ObjCmdProc Itcl_ClassTypeConstructorCmd;
static Tcl_ObjCmdProc ItclGenericClassCmd;
static const struct {
const char *name;
Tcl_ObjCmdProc *objProc;
} parseCmds[] = {
{"common", Itcl_ClassCommonCmd},
{"component", Itcl_ClassComponentCmd},
{"constructor", Itcl_ClassConstructorCmd},
{"destructor", Itcl_ClassDestructorCmd},
{"filter", Itcl_ClassFilterCmd},
{"forward", Itcl_ClassForwardCmd},
{"handleClass", Itcl_HandleClass},
{"hulltype", Itcl_ClassHullTypeCmd},
{"inherit", Itcl_ClassInheritCmd},
{"method", Itcl_ClassMethodCmd},
{"methodvariable", Itcl_ClassMethodVariableCmd},
{"mixin", Itcl_ClassMixinCmd},
{"option", Itcl_ClassOptionCmd},
{"proc", Itcl_ClassProcCmd},
{"typecomponent", Itcl_ClassTypeComponentCmd },
{"typeconstructor", Itcl_ClassTypeConstructorCmd},
{"typemethod", Itcl_ClassTypeMethodCmd},
{"typevariable", Itcl_ClassTypeVariableCmd},
{"variable", Itcl_ClassVariableCmd},
{"widgetclass", Itcl_ClassWidgetClassCmd},
{NULL, NULL}
};
static const struct {
const char *name;
Tcl_ObjCmdProc *objProc;
int protection;
} protectionCmds[] = {
{"private", Itcl_ClassProtectionCmd, ITCL_PRIVATE},
{"protected", Itcl_ClassProtectionCmd, ITCL_PROTECTED},
{"public", Itcl_ClassProtectionCmd, ITCL_PUBLIC},
{NULL, NULL, 0}
};
/*
* ------------------------------------------------------------------------
* Itcl_ParseInit()
*
* Invoked by Itcl_Init() whenever a new interpeter is created to add
* [incr Tcl] facilities. Adds the commands needed to parse class
* definitions.
* ------------------------------------------------------------------------
*/
int
Itcl_ParseInit(
Tcl_Interp *interp, /* interpreter to be updated */
ItclObjectInfo *infoPtr) /* info regarding all known objects and classes */
{
Tcl_Namespace *parserNs;
ProtectionCmdInfo *pInfoPtr;
Tcl_DString buffer;
int i;
/*
* Create the "itcl::parser" namespace used to parse class
* definitions.
*/
parserNs = Tcl_CreateNamespace(interp, "::itcl::parser",
infoPtr, Itcl_ReleaseData);
if (!parserNs) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
" (cannot initialize itcl parser)",
NULL);
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
/*
* Add commands for parsing class definitions.
*/
Tcl_DStringInit(&buffer);
for (i=0 ; parseCmds[i].name ; i++) {
Tcl_DStringAppend(&buffer, "::itcl::parser::", 16);
Tcl_DStringAppend(&buffer, parseCmds[i].name, -1);
Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
parseCmds[i].objProc, infoPtr, NULL);
Tcl_DStringFree(&buffer);
}
for (i=0 ; protectionCmds[i].name ; i++) {
Tcl_DStringAppend(&buffer, "::itcl::parser::", 16);
Tcl_DStringAppend(&buffer, protectionCmds[i].name, -1);
pInfoPtr = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo));
pInfoPtr->pLevel = protectionCmds[i].protection;
pInfoPtr->infoPtr = infoPtr;
Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
protectionCmds[i].objProc, pInfoPtr,
(Tcl_CmdDeleteProc*) ItclFreeParserCommandData);
Tcl_DStringFree(&buffer);
}
/*
* Set the runtime variable resolver for the parser namespace,
* to control access to "common" data members while parsing
* the class definition.
*/
if (infoPtr->useOldResolvers) {
ItclSetParserResolver(parserNs);
}
/*
* Install the "class" command for defining new classes.
*/
Tcl_CreateObjCommand(interp, "::itcl::class", Itcl_ClassCmd,
infoPtr, Itcl_ReleaseData);
Itcl_PreserveData(infoPtr);
Tcl_CreateObjCommand(interp, "::itcl::body", Itcl_BodyCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "::itcl::configbody", Itcl_ConfigBodyCmd,
NULL, NULL);
Itcl_EventuallyFree(infoPtr, (Tcl_FreeProc *) ItclDelObjectInfo);
/*
* Create the "itcl::find" command for high-level queries.
*/
if (Itcl_CreateEnsemble(interp, "::itcl::find") != TCL_OK) {
return TCL_ERROR;
}
if (Itcl_AddEnsemblePart(interp, "::itcl::find",
"classes", "?pattern?",
Itcl_FindClassesCmd,
infoPtr, Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
if (Itcl_AddEnsemblePart(interp, "::itcl::find",
"objects", "?-class className? ?-isa className? ?pattern?",
Itcl_FindObjectsCmd,
infoPtr, Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
/*
* Create the "itcl::delete" command to delete objects
* and classes.
*/
if (Itcl_CreateEnsemble(interp, "::itcl::delete") != TCL_OK) {
return TCL_ERROR;
}
if (Itcl_AddEnsemblePart(interp, "::itcl::delete",
"class", "name ?name...?",
Itcl_DelClassCmd,
infoPtr, Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
if (Itcl_AddEnsemblePart(interp, "::itcl::delete",
"object", "name ?name...?",
Itcl_DelObjectCmd,
infoPtr, Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
if (Itcl_AddEnsemblePart(interp, "::itcl::delete",
"ensemble", "name ?name...?",
Itcl_EnsembleDeleteCmd,
infoPtr, Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
/*
* Create the "itcl::is" command to test object
* and classes existence.
*/
if (Itcl_CreateEnsemble(interp, "::itcl::is") != TCL_OK) {
return TCL_ERROR;
}
if (Itcl_AddEnsemblePart(interp, "::itcl::is",
"class", "name", Itcl_IsClassCmd,
infoPtr, Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
if (Itcl_AddEnsemblePart(interp, "::itcl::is",
"object", "?-class classname? name", Itcl_IsObjectCmd,
infoPtr, Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
/*
* Add "code" and "scope" commands for handling scoped values.
*/
Tcl_CreateObjCommand(interp, "::itcl::code", Itcl_CodeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "::itcl::scope", Itcl_ScopeCmd,
NULL, NULL);
/*
* Add the "filter" commands (add/delete)
*/
if (Itcl_CreateEnsemble(interp, "::itcl::filter") != TCL_OK) {
return TCL_ERROR;
}
if (Itcl_AddEnsemblePart(interp, "::itcl::filter",
"add", "objectOrClass filter ? ... ?", Itcl_FilterAddCmd,
infoPtr, Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
if (Itcl_AddEnsemblePart(interp, "::itcl::filter",
"delete", "objectOrClass filter ? ... ?", Itcl_FilterDeleteCmd,
infoPtr, Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
/*
* Add the "forward" commands (add/delete)
*/
if (Itcl_CreateEnsemble(interp, "::itcl::forward") != TCL_OK) {
return TCL_ERROR;
}
if (Itcl_AddEnsemblePart(interp, "::itcl::forward",
"add", "objectOrClass srcCommand targetCommand ? options ... ?",
Itcl_ForwardAddCmd, infoPtr,
Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
if (Itcl_AddEnsemblePart(interp, "::itcl::forward",
"delete", "objectOrClass targetCommand ? ... ?",
Itcl_ForwardDeleteCmd, infoPtr,
Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
/*
* Add the "mixin" (add/delete) commands.
*/
if (Itcl_CreateEnsemble(interp, "::itcl::mixin") != TCL_OK) {
return TCL_ERROR;
}
if (Itcl_AddEnsemblePart(interp, "::itcl::mixin",
"add", "objectOrClass class ? class ... ?",
Itcl_MixinAddCmd, infoPtr,
Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
if (Itcl_AddEnsemblePart(interp, "::itcl::mixin",
"delete", "objectOrClass class ? class ... ?",
Itcl_MixinDeleteCmd, infoPtr,
Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
/*
* Add commands for handling import stubs at the Tcl level.
*/
if (Itcl_CreateEnsemble(interp, "::itcl::import::stub") != TCL_OK) {
return TCL_ERROR;
}
if (Itcl_AddEnsemblePart(interp, "::itcl::import::stub",
"create", "name", Itcl_StubCreateCmd,
NULL, NULL) != TCL_OK) {
return TCL_ERROR;
}
if (Itcl_AddEnsemblePart(interp, "::itcl::import::stub",
"exists", "name", Itcl_StubExistsCmd,
NULL, NULL) != TCL_OK) {
return TCL_ERROR;
}
Tcl_CreateObjCommand(interp, "::itcl::type", Itcl_TypeClassCmd,
infoPtr, Itcl_ReleaseData);
Itcl_PreserveData(infoPtr);
Tcl_CreateObjCommand(interp, "::itcl::widget", Itcl_WidgetCmd,
infoPtr, Itcl_ReleaseData);
Itcl_PreserveData(infoPtr);
Tcl_CreateObjCommand(interp, "::itcl::widgetadaptor", Itcl_WidgetAdaptorCmd,
infoPtr, Itcl_ReleaseData);
Itcl_PreserveData(infoPtr);
Tcl_CreateObjCommand(interp, "::itcl::nwidget", Itcl_NWidgetCmd,
infoPtr, Itcl_ReleaseData);
Itcl_PreserveData(infoPtr);
Tcl_CreateObjCommand(interp, "::itcl::addoption", Itcl_AddOptionCmd,
infoPtr, Itcl_ReleaseData);
Itcl_PreserveData(infoPtr);
Tcl_CreateObjCommand(interp, "::itcl::addobjectoption",
Itcl_AddObjectOptionCmd,
infoPtr, Itcl_ReleaseData);
Itcl_PreserveData(infoPtr);
Tcl_CreateObjCommand(interp, "::itcl::adddelegatedoption",
Itcl_AddDelegatedOptionCmd,
infoPtr, Itcl_ReleaseData);
Itcl_PreserveData(infoPtr);
Tcl_CreateObjCommand(interp, "::itcl::adddelegatedmethod",
Itcl_AddDelegatedFunctionCmd,
infoPtr, Itcl_ReleaseData);
Itcl_PreserveData(infoPtr);
Tcl_CreateObjCommand(interp, "::itcl::addcomponent", Itcl_AddComponentCmd,
infoPtr, Itcl_ReleaseData);
Itcl_PreserveData(infoPtr);
Tcl_CreateObjCommand(interp, "::itcl::setcomponent", Itcl_SetComponentCmd,
infoPtr, Itcl_ReleaseData);
Itcl_PreserveData(infoPtr);
Tcl_CreateObjCommand(interp, "::itcl::extendedclass", Itcl_ExtendedClassCmd,
infoPtr, Itcl_ReleaseData);
Itcl_PreserveData(infoPtr);
Tcl_CreateObjCommand(interp, ITCL_COMMANDS_NAMESPACE "::genericclass",
ItclGenericClassCmd, infoPtr, Itcl_ReleaseData);
Itcl_PreserveData(infoPtr);
/*
* Add the "delegate" (method/option) commands.
*/
if (Itcl_CreateEnsemble(interp, "::itcl::parser::delegate") != TCL_OK) {
return TCL_ERROR;
}
if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate",
"method", "name to targetName as scipt using script",
Itcl_ClassDelegateMethodCmd, infoPtr,
Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate",
"typemethod", "name to targetName as scipt using script",
Itcl_ClassDelegateTypeMethodCmd, infoPtr,
Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate",
"option", "option to targetOption as script",
Itcl_ClassDelegateOptionCmd, infoPtr,
Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(infoPtr);
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassCmd()
*
* Invoked by Tcl whenever the user issues an "itcl::class" command to
* specify a class definition. Handles the following syntax:
*
* itcl::class <className> {
* inherit <base-class>...
*
* constructor {<arglist>} ?{<init>}? {<body>}
* destructor {<body>}
*
* method <name> {<arglist>} {<body>}
* proc <name> {<arglist>} {<body>}
* variable <varname> ?<init>? ?<config>?
* common <varname> ?<init>?
*
* public <args>...
* protected <args>...
* private <args>...
* }
*
* ------------------------------------------------------------------------
*/
static int
ItclGenericClassCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
Tcl_Obj *namePtr;
Tcl_HashEntry *hPtr;
ItclObjectInfo *infoPtr;
ItclClass *iclsPtr;
ItclComponent *icPtr;
const char *typeStr;
int result;
ItclShowArgs(1, "ItclGenericClassCmd", objc-1, objv);
if (objc != 4) {
Tcl_AppendResult(interp, "usage: genericclass <classtype> <classname> ",
"<body>", NULL);
return TCL_ERROR;
}
infoPtr = (ItclObjectInfo *)clientData;
typeStr = Tcl_GetString(objv[1]);
hPtr = Tcl_FindHashEntry(&infoPtr->classTypes, (char *)objv[1]);
if (hPtr == NULL) {
Tcl_AppendResult(interp, "genericclass bad classtype \"", typeStr,
"\"", NULL);
return TCL_ERROR;
}
result = ItclClassBaseCmd(clientData, interp, PTR2INT(Tcl_GetHashValue(hPtr)),
objc - 1, objv + 1, &iclsPtr);
if (result != TCL_OK) {
return result;
}
if (PTR2INT(Tcl_GetHashValue(hPtr)) == ITCL_WIDGETADAPTOR) {
/* create the itcl_hull variable */
namePtr = Tcl_NewStringObj("itcl_hull", -1);
if (ItclCreateComponent(interp, iclsPtr, namePtr, ITCL_COMMON,
&icPtr) != TCL_OK) {
return TCL_ERROR;
}
iclsPtr->numVariables++;
}
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_GetString(iclsPtr->fullNamePtr), NULL);
return result;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassCmd()
*
* Invoked by Tcl whenever the user issues an "itcl::class" command to
* specify a class definition. Handles the following syntax:
*
* itcl::class <className> {
* inherit <base-class>...
*
* constructor {<arglist>} ?{<init>}? {<body>}
* destructor {<body>}
*
* method <name> {<arglist>} {<body>}
* proc <name> {<arglist>} {<body>}
* variable <varname> ?<init>? ?<config>?
* common <varname> ?<init>?
*
* public <args>...
* protected <args>...
* private <args>...
* }
*
* ------------------------------------------------------------------------
*/
int
Itcl_ClassCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
return ItclClassBaseCmd(clientData, interp, ITCL_CLASS, objc, objv, NULL);
}
/*
* ------------------------------------------------------------------------
* ItclClassBaseCmd()
*
* ------------------------------------------------------------------------
*/
static Tcl_MethodCallProc ObjCallProc;
static Tcl_MethodCallProc ArgCallProc;
static Tcl_CloneProc CloneProc;
static const Tcl_MethodType itclObjMethodType = {
TCL_OO_METHOD_VERSION_CURRENT,
"itcl objv method",
ObjCallProc,
Itcl_ReleaseData,
CloneProc
};
static const Tcl_MethodType itclArgMethodType = {
TCL_OO_METHOD_VERSION_CURRENT,
"itcl argv method",
ArgCallProc,
Itcl_ReleaseData,
CloneProc
};
static int
CloneProc(
Tcl_Interp *dummy,
ClientData original,
ClientData *copyPtr)
{
(void)dummy;
Itcl_PreserveData((ItclMemberFunc *)original);
*copyPtr = original;
return TCL_OK;
}
static int
CallAfterCallMethod(
ClientData data[],
Tcl_Interp *interp,
int result)
{
ClientData clientData = data[0];
Tcl_ObjectContext context = (Tcl_ObjectContext)data[1];
return ItclAfterCallMethod(clientData, interp, context, NULL, result);
}
static int
ObjCallProc(
ClientData clientData,
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
ItclMemberFunc *imPtr = (ItclMemberFunc *)clientData;
if (TCL_ERROR == ItclCheckCallMethod(clientData, interp, context,
NULL, NULL)) {
return TCL_ERROR;
}
Tcl_NRAddCallback(interp, CallAfterCallMethod, clientData, context,
NULL, NULL);
if ((imPtr->flags & ITCL_COMMON) == 0) {
return Itcl_ExecMethod(clientData, interp, objc-1, objv+1);
} else {
return Itcl_ExecProc(clientData, interp, objc-1, objv+1);
}
}
static int
ArgCallProc(
ClientData clientData,
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
(void)clientData;
(void)interp;
(void)context;
(void)objc;
(void)objv;
return TCL_ERROR;
}
int
ItclClassBaseCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int flags, /* flags: ITCL_CLASS, ITCL_TYPE,
* ITCL_WIDGET or ITCL_WIDGETADAPTOR */
int objc, /* number of arguments */
Tcl_Obj *const objv[], /* argument objects */
ItclClass **iclsPtrPtr) /* for returning iclsPtr */
{
Tcl_Obj *argumentPtr;
Tcl_Obj *bodyPtr;
FOREACH_HASH_DECLS;
Tcl_HashEntry *hPtr2;
Tcl_Namespace *parserNs, *ooNs;
Tcl_CallFrame frame;
ItclClass *iclsPtr;
ItclVariable *ivPtr;
ItclObjectInfo* infoPtr;
char *className;
int isNewEntry;
int result;
int noCleanup;
ItclMemberFunc *imPtr;
infoPtr = (ItclObjectInfo*)clientData;
if (iclsPtrPtr != NULL) {
*iclsPtrPtr = NULL;
}
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "name { definition }");
return TCL_ERROR;
}
ItclShowArgs(1, "ItclClassBaseCmd", objc, objv);
className = Tcl_GetString(objv[1]);
noCleanup = 0;
/*
* Find the namespace to use as a parser for the class definition.
* If for some reason it is destroyed, bail out here.
*/
parserNs = Tcl_FindNamespace(interp, "::itcl::parser",
NULL, TCL_LEAVE_ERR_MSG);
if (parserNs == NULL) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (while parsing class definition for \"%s\")",
className));
return TCL_ERROR;
}
/*
* Try to create the specified class and its namespace.
*/
/* need the workaround with infoPtr->currClassFlags to keep the stubs
* call interface compatible!
*/
infoPtr->currClassFlags = flags;
if (Itcl_CreateClass(interp, className, infoPtr, &iclsPtr) != TCL_OK) {
infoPtr->currClassFlags = 0;
return TCL_ERROR;
}
infoPtr->currClassFlags = 0;
iclsPtr->flags = flags;
/*
* Import the built-in commands from the itcl::builtin namespace.
* Do this before parsing the class definition, so methods/procs
* can override the built-in commands.
*/
result = Tcl_Import(interp, iclsPtr->nsPtr, "::itcl::builtin::*",
/* allowOverwrite */ 1);
ooNs = Tcl_GetObjectNamespace(iclsPtr->oPtr);
if ( result == TCL_OK && ooNs != iclsPtr->nsPtr) {
result = Tcl_Import(interp, ooNs, "::itcl::builtin::*", 1);
}
if (result != TCL_OK) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (while installing built-in commands for class \"%s\")",
className));
goto errorReturn;
}
/*
* Push this class onto the class definition stack so that it
* becomes the current context for all commands in the parser.
* Activate the parser and evaluate the class definition.
*/
Itcl_PushStack(iclsPtr, &infoPtr->clsStack);
result = Itcl_PushCallFrame(interp, &frame, parserNs,
/* isProcCallFrame */ 0);
Itcl_SetCallFrameResolver(interp, iclsPtr->resolvePtr);
if (result == TCL_OK) {
result = Tcl_EvalObjEx(interp, objv[2], 0);
Itcl_PopCallFrame(interp);
}
Itcl_PopStack(&infoPtr->clsStack);
noCleanup = 0;
if (result != TCL_OK) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, result);
Tcl_Obj *key = Tcl_NewStringObj("-errorline", -1);
Tcl_Obj *stackTrace = NULL;
Tcl_IncrRefCount(key);
Tcl_DictObjGet(NULL, options, key, &stackTrace);
Tcl_DecrRefCount(key);
if (stackTrace == NULL) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n error while parsing class \"%s\" body %s",
className, Tcl_GetString(objv[2])));
noCleanup = 1;
} else {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (class \"%s\" body line %s)",
className, Tcl_GetString(stackTrace)));
}
Tcl_DecrRefCount(options);
result = TCL_ERROR;
goto errorReturn;
}
if (Itcl_FirstListElem(&iclsPtr->bases) == NULL) {
/* No [inherit]. Use default inheritance root. */
Tcl_Obj *cmdPtr = Tcl_NewListObj(4, NULL);
Tcl_ListObjAppendElement(NULL, cmdPtr,
Tcl_NewStringObj("::oo::define", -1));
Tcl_ListObjAppendElement(NULL, cmdPtr, iclsPtr->fullNamePtr);
Tcl_ListObjAppendElement(NULL, cmdPtr,
Tcl_NewStringObj("superclass", -1));
Tcl_ListObjAppendElement(NULL, cmdPtr,
Tcl_NewStringObj("::itcl::Root", -1));
Tcl_IncrRefCount(cmdPtr);
result = Tcl_EvalObjEx(interp, cmdPtr, 0);
Tcl_DecrRefCount(cmdPtr);
if (result == TCL_ERROR) {
goto errorReturn;
}
}
/*
* At this point, parsing of the class definition has succeeded.
* Add built-in methods such as "configure" and "cget"--as long
* as they don't conflict with those defined in the class.
*/
if (Itcl_InstallBiMethods(interp, iclsPtr) != TCL_OK) {
result = TCL_ERROR;
goto errorReturn;
}
/*
* Build the name resolution tables for all data members.
*/
Itcl_BuildVirtualTables(iclsPtr);
/* make the methods and procs known to TclOO */
FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) {
ClientData pmPtr;
argumentPtr = imPtr->codePtr->argumentPtr;
bodyPtr = imPtr->codePtr->bodyPtr;
if (imPtr->codePtr->flags & ITCL_IMPLEMENT_OBJCMD) {
/* Implementation of this member is coded in C expecting Tcl_Obj */
imPtr->tmPtr = Tcl_NewMethod(interp, iclsPtr->clsPtr, imPtr->namePtr,
1, &itclObjMethodType, imPtr);
Itcl_PreserveData(imPtr);
if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
imPtr->tmPtr = Tcl_NewInstanceMethod(interp, iclsPtr->oPtr,
imPtr->namePtr, 1, &itclObjMethodType, imPtr);
Itcl_PreserveData(imPtr);
}
} else if (imPtr->codePtr->flags & ITCL_IMPLEMENT_ARGCMD) {
/* Implementation of this member is coded in C expecting (char *) */
imPtr->tmPtr = Tcl_NewMethod(interp, iclsPtr->clsPtr, imPtr->namePtr,
1, &itclArgMethodType, imPtr);
Itcl_PreserveData(imPtr);
} else {
if (imPtr->codePtr->flags & ITCL_BUILTIN) {
int isDone;
isDone = 0;
if (imPtr->builtinArgumentPtr == NULL) {
/* FIXME next lines are possibly a MEMORY leak not really sure!! */
argumentPtr = Tcl_NewStringObj("args", -1);
imPtr->builtinArgumentPtr = argumentPtr;
Tcl_IncrRefCount(imPtr->builtinArgumentPtr);
} else {
argumentPtr = imPtr->builtinArgumentPtr;
}
bodyPtr = Tcl_NewStringObj("return [", -1);
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-cget") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::cget", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-configure") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::configure", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-isa") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::isa", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-createhull") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::createhull", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-keepcomponentoption") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::keepcomponentoption", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-ignorecomponentoption") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::ignorercomponentoption", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-renamecomponentoption") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::renamecomponentoption", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-keepoptioncomponent") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::keepoptioncomponent", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-ignoreoptioncomponent") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::ignoreoptioncomponent", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-renameoptioncomponent") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::renameoptioncomponent", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-setupcomponent") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::setupcomponent", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-initoptions") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::initoptions", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-getinstancevar") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::getinstancevar",
-1);
isDone = 1;
}
if (iclsPtr->flags &
(ITCL_TYPE|ITCL_WIDGETADAPTOR|
ITCL_WIDGET|ITCL_ECLASS)) {
/* now the builtin stuff for snit functionality */
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-mytypemethod") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::mytypemethod",
-1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-mymethod") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::mymethod", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-myvar") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::myvar", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-mytypevar") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::mytypevar", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-itcl_hull") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::itcl_hull", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-callinstance") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::callinstance",
-1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-myproc") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::myproc", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-installhull") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::installhull",
-1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-installcomponent") == 0) {
Tcl_AppendToObj(bodyPtr,
"::itcl::builtin::installcomponent", -1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-classunknown") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::classunknown",
-1);
isDone = 1;
}
if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-destroy") == 0) {
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::destroy", -1);
isDone = 1;
}
}
if (strncmp(Tcl_GetString(imPtr->codePtr->bodyPtr),
"@itcl-builtin-setget", 20) == 0) {
char *cp = Tcl_GetString(imPtr->codePtr->bodyPtr)+20;
Tcl_AppendToObj(bodyPtr, "::itcl::builtin::setget ", -1);
Tcl_AppendToObj(bodyPtr, cp, -1);
Tcl_AppendToObj(bodyPtr, " ", 1);
isDone = 1;
}
if (!isDone) {
Tcl_AppendToObj(bodyPtr,
Tcl_GetString(imPtr->codePtr->bodyPtr), -1);
}
Tcl_AppendToObj(bodyPtr, " {*}$args]", -1);
}
imPtr->tmPtr = Itcl_NewProcClassMethod(interp,
iclsPtr->clsPtr, ItclCheckCallMethod, ItclAfterCallMethod,
ItclProcErrorProc, imPtr, imPtr->namePtr, argumentPtr,
bodyPtr, &pmPtr);
hPtr2 = Tcl_CreateHashEntry(&iclsPtr->infoPtr->procMethods,
(char *)imPtr->tmPtr, &isNewEntry);
if (isNewEntry) {
Tcl_SetHashValue(hPtr2, imPtr);
}
if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
if (argumentPtr == NULL) {
argumentPtr = iclsPtr->infoPtr->typeDestructorArgumentPtr;
imPtr->codePtr->argumentPtr = argumentPtr;
Tcl_IncrRefCount(argumentPtr);
}
/*
* We're overwriting the tmPtr field, so yank out the
* entry in the procMethods map based on the old one.
*/
if (isNewEntry) {
Tcl_DeleteHashEntry(hPtr2);
}
imPtr->tmPtr = Itcl_NewProcMethod(interp,
iclsPtr->oPtr, ItclCheckCallMethod, ItclAfterCallMethod,
ItclProcErrorProc, imPtr, imPtr->namePtr, argumentPtr,
bodyPtr, &pmPtr);
}
}
if ((imPtr->flags & ITCL_COMMON) == 0) {
imPtr->accessCmd = Tcl_CreateObjCommand(interp,
Tcl_GetString(imPtr->fullNamePtr),
Itcl_ExecMethod, imPtr, Itcl_ReleaseData);
Itcl_PreserveData(imPtr);
} else {
imPtr->accessCmd = Tcl_CreateObjCommand(interp,
Tcl_GetString(imPtr->fullNamePtr),
Itcl_ExecProc, imPtr, Itcl_ReleaseData);
Itcl_PreserveData(imPtr);
}
}
if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
/* initialize the typecomponents and typevariables */
if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr,
/*isProcCallFrame*/0) != TCL_OK) {
result = TCL_ERROR;
goto errorReturn;
}
FOREACH_HASH_VALUE(ivPtr, &iclsPtr->variables) {
if ((ivPtr->flags & ITCL_COMMON) && (ivPtr->init != NULL)) {
if (Tcl_SetVar2(interp, Tcl_GetString(ivPtr->namePtr), NULL,
Tcl_GetString(ivPtr->init),
TCL_NAMESPACE_ONLY) == NULL) {
Itcl_PopCallFrame(interp);
result = TCL_ERROR;
goto errorReturn;
}
}
}
Itcl_PopCallFrame(interp);
}
if (iclsPtr->typeConstructorPtr != NULL) {
/* call the typeconstructor body */
if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr,
/*isProcCallFrame*/0) != TCL_OK) {
result = TCL_ERROR;
goto errorReturn;
}
result = Tcl_EvalObjEx(interp, iclsPtr->typeConstructorPtr,
TCL_EVAL_DIRECT);
Itcl_PopCallFrame(interp);
if (result != TCL_OK) {
goto errorReturn;
}
}
result = TCL_OK;
if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
if (ItclCheckForInitializedComponents(interp, iclsPtr, NULL) !=
TCL_OK) {
result = TCL_ERROR;
goto errorReturn;
}
}
if (result == TCL_OK) {
Tcl_ResetResult(interp);
}
if (iclsPtrPtr != NULL) {
*iclsPtrPtr = iclsPtr;
}
ItclAddClassesDictInfo(interp, iclsPtr);
return result;
errorReturn:
if (!noCleanup) {
Tcl_DeleteNamespace(iclsPtr->nsPtr);
}
return result;
}
/*
* ------------------------------------------------------------------------
* ItclCheckForInitializedComponents()
*
* check if all components for delegation exist and are initialized
* ------------------------------------------------------------------------
*/
int
ItclCheckForInitializedComponents(
Tcl_Interp *interp,
ItclClass *iclsPtr,
ItclObject *ioPtr)
{
FOREACH_HASH_DECLS;
Tcl_CallFrame frame;
Tcl_DString buffer;
ItclDelegatedFunction *idmPtr;
int result;
int doCheck;
result = TCL_OK;
/* check if the typecomponents are initialized */
if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr,
/*isProcCallFrame*/0) != TCL_OK) {
return TCL_ERROR;
}
idmPtr = NULL;
FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) {
const char *val;
/* check here for delegated typemethods only
* rest is done in ItclCreateObject
*/
doCheck = 1;
if (ioPtr == NULL) {
if (!(idmPtr->flags & ITCL_TYPE_METHOD)) {
doCheck = 0;
ioPtr = iclsPtr->infoPtr->currIoPtr;
}
}
if (doCheck) {
if (idmPtr->icPtr != NULL) {
if (idmPtr->icPtr->ivPtr->flags & ITCL_COMMON) {
Tcl_Obj *objPtr;
objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, -1);
Tcl_AppendToObj(objPtr, (Tcl_GetObjectNamespace(
idmPtr->icPtr->ivPtr->iclsPtr->oPtr))->fullName,
-1);
Tcl_AppendToObj(objPtr, "::", -1);
Tcl_AppendToObj(objPtr, Tcl_GetString(
idmPtr->icPtr->ivPtr->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 ((ioPtr != NULL) && ((val != NULL) && (strlen(val) == 0))) {
val = ItclGetInstanceVar(
ioPtr->iclsPtr->interp,
"itcl_hull", NULL, ioPtr,
iclsPtr);
}
if ((val == NULL) || (strlen(val) == 0)) {
if (iclsPtr->flags & ITCL_WIDGETADAPTOR) {
if (strcmp (Tcl_GetString(idmPtr->icPtr->namePtr),
"itcl_hull") == 0) {
/* maybe that will be initialized in constructor
* later on */
continue;
}
}
result = TCL_ERROR;
break;
}
}
}
}
Itcl_PopCallFrame(interp);
if (result == TCL_ERROR) {
const char *startStr;
const char *sepStr;
const char *objectStr;
startStr = "";
sepStr = "";
objectStr = "";
if (ioPtr != NULL) {
sepStr = " ";
objectStr = Tcl_GetString(ioPtr->origNamePtr);
}
if (idmPtr->flags & ITCL_TYPE_METHOD) {
startStr = "type";
}
/* FIXME there somtimes is a message for widgetadaptor:
* can't read "itcl_hull": no such variable
* have to check why
*/
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_GetString(iclsPtr->fullNamePtr),
sepStr, objectStr, " delegates ", startStr, "method \"",
Tcl_GetString(idmPtr->namePtr),
"\" to undefined ", startStr, "component \"",
Tcl_GetString(idmPtr->icPtr->ivPtr->namePtr), "\"", NULL);
}
return result;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassInheritCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "inherit" command is invoked to define one or more base classes.
* Handles the following syntax:
*
* inherit <baseclass> ?<baseclass>...?
*
* ------------------------------------------------------------------------
*/
int
Itcl_ClassInheritCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
int result;
int i;
int newEntry;
int haveClasses;
const char *token;
Itcl_ListElem *elem;
Itcl_ListElem *elem2;
ItclClass *cdPtr;
ItclClass *baseClsPtr;
ItclClass *badCdPtr;
ItclHierIter hier;
Itcl_Stack stack;
Tcl_CallFrame frame;
Tcl_DString buffer;
ItclShowArgs(2, "Itcl_InheritCmd", objc, objv);
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "class ?class...?");
return TCL_ERROR;
}
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::inherit called from",
" not within a class", NULL);
return TCL_ERROR;
}
/*
* An "inherit" statement can only be included once in a
* class definition.
*/
elem = Itcl_FirstListElem(&iclsPtr->bases);
if (elem != NULL) {
Tcl_AppendToObj(Tcl_GetObjResult(interp), "inheritance \"", -1);
while (elem) {
cdPtr = (ItclClass*)Itcl_GetListValue(elem);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
Tcl_GetString(cdPtr->namePtr), " ", NULL);
elem = Itcl_NextListElem(elem);
}
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"\" already defined for class \"",
Tcl_GetString(iclsPtr->fullNamePtr), "\"",
NULL);
return TCL_ERROR;
}
/*
* Validate each base class and add it to the "bases" list.
*/
result = Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr->parentPtr,
/* isProcCallFrame */ 0);
if (result != TCL_OK) {
return TCL_ERROR;
}
for (objc--,objv++; objc > 0; objc--,objv++) {
/*
* Make sure that the base class name is known in the
* parent namespace (currently active). If not, try
* to autoload its definition.
*/
token = Tcl_GetString(*objv);
baseClsPtr = Itcl_FindClass(interp, token, /* autoload */ 1);
if (!baseClsPtr) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
int errlen;
char *errmsg;
Tcl_IncrRefCount(resultPtr);
errmsg = Tcl_GetStringFromObj(resultPtr, &errlen);
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot inherit from \"", token, "\"",
NULL);
if (errlen > 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
" (", errmsg, ")", NULL);
}
Tcl_DecrRefCount(resultPtr);
goto inheritError;
}
/*
* Make sure that the base class is not the same as the
* class that is being built.
*/
if (baseClsPtr == iclsPtr) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"class \"", Tcl_GetString(iclsPtr->namePtr),
"\" cannot inherit from itself",
NULL);
goto inheritError;
}
Itcl_AppendList(&iclsPtr->bases, baseClsPtr);
ItclPreserveClass(baseClsPtr);
}
/*
* Scan through the inheritance list to make sure that no
* class appears twice.
*/
elem = Itcl_FirstListElem(&iclsPtr->bases);
while (elem) {
elem2 = Itcl_NextListElem(elem);
while (elem2) {
if (Itcl_GetListValue(elem) == Itcl_GetListValue(elem2)) {
cdPtr = (ItclClass*)Itcl_GetListValue(elem);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"class \"", iclsPtr->fullNamePtr,
"\" cannot inherit base class \"",
cdPtr->fullNamePtr, "\" more than once",
NULL);
goto inheritError;
}
elem2 = Itcl_NextListElem(elem2);
}
elem = Itcl_NextListElem(elem);
}
/*
* Add each base class and all of its base classes into
* the heritage for the current class. Along the way, make
* sure that no class appears twice in the heritage.
*/
Itcl_InitHierIter(&hier, iclsPtr);
cdPtr = Itcl_AdvanceHierIter(&hier); /* skip the class itself */
cdPtr = Itcl_AdvanceHierIter(&hier);
while (cdPtr != NULL) {
(void) Tcl_CreateHashEntry(&iclsPtr->heritage,
(char*)cdPtr, &newEntry);
if (!newEntry) {
break;
}
cdPtr = Itcl_AdvanceHierIter(&hier);
}
Itcl_DeleteHierIter(&hier);
/*
* Same base class found twice in the hierarchy?
* Then flag error. Show the list of multiple paths
* leading to the same base class.
*/
if (!newEntry) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
badCdPtr = cdPtr;
Tcl_AppendStringsToObj(resultPtr,
"class \"", Tcl_GetString(iclsPtr->fullNamePtr),
"\" inherits base class \"",
Tcl_GetString(badCdPtr->fullNamePtr), "\" more than once:",
NULL);
cdPtr = iclsPtr;
Itcl_InitStack(&stack);
Itcl_PushStack(cdPtr, &stack);
/*
* Show paths leading to bad base class
*/
while (Itcl_GetStackSize(&stack) > 0) {
cdPtr = (ItclClass*)Itcl_PopStack(&stack);
if (cdPtr == badCdPtr) {
Tcl_AppendToObj(resultPtr, "\n ", -1);
for (i=0; i < Itcl_GetStackSize(&stack); i++) {
if (Itcl_GetStackValue(&stack, i) == NULL) {
cdPtr = (ItclClass*)Itcl_GetStackValue(&stack, i-1);
Tcl_AppendStringsToObj(resultPtr,
Tcl_GetString(cdPtr->namePtr), "->",
NULL);
}
}
Tcl_AppendToObj(resultPtr,
Tcl_GetString(badCdPtr->namePtr), -1);
}
else if (!cdPtr) {
(void)Itcl_PopStack(&stack);
}
else {
elem = Itcl_LastListElem(&cdPtr->bases);
if (elem) {
Itcl_PushStack(cdPtr, &stack);
Itcl_PushStack(NULL, &stack);
while (elem) {
Itcl_PushStack(Itcl_GetListValue(elem), &stack);
elem = Itcl_PrevListElem(elem);
}
}
}
}
Itcl_DeleteStack(&stack);
goto inheritError;
}
/*
* At this point, everything looks good.
* Finish the installation of the base classes. Update
* each base class to recognize the current class as a
* derived class.
*/
Tcl_DStringInit(&buffer);
haveClasses = 0;
elem = Itcl_FirstListElem(&iclsPtr->bases);
Tcl_DStringAppend(&buffer, "::oo::define ", -1);
Tcl_DStringAppend(&buffer, Tcl_GetString(iclsPtr->fullNamePtr), -1);
Tcl_DStringAppend(&buffer, " superclass", -1);
while (elem) {
baseClsPtr = (ItclClass*)Itcl_GetListValue(elem);
haveClasses++;
Tcl_DStringAppend(&buffer, " ", -1);
Tcl_DStringAppend(&buffer, Tcl_GetString(baseClsPtr->fullNamePtr), -1);
Itcl_AppendList(&baseClsPtr->derived, iclsPtr);
ItclPreserveClass(iclsPtr);
elem = Itcl_NextListElem(elem);
}
Itcl_PopCallFrame(interp);
if (haveClasses) {
result = Tcl_EvalEx(interp, Tcl_DStringValue(&buffer), -1, 0);
}
Tcl_DStringFree(&buffer);
Itcl_BuildVirtualTables(iclsPtr);
return result;
/*
* If the "inherit" list cannot be built properly, tear it
* down and return an error.
*/
inheritError:
Itcl_PopCallFrame(interp);
elem = Itcl_FirstListElem(&iclsPtr->bases);
while (elem) {
ItclReleaseClass( (ItclClass *)Itcl_GetListValue(elem) );
elem = Itcl_DeleteListElem(elem);
}
return TCL_ERROR;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassProtectionCmd()
*
* Invoked by Tcl whenever the user issues a protection setting
* command like "public" or "private". Creates commands and
* variables, and assigns a protection level to them. Protection
* levels are defined as follows:
*
* public => accessible from any namespace
* protected => accessible from selected namespaces
* private => accessible only in the namespace where it was defined
*
* Handles the following syntax:
*
* public <command> ?<arg> <arg>...?
*
* Returns TCL_OK/TCL_ERROR to indicate success/failure.
* ------------------------------------------------------------------------
*/
int
Itcl_ClassProtectionCmd(
ClientData clientData, /* protection level (public/protected/private) */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
ProtectionCmdInfo *pInfo = (ProtectionCmdInfo*)clientData;
int result;
int oldLevel;
ItclShowArgs(2, "Itcl_ClassProtectionCmd", objc, objv);
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg arg...?");
return TCL_ERROR;
}
oldLevel = Itcl_Protection(interp, pInfo->pLevel);
if (objc == 2) {
/* something like: public { variable a; variable b } */
result = Tcl_EvalObjEx(interp, objv[1], 0);
} else {
/* something like: public variable a 123 456 */
result = Itcl_EvalArgs(interp, objc-1, objv+1);
}
if (result == TCL_BREAK) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("invoked \"break\" outside of a loop",
-1));
result = TCL_ERROR;
} else {
if (result == TCL_CONTINUE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("invoked \"continue\" outside of a loop",
-1));
result = TCL_ERROR;
} else {
if (result != TCL_OK) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, result);
Tcl_Obj *key = Tcl_NewStringObj("-errorline", -1);
Tcl_Obj *stackTrace = NULL;
Tcl_IncrRefCount(key);
Tcl_DictObjGet(NULL, options, key, &stackTrace);
Tcl_DecrRefCount(key);
if (stackTrace == NULL) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n error while parsing class \"%s\"",
Tcl_GetString(objv[0])));
} else {
char *token = Tcl_GetString(objv[0]);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (%.100s body line %s)",
token, Tcl_GetString(stackTrace)));
}
}
}
}
Itcl_Protection(interp, oldLevel);
return result;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassConstructorCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "constructor" command is invoked to define the constructor
* for an object. Handles the following syntax:
*
* constructor <arglist> ?<init>? <body>
*
* ------------------------------------------------------------------------
*/
int
Itcl_ClassConstructorCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
Tcl_Obj *namePtr;
char *arglist;
char *body;
ItclShowArgs(2, "Itcl_ClassConstructorCmd", objc, objv);
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "args ?init? body");
return TCL_ERROR;
}
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::constructor called from",
" not within a class", NULL);
return TCL_ERROR;
}
namePtr = objv[0];
if (Tcl_FindHashEntry(&iclsPtr->functions, (char *)objv[0])) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"\"", Tcl_GetString(namePtr), "\" already defined in class \"",
Tcl_GetString(iclsPtr->fullNamePtr), "\"",
NULL);
return TCL_ERROR;
}
/*
* If there is an object initialization statement, pick this
* out and take the last argument as the constructor body.
*/
arglist = Tcl_GetString(objv[1]);
if (objc == 3) {
body = Tcl_GetString(objv[2]);
} else {
iclsPtr->initCode = objv[2];
Tcl_IncrRefCount(iclsPtr->initCode);
body = Tcl_GetString(objv[3]);
}
if (Itcl_CreateMethod(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassDestructorCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "destructor" command is invoked to define the destructor
* for an object. Handles the following syntax:
*
* destructor <body>
*
* ------------------------------------------------------------------------
*/
int
Itcl_ClassDestructorCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
Tcl_Obj *namePtr;
char *body;
ItclShowArgs(2, "Itcl_ClassDestructorCmd", objc, objv);
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "body");
return TCL_ERROR;
}
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::destructor called from",
" not within a class", NULL);
return TCL_ERROR;
}
namePtr = objv[0];
body = Tcl_GetString(objv[1]);
if (Tcl_FindHashEntry(&iclsPtr->functions, (char *)namePtr)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"\"", Tcl_GetString(namePtr), "\" already defined in class \"",
Tcl_GetString(iclsPtr->fullNamePtr), "\"",
NULL);
return TCL_ERROR;
}
if (Itcl_CreateMethod(interp, iclsPtr, namePtr, NULL, body)
!= TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassMethodCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "method" command is invoked to define an object method.
* Handles the following syntax:
*
* method <name> ?<arglist>? ?<body>?
*
* ------------------------------------------------------------------------
*/
int
Itcl_ClassMethodCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
Tcl_Obj *namePtr;
Tcl_HashEntry *hPtr;
ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
char *arglist;
char *body;
ItclShowArgs(2, "Itcl_ClassMethodCmd", objc, objv);
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?");
return TCL_ERROR;
}
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::method called from",
" not within a class", NULL);
return TCL_ERROR;
}
namePtr = objv[1];
hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *)objv[1]);
if (hPtr != NULL) {
Tcl_AppendResult(interp, "method \"", Tcl_GetString(namePtr),
"\" has been delegated", NULL);
return TCL_ERROR;
}
arglist = NULL;
body = NULL;
if (objc >= 3) {
arglist = Tcl_GetString(objv[2]);
}
if (objc >= 4) {
body = Tcl_GetString(objv[3]);
}
if (Itcl_CreateMethod(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassProcCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "proc" command is invoked to define a common class proc.
* A "proc" is like a "method", but only has access to "common"
* class variables. Handles the following syntax:
*
* proc <name> ?<arglist>? ?<body>?
*
* ------------------------------------------------------------------------
*/
int
Itcl_ClassProcCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
FOREACH_HASH_DECLS;
Tcl_Obj *namePtr;
ItclObjectInfo *infoPtr;
ItclClass *iclsPtr;
ItclDelegatedFunction *idmPtr;
char *arglist;
char *body;
ItclShowArgs(1, "Itcl_ClassProcCmd", objc, objv);
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?");
return TCL_ERROR;
}
infoPtr = (ItclObjectInfo*)clientData;
iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
namePtr = objv[1];
arglist = NULL;
body = NULL;
if (objc >= 3) {
arglist = Tcl_GetString(objv[2]);
}
if (objc >= 4) {
body = Tcl_GetString(objv[3]);
}
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::proc called from",
" not within a class", NULL);
return TCL_ERROR;
}
if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
const char *name = Tcl_GetString(namePtr);
/* check if the typemethod is already delegated */
FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) {
if (strcmp(Tcl_GetString(idmPtr->namePtr), name) == 0) {
Tcl_AppendResult(interp, "Error in \"typemethod ", name,
"...\", \"", name, "\" has been delegated", NULL);
return TCL_ERROR;
}
}
}
if (Itcl_CreateProc(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassTypeMethodCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "proc" command is invoked to define a common class proc.
* A "proc" is like a "method", but only has access to "common"
* class variables. Handles the following syntax:
*
* typemethod <name> ?<arglist>? ?<body>?
*
* ------------------------------------------------------------------------
*/
static int
Itcl_ClassTypeMethodCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
FOREACH_HASH_DECLS;
Tcl_Obj *namePtr;
ItclObjectInfo *infoPtr;
ItclClass *iclsPtr;
ItclDelegatedFunction *idmPtr;
char *arglist;
char *body;
ItclMemberFunc *imPtr;
ItclShowArgs(1, "Itcl_ClassTypeMethodCmd", objc, objv);
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?");
return TCL_ERROR;
}
infoPtr = (ItclObjectInfo*)clientData;
iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::typemethod called from",
" not within a class", NULL);
return TCL_ERROR;
}
namePtr = objv[1];
arglist = NULL;
body = NULL;
if (objc >= 3) {
arglist = Tcl_GetString(objv[2]);
}
if (objc >= 4) {
body = Tcl_GetString(objv[3]);
}
if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
const char *name = Tcl_GetString(namePtr);
/* check if the typemethod is already delegated */
FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) {
if (strcmp(Tcl_GetString(idmPtr->namePtr), name) == 0) {
Tcl_AppendResult(interp, "Error in \"typemethod ", name,
"...\", \"", name, "\" has been delegated", NULL);
return TCL_ERROR;
}
}
}
iclsPtr->infoPtr->functionFlags = ITCL_TYPE_METHOD;
if (Itcl_CreateProc(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) {
iclsPtr->infoPtr->functionFlags = 0;
return TCL_ERROR;
}
iclsPtr->infoPtr->functionFlags = 0;
hPtr = Tcl_FindHashEntry(&iclsPtr->functions, (char *)namePtr);
imPtr = (ItclMemberFunc *)Tcl_GetHashValue(hPtr);
imPtr->flags |= ITCL_TYPE_METHOD;
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassVariableCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "variable" command is invoked to define an instance variable.
* Handles the following syntax:
*
* variable <varname> ?<init>? ?<config>?
*
* ------------------------------------------------------------------------
*/
int
Itcl_ClassVariableCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
Tcl_Obj *namePtr;
ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
ItclVariable *ivPtr;
char *init;
char *config;
char *arrayInitStr;
const char *usageStr;
int pLevel;
int haveError;
int haveArrayInit;
int result;
result = TCL_OK;
haveError = 0;
haveArrayInit = 0;
usageStr = NULL;
arrayInitStr = NULL;
ItclShowArgs(1, "Itcl_ClassVariableCmd", objc, objv);
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::variable called from",
" not within a class", NULL);
return TCL_ERROR;
}
pLevel = Itcl_Protection(interp, 0);
if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
if (objc > 2) {
if (strcmp(Tcl_GetString(objv[2]), "-array") == 0) {
if (objc == 4) {
arrayInitStr = Tcl_GetString(objv[3]);
haveArrayInit = 1;
} else {
haveError = 1;
usageStr = "varname ?init|-array init?";
}
}
}
}
if (!haveError && !haveArrayInit) {
if (pLevel == ITCL_PUBLIC) {
if (objc < 2 || objc > 4) {
usageStr = "name ?init? ?config?";
haveError = 1;
}
} else {
if ((objc < 2) || (objc > 3)) {
usageStr = "name ?init?";
haveError = 1;
}
}
}
if (haveError) {
Tcl_WrongNumArgs(interp, 1, objv, usageStr);
return TCL_ERROR;
}
/*
* Make sure that the variable name does not contain anything
* goofy like a "::" scope qualifier.
*/
namePtr = objv[1];
if (strstr(Tcl_GetString(namePtr), "::")) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad variable name \"", Tcl_GetString(namePtr), "\"",
NULL);
return TCL_ERROR;
}
init = NULL;
config = NULL;
if (!haveArrayInit) {
if (objc >= 3) {
init = Tcl_GetString(objv[2]);
}
if (objc >= 4) {
config = Tcl_GetString(objv[3]);
}
}
if (Itcl_CreateVariable(interp, iclsPtr, namePtr, init, config,
&ivPtr) != TCL_OK) {
return TCL_ERROR;
}
if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
ivPtr->flags |= ITCL_VARIABLE;
}
if (haveArrayInit) {
ivPtr->arrayInitPtr = Tcl_NewStringObj(arrayInitStr, -1);
Tcl_IncrRefCount(ivPtr->arrayInitPtr);
} else {
ivPtr->arrayInitPtr = NULL;
}
iclsPtr->numVariables++;
ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr);
return result;
}
/*
* ------------------------------------------------------------------------
* ItclInitClassCommon()
*
* initialize a class commen variable
*
* ------------------------------------------------------------------------
*/
static int
ItclInitClassCommon(
Tcl_Interp *interp,
ItclClass *iclsPtr,
ItclVariable *ivPtr,
const char *initStr)
{
Tcl_DString buffer;
Tcl_CallFrame frame;
Tcl_Namespace *commonNsPtr;
Tcl_HashEntry *hPtr;
Tcl_Var varPtr;
int result;
int isNew;
result = TCL_OK;
ivPtr->flags |= ITCL_COMMON;
iclsPtr->numCommons++;
/*
* Create the variable in the namespace associated with the
* class. Do this the hard way, to avoid the variable resolver
* procedures. These procedures won't work until we rebuild
* the virtual tables below.
*/
Tcl_DStringInit(&buffer);
if (ivPtr->protection != ITCL_PUBLIC) {
/* public commons go to the class namespace directly the others
* go to the variables namespace of the class */
Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1);
}
Tcl_DStringAppend(&buffer,
(Tcl_GetObjectNamespace(ivPtr->iclsPtr->oPtr))->fullName, -1);
commonNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), NULL, 0);
if (commonNsPtr == NULL) {
Tcl_AppendResult(interp, "ITCL: cannot find common variables namespace",
" for class \"", Tcl_GetString(ivPtr->iclsPtr->fullNamePtr),
"\"", NULL);
return TCL_ERROR;
}
varPtr = Tcl_NewNamespaceVar(interp, commonNsPtr,
Tcl_GetString(ivPtr->namePtr));
hPtr = Tcl_CreateHashEntry(&iclsPtr->classCommons, (char *)ivPtr,
&isNew);
if (isNew) {
Itcl_PreserveVar(varPtr);
Tcl_SetHashValue(hPtr, varPtr);
}
result = Itcl_PushCallFrame(interp, &frame, commonNsPtr,
/* isProcCallFrame */ 0);
Itcl_PopCallFrame(interp);
/*
* If an initialization value was specified, then initialize
* the variable now, otherwise be sure the variable is uninitialized.
*/
if (initStr != NULL) {
const char *val;
val = Tcl_SetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), NULL,
initStr, TCL_NAMESPACE_ONLY);
if (!val) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot initialize common variable \"",
Tcl_GetString(ivPtr->namePtr), "\"",
NULL);
return TCL_ERROR;
}
} else {
/* previous var-lookup in class body (in ::itcl::parser) could obtain
* inherited common vars, so be sure it does not exists after new
* common creation (simply remove this reference). */
Tcl_UnsetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), NULL,
TCL_NAMESPACE_ONLY);
}
if (ivPtr->arrayInitPtr != NULL) {
int i;
int argc;
const char **argv;
const char *val;
result = Tcl_SplitList(interp, Tcl_GetString(ivPtr->arrayInitPtr),
&argc, &argv);
for (i = 0; i < argc; i++) {
val = Tcl_SetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), argv[i],
argv[i + 1], TCL_NAMESPACE_ONLY);
if (!val) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot initialize common variable \"",
Tcl_GetString(ivPtr->namePtr), "\"",
NULL);
return TCL_ERROR;
}
i++;
}
ckfree((char *)argv);
}
Tcl_DStringFree(&buffer);
return result;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassCommonCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "common" command is invoked to define a variable that is
* common to all objects in the class. Handles the following syntax:
*
* common <varname> ?<init>?
*
* ------------------------------------------------------------------------
*/
static int
ItclClassCommonCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[], /* argument objects */
int protection,
ItclVariable **ivPtrPtr)
{
ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
ItclVariable *ivPtr;
Tcl_Obj *namePtr;
char *arrayInitStr;
const char *usageStr;
char *initStr;
int haveError;
int haveArrayInit;
int result;
result = TCL_OK;
haveError = 0;
haveArrayInit = 0;
usageStr = NULL;
arrayInitStr = NULL;
*ivPtrPtr = NULL;
ItclShowArgs(2, "Itcl_ClassCommonCmd", objc, objv);
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::common called from",
" not within a class", NULL);
return TCL_ERROR;
}
if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
if (objc > 2) {
if (strcmp(Tcl_GetString(objv[2]), "-array") == 0) {
if (objc == 4) {
arrayInitStr = Tcl_GetString(objv[3]);
haveArrayInit = 1;
} else {
haveError = 1;
usageStr = "varname ?init|-array init?";
}
}
}
}
if (!haveError && !haveArrayInit) {
if ((objc < 2) || (objc > 3)) {
usageStr = "varname ?init?";
haveError = 1;
}
}
if (haveError) {
Tcl_WrongNumArgs(interp, 1, objv, usageStr);
return TCL_ERROR;
}
/*
* Make sure that the variable name does not contain anything
* goofy like a "::" scope qualifier.
*/
namePtr = objv[1];
if (strstr(Tcl_GetString(namePtr), "::")) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad variable name \"", Tcl_GetString(namePtr), "\"",
NULL);
return TCL_ERROR;
}
initStr = NULL;
if (!haveArrayInit) {
if (objc >= 3) {
initStr = Tcl_GetString(objv[2]);
}
}
if (Itcl_CreateVariable(interp, iclsPtr, namePtr, initStr, NULL,
&ivPtr) != TCL_OK) {
return TCL_ERROR;
}
if (protection != 0) {
ivPtr->protection = protection;
}
if (haveArrayInit) {
ivPtr->arrayInitPtr = Tcl_NewStringObj(arrayInitStr, -1);
Tcl_IncrRefCount(ivPtr->arrayInitPtr);
} else {
ivPtr->arrayInitPtr = NULL;
}
*ivPtrPtr = ivPtr;
result = ItclInitClassCommon(interp, iclsPtr, ivPtr, initStr);
ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr);
return result;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassTypeVariableCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "typevariable" command is invoked to define a variable that is
* common to all objects in the class. Handles the following syntax:
*
* typevariable <varname> ?<init>?
*
* ------------------------------------------------------------------------
*/
static int
Itcl_ClassTypeVariableCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
ItclVariable *ivPtr;
int result;
ivPtr = NULL;
ItclShowArgs(1, "Itcl_ClassTypeVariableCmd", objc, objv);
result = ItclClassCommonCmd(clientData, interp, objc, objv, ITCL_PUBLIC,
&ivPtr);
if (ivPtr != NULL) {
ivPtr->flags |= ITCL_TYPE_VARIABLE;
ItclAddClassVariableDictInfo(interp, ivPtr->iclsPtr, ivPtr);
}
return result;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassCommonCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "common" command is invoked to define a variable that is
* common to all objects in the class. Handles the following syntax:
*
* common <varname> ?<init>?
*
* ------------------------------------------------------------------------
*/
int
Itcl_ClassCommonCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
ItclVariable *ivPtr;
ItclShowArgs(2, "Itcl_ClassTypeVariableCmd", objc, objv);
return ItclClassCommonCmd(clientData, interp, objc, objv, 0, &ivPtr);
}
/*
* ------------------------------------------------------------------------
* ItclFreeParserCommandData()
*
* This callback will free() up memory dynamically allocated
* and passed as the ClientData argument to Tcl_CreateObjCommand.
* This callback is required because one can not simply pass
* a pointer to the free() or ckfree() to Tcl_CreateObjCommand.
* ------------------------------------------------------------------------
*/
static void
ItclFreeParserCommandData(
ClientData cdata) /* client data to be destroyed */
{
ckfree(cdata);
}
/*
* ------------------------------------------------------------------------
* ItclDelObjectInfo()
*
* Invoked when the management info for [incr Tcl] is no longer being
* used in an interpreter. This will only occur when all class
* manipulation commands are removed from the interpreter.
*
* See also FreeItclObjectInfo() in itclBase.c
* ------------------------------------------------------------------------
*/
static void
ItclDelObjectInfo(
char* cdata) /* client data for class command */
{
Tcl_HashSearch place;
Tcl_HashEntry *hPtr;
ItclObjectInfo *infoPtr = (ItclObjectInfo*)cdata;
ItclObject *ioPtr;
/*
* Destroy all known objects by deleting their access
* commands.
*/
hPtr = Tcl_FirstHashEntry(&infoPtr->objects, &place);
while (hPtr) {
ioPtr = (ItclObject*)Tcl_GetHashValue(hPtr);
Tcl_DeleteCommandFromToken(infoPtr->interp, ioPtr->accessCmd);
/*
* Fix 227804: Whenever an object to delete was found we
* have to reset the search to the beginning as the
* current entry in the search was deleted and accessing it
* is therefore not allowed anymore.
*/
hPtr = Tcl_FirstHashEntry(&infoPtr->objects, &place);
/*hPtr = Tcl_NextHashEntry(&place);*/
}
Tcl_DeleteHashTable(&infoPtr->objects);
Tcl_DeleteHashTable(&infoPtr->frameContext);
Itcl_DeleteStack(&infoPtr->clsStack);
Itcl_Free(infoPtr);
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassFilterCmd()
*
*
* ------------------------------------------------------------------------
*/
static int
Itcl_ClassFilterCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
Tcl_Obj **newObjv;
ItclObjectInfo *infoPtr;
ItclClass *iclsPtr;
int result;
ItclShowArgs(1, "Itcl_ClassFilterCmd", objc, objv);
infoPtr = (ItclObjectInfo*)clientData;
iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::filter called from",
" not within a class", NULL);
return TCL_ERROR;
}
if (iclsPtr->flags & ITCL_CLASS) {
Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr),
" is no ::itcl::widget/::itcl::widgetadaptor/::itcl::type",
"/::itcl::extendedclass. Only these can have filters", NULL);
return TCL_ERROR;
}
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "<filterName> ?<filterName> ...?");
return TCL_ERROR;
}
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+2));
newObjv[0] = Tcl_NewStringObj("::oo::define", -1);
Tcl_IncrRefCount(newObjv[0]);
newObjv[1] = Tcl_NewStringObj(Tcl_GetString(iclsPtr->fullNamePtr), -1);
Tcl_IncrRefCount(newObjv[1]);
newObjv[2] = Tcl_NewStringObj("filter", -1);
Tcl_IncrRefCount(newObjv[2]);
memcpy(newObjv+3, objv+1, sizeof(Tcl_Obj *)*(objc-1));
ItclShowArgs(1, "Itcl_ClassFilterCmd2", objc+2, newObjv);
result = Tcl_EvalObjv(interp, objc+2, newObjv, 0);
Tcl_DecrRefCount(newObjv[0]);
Tcl_DecrRefCount(newObjv[1]);
Tcl_DecrRefCount(newObjv[2]);
ckfree((char *)newObjv);
return result;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassMixinCmd()
*
*
* ------------------------------------------------------------------------
*/
static int
Itcl_ClassMixinCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
(void)clientData;
(void)interp;
ItclShowArgs(0, "Itcl_ClassMixinCmd", objc, objv);
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_WidgetCmd()
*
* that is just a dummy command to load package ItclWidget
* and then to resend the command and execute it in that package
* package ItclWidget is renaming the Tcl command!!
*
* ------------------------------------------------------------------------
*/
static int
Itcl_WidgetCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
ItclObjectInfo *infoPtr;
int result;
ItclShowArgs(1, "Itcl_WidgetCmd", objc-1, objv);
infoPtr = (ItclObjectInfo *)clientData;
if (!infoPtr->itclWidgetInitted) {
result = Tcl_EvalEx(interp, initWidgetScript, -1, 0);
if (result != TCL_OK) {
return result;
}
infoPtr->itclWidgetInitted = 1;
}
return Tcl_EvalObjv(interp, objc, objv, 0);
}
/*
* ------------------------------------------------------------------------
* Itcl_WidgetAdaptorCmd()
*
* that is just a dummy command to load package ItclWidget
* and then to resend the command and execute it in that package
* package ItclWidget is renaming the Tcl command!!
*
* ------------------------------------------------------------------------
*/
static int
Itcl_WidgetAdaptorCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
ItclObjectInfo *infoPtr;
int result;
ItclShowArgs(1, "Itcl_WidgetAdaptorCmd", objc-1, objv);
infoPtr = (ItclObjectInfo *)clientData;
if (!infoPtr->itclWidgetInitted) {
result = Tcl_EvalEx(interp, initWidgetScript, -1, 0);
if (result != TCL_OK) {
return result;
}
infoPtr->itclWidgetInitted = 1;
}
return Tcl_EvalObjv(interp, objc, objv, 0);
}
/*
* ------------------------------------------------------------------------
* ItclParseOption()
*
* Invoked by Tcl during the parsing whenever
* the "option" command is invoked to define an option
* Handles the following syntax:
*
* option
*
* ------------------------------------------------------------------------
*/
int
ItclParseOption(
ItclObjectInfo *infoPtr, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[], /* argument objects */
ItclClass *iclsPtr,
ItclObject *ioPtr,
ItclOption **ioptPtrPtr) /* where the otpion info is found */
{
Tcl_Obj *classNamePtr;
Tcl_Obj *nameSpecPtr;
Tcl_Obj **newObjv;
Tcl_HashEntry *hPtr;
ItclOption *ioptPtr;
char *init;
char *defaultValue;
char *cgetMethod;
char *cgetMethodVar;
char *configureMethod;
char *configureMethodVar;
char *validateMethod;
char *validateMethodVar;
const char *token;
const char *usage;
const char *optionName;
const char **argv;
const char *name;
const char *resourceName;
const char *className;
int argc;
int pLevel;
int readOnly;
int newObjc;
int foundOption;
int result;
int i;
const char *cp;
(void)infoPtr;
ItclShowArgs(1, "ItclParseOption", objc, objv);
pLevel = Itcl_Protection(interp, 0);
usage = "namespec \
?init? \
?-default value? \
?-readonly? \
?-cgetmethod methodName? \
?-cgetmethodvar varName? \
?-configuremethod methodName? \
?-configuremethodvar varName? \
?-validatemethod methodName? \
?-validatemethodvar varName";
if (pLevel == ITCL_PUBLIC) {
if (objc < 2 || objc > 11) {
Tcl_WrongNumArgs(interp, 1, objv, usage);
return TCL_ERROR;
}
} else {
if ((objc < 2) || (objc > 12)) {
Tcl_WrongNumArgs(interp, 1, objv, usage);
return TCL_ERROR;
}
}
argv = NULL;
newObjv = NULL;
defaultValue = NULL;
cgetMethod = NULL;
configureMethod = NULL;
validateMethod = NULL;
cgetMethodVar = NULL;
configureMethodVar = NULL;
validateMethodVar = NULL;
readOnly = 0;
newObjc = 0;
optionName = Tcl_GetString(objv[1]);
if (iclsPtr != NULL) {
/* check for already delegated!! */
hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedOptions, (char *)objv[1]);
if (hPtr != NULL) {
Tcl_AppendResult(interp, "cannot define option \"", optionName,
"\" locally, it has already been delegated", NULL);
result = TCL_ERROR;
goto errorOut;
}
}
if (ioPtr != NULL) {
/* check for already delegated!! */
hPtr = Tcl_FindHashEntry(&ioPtr->objectDelegatedOptions,
(char *)objv[1]);
if (hPtr != NULL) {
Tcl_AppendResult(interp, "cannot define option \"", optionName,
"\" locally, it has already been delegated", NULL);
result = TCL_ERROR;
goto errorOut;
}
}
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*objc);
newObjv[newObjc] = objv[1];
newObjc++;
for (i=2; i<objc; i++) {
token = Tcl_GetString(objv[i]);
foundOption = 0;
if (*token == '-') {
if (objc < i+1) {
Tcl_WrongNumArgs(interp, 1, objv, usage);
result = TCL_ERROR;
goto errorOut;
}
if (strcmp(token, "-default") == 0) {
foundOption = 1;
i++;
defaultValue = Tcl_GetString(objv[i]);
} else {
if (strcmp(token, "-readonly") == 0) {
foundOption = 1;
readOnly = 1;
} else {
if (strncmp(token, "-cgetmethod", 11) == 0) {
if (strcmp(token, "-cgetmethod") == 0) {
foundOption = 1;
i++;
cgetMethod = Tcl_GetString(objv[i]);
}
if (strcmp(token, "-cgetmethodvar") == 0) {
foundOption = 1;
i++;
cgetMethodVar = Tcl_GetString(objv[i]);
}
} else {
if (strncmp(token, "-configuremethod", 16) == 0) {
if (strcmp(token, "-configuremethod") == 0) {
foundOption = 1;
i++;
configureMethod = Tcl_GetString(objv[i]);
}
if (strcmp(token, "-configuremethodvar") == 0) {
foundOption = 1;
i++;
configureMethodVar = Tcl_GetString(objv[i]);
}
} else {
if (strncmp(token, "-validatemethod", 15) == 0) {
if (strcmp(token, "-validatemethod") == 0) {
foundOption = 1;
i++;
validateMethod = Tcl_GetString(objv[i]);
}
if (strcmp(token, "-validatemethodvar") == 0) {
foundOption = 1;
i++;
validateMethodVar = Tcl_GetString(objv[i]);
}
}
}
}
}
}
if (!foundOption) {
Tcl_AppendResult(interp, "funny option command option: \"",
token, "\"", NULL);
return TCL_ERROR;
}
}
if (!foundOption) {
newObjv[newObjc] = objv[i];
newObjc++;
}
}
if ((cgetMethod != NULL) && (cgetMethodVar != NULL)) {
Tcl_AppendResult(interp,
"option -cgetmethod and -cgetmethodvar cannot be used both",
NULL);
result = TCL_ERROR;
goto errorOut;
}
if ((configureMethod != NULL) && (configureMethodVar != NULL)) {
Tcl_AppendResult(interp,
"option -configuremethod and -configuremethodvar",
"cannot be used both",
NULL);
result = TCL_ERROR;
goto errorOut;
}
if ((validateMethod != NULL) && (validateMethodVar != NULL)) {
Tcl_AppendResult(interp,
"option -validatemethod and -validatemethodvar",
"cannot be used both",
NULL);
result = TCL_ERROR;
goto errorOut;
}
if (newObjc < 1) {
Tcl_AppendResult(interp, "usage: option ", usage, NULL);
result = TCL_ERROR;
goto errorOut;
}
resourceName = NULL;
className = NULL;
nameSpecPtr = newObjv[0];
token = Tcl_GetString(nameSpecPtr);
if (Tcl_SplitList(interp, (const char *)token, &argc, &argv) != TCL_OK) {
result = TCL_ERROR;
goto errorOut;
}
name = argv[0];
if (*name != '-') {
Tcl_AppendResult(interp, "bad option name \"", name,
"\", options must start with a \"-\"", NULL);
result = TCL_ERROR;
goto errorOut;
}
/*
* Make sure that the variable name does not contain anything
* goofy like a "::" scope qualifier.
*/
if (strstr(name, "::")) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option name \"", name,
"\", option names must not contain \"::\"", NULL);
result = TCL_ERROR;
goto errorOut;
}
if (strstr(name, " ")) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option name \"", name,
"\", option names must not contain \" \"", NULL);
result = TCL_ERROR;
goto errorOut;
}
cp = name;
while (*cp) {
if (isupper(UCHAR(*cp))) {
Tcl_AppendResult(interp, "bad option name \"", name, "\" ",
", options must not contain uppercase characters", NULL);
result = TCL_ERROR;
goto errorOut;
}
cp++;
}
if (argc > 1) {
resourceName = argv[1];
} else {
/* resource name defaults to option name minus hyphen */
resourceName = name+1;
}
if (argc > 2) {
className = argv[2];
} else {
/* class name defaults to option name minus hyphen and capitalized */
className = resourceName;
}
classNamePtr = ItclCapitalize(className);
init = defaultValue;
if ((newObjc > 1) && (init == NULL)) {
init = Tcl_GetString(newObjv[1]);
}
ioptPtr = (ItclOption*)Itcl_Alloc(sizeof(ItclOption));
ioptPtr->protection = Itcl_Protection(interp, 0);
if (ioptPtr->protection == ITCL_DEFAULT_PROTECT) {
ioptPtr->protection = ITCL_PROTECTED;
}
ioptPtr->namePtr = Tcl_NewStringObj(name, -1);
Tcl_IncrRefCount(ioptPtr->namePtr);
ioptPtr->resourceNamePtr = Tcl_NewStringObj(resourceName, -1);
Tcl_IncrRefCount(ioptPtr->resourceNamePtr);
ioptPtr->classNamePtr = Tcl_NewStringObj(Tcl_GetString(classNamePtr), -1);
Tcl_IncrRefCount(ioptPtr->classNamePtr);
Tcl_DecrRefCount(classNamePtr);
if (init) {
ioptPtr->defaultValuePtr = Tcl_NewStringObj(init, -1);
Tcl_IncrRefCount(ioptPtr->defaultValuePtr);
}
if (cgetMethod != NULL) {
ioptPtr->cgetMethodPtr = Tcl_NewStringObj(cgetMethod, -1);
Tcl_IncrRefCount(ioptPtr->cgetMethodPtr);
}
if (configureMethod != NULL) {
ioptPtr->configureMethodPtr = Tcl_NewStringObj(configureMethod, -1);
Tcl_IncrRefCount(ioptPtr->configureMethodPtr);
}
if (validateMethod != NULL) {
ioptPtr->validateMethodPtr = Tcl_NewStringObj(validateMethod, -1);
Tcl_IncrRefCount(ioptPtr->validateMethodPtr);
}
if (cgetMethodVar != NULL) {
ioptPtr->cgetMethodVarPtr = Tcl_NewStringObj(cgetMethodVar, -1);
Tcl_IncrRefCount(ioptPtr->cgetMethodVarPtr);
}
if (configureMethodVar != NULL) {
ioptPtr->configureMethodVarPtr = Tcl_NewStringObj(configureMethodVar, -1);
Tcl_IncrRefCount(ioptPtr->configureMethodVarPtr);
}
if (validateMethodVar != NULL) {
ioptPtr->validateMethodVarPtr = Tcl_NewStringObj(validateMethodVar, -1);
Tcl_IncrRefCount(ioptPtr->validateMethodVarPtr);
}
if (readOnly != 0) {
ioptPtr->flags |= ITCL_OPTION_READONLY;
}
*ioptPtrPtr = ioptPtr;
ItclAddOptionDictInfo(interp, iclsPtr, ioptPtr);
result = TCL_OK;
errorOut:
if (argv != NULL) {
ckfree((char *)argv);
}
if (newObjv != NULL) {
ckfree((char *)newObjv);
}
return result;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassOptionCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "option" command is invoked to define an option
* Handles the following syntax:
*
* option
*
* ------------------------------------------------------------------------
*/
int
Itcl_ClassOptionCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
ItclOption *ioptPtr;
const char *tkPackage;
const char *tkVersion;
ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
ItclShowArgs(1, "Itcl_ClassOptionCmd", objc, objv);
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::option called from",
" not within a class", NULL);
return TCL_ERROR;
}
if (iclsPtr->flags & ITCL_CLASS) {
Tcl_AppendResult(interp, "a \"class\" cannot have options", NULL);
return TCL_ERROR;
}
if ((objc > 1) && (strcmp(Tcl_GetString(objv[1]), "add") == 0)) {
tkVersion = "8.6";
tkPackage = Tcl_PkgPresentEx(interp, "Tk", tkVersion, 0, NULL);
if (tkPackage == NULL) {
tkPackage = Tcl_PkgRequireEx(interp, "Tk", tkVersion, 0, NULL);
}
if (tkPackage == NULL) {
Tcl_AppendResult(interp, "cannot load package Tk", tkVersion,
NULL);
return TCL_ERROR;
}
return Tcl_EvalObjv(interp, objc, objv, TCL_EVAL_GLOBAL);
}
if (ItclParseOption(infoPtr, interp, objc, objv, iclsPtr, NULL,
&ioptPtr) != TCL_OK) {
return TCL_ERROR;
}
if (Itcl_CreateOption(interp, iclsPtr, ioptPtr) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* ItclCreateComponent()
*
*
* ------------------------------------------------------------------------
*/
int
ItclCreateComponent(
Tcl_Interp *interp,
ItclClass *iclsPtr,
Tcl_Obj *componentPtr,
int type,
ItclComponent **icPtrPtr)
{
Tcl_HashEntry *hPtr;
ItclComponent *icPtr;
ItclVariable *ivPtr;
int result;
int isNew;
if (iclsPtr == NULL) {
return TCL_OK;
}
hPtr = Tcl_CreateHashEntry(&iclsPtr->components, (char *)componentPtr,
&isNew);
if (isNew) {
if (Itcl_CreateVariable(interp, iclsPtr, componentPtr, NULL, NULL,
&ivPtr) != TCL_OK) {
return TCL_ERROR;
}
if (type & ITCL_COMMON) {
result = ItclInitClassCommon(interp, iclsPtr, ivPtr, "");
if (result != TCL_OK) {
return result;
}
}
if (iclsPtr->flags & (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
if (strcmp(Tcl_GetString(componentPtr), "itcl_hull") == 0) {
/* special built in itcl_hull variable */
ivPtr->initted = 1;
ivPtr->flags |= ITCL_HULL_VAR;
}
}
ivPtr->flags |= ITCL_COMPONENT_VAR;
icPtr = (ItclComponent *)ckalloc(sizeof(ItclComponent));
memset(icPtr, 0, sizeof(ItclComponent));
Tcl_InitObjHashTable(&icPtr->keptOptions);
icPtr->namePtr = componentPtr;
Tcl_IncrRefCount(icPtr->namePtr);
icPtr->ivPtr = ivPtr;
Tcl_SetHashValue(hPtr, icPtr);
ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr);
} else {
icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr);
}
*icPtrPtr = icPtr;
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* ItclHandleClassComponent()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "component" command is invoked to define a component
* Handles the following syntax:
*
* component
*
* ------------------------------------------------------------------------
*/
static int
ItclHandleClassComponent(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[], /* argument objects */
ItclComponent **icPtrPtr)
{
Tcl_Obj **newObjv;
ItclObjectInfo *infoPtr;
ItclClass *iclsPtr;
ItclComponent *icPtr;
const char *usage;
const char *publ;
int inherit;
int haveInherit;
int havePublic;
int newObjc;
int haveValue;
int storageClass;
int i;
ItclShowArgs(1, "Itcl_ClassComponentCmd", objc, objv);
if (icPtrPtr != NULL) {
*icPtrPtr = NULL;
}
infoPtr = (ItclObjectInfo*)clientData;
iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::component called from",
" not within a class", NULL);
return TCL_ERROR;
}
usage = "component ?-public <typemethod>? ?-inherit ?<flag>??";
if (iclsPtr->flags & ITCL_CLASS) {
Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr),
" is no ::itcl::extendedclass/::itcl::widget",
"/::itcl::widgetadaptor/::itcl::type.",
" Only these can have components", NULL);
return TCL_ERROR;
}
if ((objc < 2) || (objc > 6)) {
Tcl_AppendResult(interp, "wrong # args should be: ", usage, NULL);
return TCL_ERROR;
}
inherit = 0;
haveInherit = 0;
publ = NULL;
havePublic = 0;
for (i = 2; i < objc; i++) {
if (strcmp(Tcl_GetString(objv[i]), "-inherit") == 0) {
if (haveInherit) {
Tcl_AppendResult(interp, "wrong syntax should be: ",
usage, NULL);
return TCL_ERROR;
}
haveValue = 0;
inherit = 1;
if (i < objc - 1) {
if (strcmp(Tcl_GetString(objv[i + 1]), "yes") == 0) {
haveValue = 1;
}
if (strcmp(Tcl_GetString(objv[i + 1]), "YES") == 0) {
haveValue = 1;
}
if (strcmp(Tcl_GetString(objv[i + 1]), "no") == 0) {
haveValue = 1;
inherit = 0;
}
if (strcmp(Tcl_GetString(objv[i + 1]), "NO") == 0) {
haveValue = 1;
inherit = 0;
}
}
if (haveValue) {
i++;
}
haveInherit = 1;
} else {
if (strcmp(Tcl_GetString(objv[i]), "-public") == 0) {
if (havePublic) {
Tcl_AppendResult(interp, "wrong syntax should be: ",
usage, NULL);
return TCL_ERROR;
}
havePublic = 1;
if (i >= objc - 1) {
Tcl_AppendResult(interp, "wrong syntax should be: ",
usage, NULL);
return TCL_ERROR;
}
publ = Tcl_GetString(objv[i + 1]);
} else {
Tcl_AppendResult(interp, "wrong syntax should be: ",
usage, NULL);
return TCL_ERROR;
}
}
i++;
}
storageClass = ITCL_COMMON;
if (iclsPtr->flags & ITCL_ECLASS) {
storageClass = 0;
}
if (ItclCreateComponent(interp, iclsPtr, objv[1], storageClass,
&icPtr) != TCL_OK) {
return TCL_ERROR;
}
if (inherit) {
icPtr->flags |= ITCL_COMPONENT_INHERIT;
newObjc = 4;
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*)*newObjc);
newObjv[0] = Tcl_NewStringObj("delegate::option", -1);
Tcl_IncrRefCount(newObjv[0]);
newObjv[1] = Tcl_NewStringObj("*", -1);
Tcl_IncrRefCount(newObjv[1]);
newObjv[2] = Tcl_NewStringObj("to", -1);
Tcl_IncrRefCount(newObjv[2]);
newObjv[3] = objv[1];
Tcl_IncrRefCount(newObjv[3]);
if (Itcl_ClassDelegateOptionCmd(infoPtr, interp, newObjc, newObjv)
!= TCL_OK) {
return TCL_ERROR;
}
Tcl_SetStringObj(newObjv[0] , "delegate::method", -1);
if (Itcl_ClassDelegateMethodCmd(infoPtr, interp, newObjc, newObjv)
!= TCL_OK) {
return TCL_ERROR;
}
Tcl_DecrRefCount(newObjv[0]);
Tcl_DecrRefCount(newObjv[1]);
Tcl_DecrRefCount(newObjv[2]);
Tcl_DecrRefCount(newObjv[3]);
ckfree((char *)newObjv);
}
if (publ != NULL) {
icPtr->flags |= ITCL_COMPONENT_PUBLIC;
newObjc = 4;
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*)*newObjc);
newObjv[0] = Tcl_NewStringObj("delegate::method", -1);
Tcl_IncrRefCount(newObjv[0]);
newObjv[1] = Tcl_NewStringObj(publ, -1);
Tcl_IncrRefCount(newObjv[1]);
newObjv[2] = Tcl_NewStringObj("to", -1);
Tcl_IncrRefCount(newObjv[2]);
newObjv[3] = objv[1];
Tcl_IncrRefCount(newObjv[3]);
ItclShowArgs(1, "COMPPUB", newObjc, newObjv);
if (Itcl_ClassDelegateMethodCmd(infoPtr, interp, newObjc, newObjv)
!= TCL_OK) {
return TCL_ERROR;
}
Tcl_DecrRefCount(newObjv[0]);
Tcl_DecrRefCount(newObjv[1]);
Tcl_DecrRefCount(newObjv[2]);
Tcl_DecrRefCount(newObjv[3]);
ckfree((char *)newObjv);
}
if (icPtrPtr != NULL) {
*icPtrPtr = icPtr;
}
ItclAddClassComponentDictInfo(interp, iclsPtr, icPtr);
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassComponentCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "component" command is invoked to define a component
* Handles the following syntax:
*
* component
*
* ------------------------------------------------------------------------
*/
static int
Itcl_ClassComponentCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
ItclComponent *icPtr;
return ItclHandleClassComponent(clientData, interp, objc, objv, &icPtr);
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassTypeComponentCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "typecomponent" command is invoked to define a typecomponent
* Handles the following syntax:
*
* component
*
* ------------------------------------------------------------------------
*/
static int
Itcl_ClassTypeComponentCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
ItclComponent *icPtr;
int result;
ItclShowArgs(1, "Itcl_ClassTypeComponentCmd", objc, objv);
result = ItclHandleClassComponent(clientData, interp, objc, objv, &icPtr);
if (result != TCL_OK) {
return result;
}
icPtr->ivPtr->flags |= ITCL_COMMON;
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* ItclCreateDelegatedFunction()
*
* Install a delegated function for a class
*
* ------------------------------------------------------------------------
*/
int
ItclCreateDelegatedFunction(
Tcl_Interp *interp,
ItclClass *iclsPtr,
Tcl_Obj *methodNamePtr,
ItclComponent *icPtr,
Tcl_Obj *targetPtr,
Tcl_Obj *usingPtr,
Tcl_Obj *exceptionsPtr,
ItclDelegatedFunction **idmPtrPtr)
{
ItclDelegatedFunction *idmPtr;
const char **argv;
int argc;
int isNew;
int i;
idmPtr = (ItclDelegatedFunction *)ckalloc(sizeof(ItclDelegatedFunction));
memset(idmPtr, 0, sizeof(ItclDelegatedFunction));
Tcl_InitObjHashTable(&idmPtr->exceptions);
idmPtr->namePtr = Tcl_NewStringObj(Tcl_GetString(methodNamePtr), -1);
Tcl_IncrRefCount(idmPtr->namePtr);
idmPtr->icPtr = icPtr;
idmPtr->asPtr = targetPtr;
if (idmPtr->asPtr != NULL) {
Tcl_IncrRefCount(idmPtr->asPtr);
}
idmPtr->usingPtr = usingPtr;
if (idmPtr->usingPtr != NULL) {
Tcl_IncrRefCount(idmPtr->usingPtr);
}
if (exceptionsPtr != NULL) {
if (Tcl_SplitList(interp, Tcl_GetString(exceptionsPtr), &argc, &argv)
!= TCL_OK) {
return TCL_ERROR;
}
for(i = 0; i < argc; i++) {
Tcl_Obj *objPtr;
objPtr = Tcl_NewStringObj(argv[i], -1);
Tcl_CreateHashEntry(&idmPtr->exceptions, (char *)objPtr,
&isNew);
}
ckfree((char *) argv);
}
if (idmPtrPtr != NULL) {
*idmPtrPtr = idmPtr;
}
ItclAddClassDelegatedFunctionDictInfo(interp, iclsPtr, idmPtr);
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_HandleDelegateMethodCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "delegate method" command is invoked to define a
* Handles the following syntax:
*
* delegate method
*
* ------------------------------------------------------------------------
*/
int
Itcl_HandleDelegateMethodCmd(
Tcl_Interp *interp, /* current interpreter */
ItclObject *ioPtr, /* != NULL for ::itcl::adddelegatedmethod
otherwise NULL */
ItclClass *iclsPtr, /* != NULL for delegate method otherwise NULL */
ItclDelegatedFunction **idmPtrPtr,
/* where to return idoPtr */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
Tcl_Obj *methodNamePtr;
Tcl_Obj *componentPtr;
Tcl_Obj *targetPtr;
Tcl_Obj *usingPtr;
Tcl_Obj *exceptionsPtr;
Tcl_HashEntry *hPtr;
ItclClass *iclsPtr2;
ItclComponent *icPtr;
ItclHierIter hier;
const char *usageStr;
const char *methodName;
const char *component;
const char *token;
int result;
int i;
int foundOpt;
ItclShowArgs(1, "Itcl_HandleDelegateMethodCmd", objc, objv);
usageStr = "delegate method <methodName> to <componentName> ?as <targetName>?\n\
delegate method <methodName> ?to <componentName>? using <pattern>\n\
delegate method * ?to <componentName>? ?using <pattern>? ?except <methods>?";
if (objc < 4) {
Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL);
return TCL_ERROR;
}
componentPtr = NULL;
icPtr = NULL;
methodName = Tcl_GetString(objv[1]);
component = NULL;
targetPtr = NULL;
usingPtr = NULL;
exceptionsPtr = NULL;
for(i=2;i<objc;i++) {
token = Tcl_GetString(objv[i]);
if (i+1 == objc) {
Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL);
return TCL_ERROR;
}
foundOpt = 0;
if (strcmp(token, "to") == 0) {
i++;
component = Tcl_GetString(objv[i]);
componentPtr = objv[i];
foundOpt++;
}
if (strcmp(token, "as") == 0) {
i++;
targetPtr = objv[i];
foundOpt++;
}
if (strcmp(token, "except") == 0) {
i++;
exceptionsPtr = objv[i];
foundOpt++;
}
if (strcmp(token, "using") == 0) {
i++;
usingPtr = objv[i];
foundOpt++;
}
if (!foundOpt) {
Tcl_AppendResult(interp, "bad option \"", token, "\" should be ",
usageStr, NULL);
return TCL_ERROR;
}
}
if ((exceptionsPtr != NULL) && (*methodName != '*')) {
Tcl_AppendResult(interp,
"can only specify \"except\" with \"delegate method *\"", NULL);
return TCL_ERROR;
}
if ((component == NULL) && (usingPtr == NULL)) {
Tcl_AppendResult(interp, "missing to should be: ", usageStr, NULL);
return TCL_ERROR;
}
if ((*methodName == '*') && (targetPtr != NULL)) {
Tcl_AppendResult(interp,
"cannot specify \"as\" with \"delegate method *\"", NULL);
return TCL_ERROR;
}
/* check for already delegated */
methodNamePtr = Tcl_NewStringObj(methodName, -1);
if (ioPtr != NULL) {
hPtr = Tcl_FindHashEntry(&ioPtr->objectDelegatedFunctions, (char *)
methodNamePtr);
} else {
hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *)
methodNamePtr);
}
hPtr = NULL;
if (ioPtr != NULL) {
if (componentPtr != NULL) {
Itcl_InitHierIter(&hier, ioPtr->iclsPtr);
while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) {
hPtr = Tcl_FindHashEntry(&iclsPtr->components,
(char *)componentPtr);
if (hPtr != NULL) {
break;
}
}
Itcl_DeleteHierIter(&hier);
}
} else {
if (componentPtr != NULL) {
iclsPtr2 = iclsPtr;
Itcl_InitHierIter(&hier, iclsPtr2);
while ((iclsPtr2 = Itcl_AdvanceHierIter(&hier)) != NULL) {
hPtr = Tcl_FindHashEntry(&iclsPtr2->components,
(char *)componentPtr);
if (hPtr != NULL) {
break;
}
}
Itcl_DeleteHierIter(&hier);
}
}
if (hPtr == NULL) {
if (componentPtr != NULL) {
if (ItclCreateComponent(interp, iclsPtr, componentPtr,
ITCL_COMMON, &icPtr) != TCL_OK) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&iclsPtr->components,
(char *)componentPtr);
}
}
if (hPtr != NULL) {
icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr);
}
if (*methodName != '*') {
/* FIXME !!! */
/* check for locally defined method */
hPtr = NULL;
if (ioPtr != NULL) {
} else {
/* FIXME !! have to check the hierarchy !! */
hPtr = Tcl_FindHashEntry(&iclsPtr->functions,
(char *)methodNamePtr);
}
if (hPtr != NULL) {
Tcl_AppendResult(interp, "method \"", methodName,
"\" has been defined locally", NULL);
result = TCL_ERROR;
goto errorOut;
}
}
result = ItclCreateDelegatedFunction(interp, iclsPtr, methodNamePtr, icPtr,
targetPtr, usingPtr, exceptionsPtr, idmPtrPtr);
(*idmPtrPtr)->flags |= ITCL_METHOD;
errorOut:
Tcl_DecrRefCount(methodNamePtr);
return result;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassDelegateMethodCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "delegate method" command is invoked to define a
* Handles the following syntax:
*
* delegate method
*
* ------------------------------------------------------------------------
*/
static int
Itcl_ClassDelegateMethodCmd(
ClientData 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;
ItclObjectInfo *infoPtr;
ItclClass *iclsPtr;
ItclDelegatedFunction *idmPtr;
int isNew;
int result;
ItclShowArgs(1, "Itcl_ClassDelegateMethodCmd", objc, objv);
infoPtr = (ItclObjectInfo*)clientData;
iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::delegatemethod called from",
" not within a class", NULL);
return TCL_ERROR;
}
if (iclsPtr->flags & ITCL_CLASS) {
Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr),
" is no ::itcl::widget/::itcl::widgetadaptor/::itcl::type",
"/::itcl::extendedclass.",
" Only these can delegate methods", NULL);
return TCL_ERROR;
}
result = Itcl_HandleDelegateMethodCmd(interp, NULL, iclsPtr, &idmPtr, objc,
objv);
if (result != TCL_OK) {
return result;
}
idmPtr->flags |= ITCL_METHOD;
hPtr = Tcl_CreateHashEntry(&iclsPtr->delegatedFunctions,
(char *)idmPtr->namePtr, &isNew);
Tcl_SetHashValue(hPtr, idmPtr);
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_HandleDelegateOptionCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "delegate option" command is invoked to define a delegated option
* or if ::itcl::adddelegatedoption is called with an itcl object
* Handles the following syntax:
*
* delegate option ...
*
* ------------------------------------------------------------------------
*/
int
Itcl_HandleDelegateOptionCmd(
Tcl_Interp *interp, /* current interpreter */
ItclObject *ioPtr, /* != NULL for ::itcl::adddelgatedoption
otherwise NULL */
ItclClass *iclsPtr, /* != NULL for delegate option otherwise NULL */
ItclDelegatedOption **idoPtrPtr,
/* where to return idoPtr */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
Tcl_Obj *allOptionNamePtr;
Tcl_Obj *optionNamePtr;
Tcl_Obj *componentPtr;
Tcl_Obj *targetPtr;
Tcl_Obj *exceptionsPtr;
Tcl_Obj *resourceNamePtr;
Tcl_Obj *classNamePtr;
Tcl_HashEntry *hPtr;
ItclComponent *icPtr;
ItclClass *iclsPtr2;
ItclDelegatedOption *idoPtr;
ItclHierIter hier;
const char *usageStr;
const char *option;
const char *component;
const char *token;
const char **argv;
int foundOpt;
int argc;
int isStarOption;
int isNew;
int i;
const char *cp;
ItclShowArgs(1, "Itcl_HandleDelegatedOptionCmd", objc, objv);
usageStr = "<optionDef> to <targetDef> ?as <script>? ?except <script>?";
if (objc < 4) {
Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL);
return TCL_ERROR;
}
componentPtr = NULL;
icPtr = NULL;
isStarOption = 0;
token = Tcl_GetString(objv[1]);
if (Tcl_SplitList(interp, (const char *)token, &argc, &argv) != TCL_OK) {
return TCL_ERROR;
}
option = argv[0];
if (strcmp(option, "*") == 0) {
isStarOption = 1;
}
if ((argc < 1) || (isStarOption && (argc > 1))) {
Tcl_AppendResult(interp, "<optionDef> must be either \"*\" or ",
"\"<optionName> <resourceName> <className>\"", NULL);
ckfree((char *)argv);
return TCL_ERROR;
}
if (isStarOption && (argc > 3)) {
Tcl_AppendResult(interp, "<optionDef> syntax should be: ",
"\"<optionName> <resourceName> <className>\"", NULL);
ckfree((char *)argv);
return TCL_ERROR;
}
if ((*option != '-') && !isStarOption) {
Tcl_AppendResult(interp, "bad delegated option name \"", option,
"\", options must start with a \"-\"", NULL);
ckfree((char *)argv);
return TCL_ERROR;
}
/*
* Make sure that the variable name does not contain anything
* goofy like a "::" scope qualifier.
*/
if (strstr(option, "::")) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option name \"", option,
"\", option names must not contain \"::\"", NULL);
ckfree((char *)argv);
return TCL_ERROR;
}
if (strstr(option, " ")) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option name \"", option,
"\", option names must not contain \" \"", NULL);
ckfree((char *)argv);
return TCL_ERROR;
}
cp = option;
while (*cp) {
if (isupper(UCHAR(*cp))) {
Tcl_AppendResult(interp, "bad option name \"", option, "\" ",
", options must not contain uppercase characters", NULL);
ckfree((char *)argv);
return TCL_ERROR;
}
cp++;
}
optionNamePtr = Tcl_NewStringObj(option, -1);
Tcl_IncrRefCount(optionNamePtr);
resourceNamePtr = NULL;
classNamePtr = NULL;
if (argc > 1) {
resourceNamePtr = Tcl_NewStringObj(argv[1], -1);
Tcl_IncrRefCount(resourceNamePtr);
}
if (argc > 2) {
classNamePtr = Tcl_NewStringObj(argv[2], -1);
}
component = NULL;
targetPtr = NULL;
exceptionsPtr = NULL;
for(i=2;i<objc;i++) {
token = Tcl_GetString(objv[i]);
if (i+1 == objc) {
Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL);
goto errorOut1;
}
foundOpt = 0;
if (strcmp(token, "to") == 0) {
i++;
component = Tcl_GetString(objv[i]);
componentPtr = objv[i];
foundOpt++;
}
if (strcmp(token, "as") == 0) {
i++;
targetPtr = objv[i];
foundOpt++;
}
if (strcmp(token, "except") == 0) {
i++;
exceptionsPtr = objv[i];
foundOpt++;
}
if (!foundOpt) {
Tcl_AppendResult(interp, "bad option \"", token, "\" should be ",
usageStr, NULL);
goto errorOut1;
}
}
if (component == NULL) {
Tcl_AppendResult(interp, "missing to should be: ", usageStr, NULL);
goto errorOut1;
}
if ((*option == '*') && (targetPtr != NULL)) {
Tcl_AppendResult(interp,
"cannot specify \"as\" with \"delegate option *\"", NULL);
goto errorOut1;
}
/* check for already delegated */
allOptionNamePtr = Tcl_NewStringObj("*", -1);
Tcl_IncrRefCount(allOptionNamePtr);
if (ioPtr != NULL) {
hPtr = Tcl_FindHashEntry(&ioPtr->objectDelegatedOptions, (char *)
allOptionNamePtr);
} else {
hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedOptions, (char *)
allOptionNamePtr);
}
Tcl_DecrRefCount(allOptionNamePtr);
if (hPtr != NULL) {
Tcl_AppendResult(interp, "option \"", option,
"\" is already delegated", NULL);
goto errorOut1;
}
if (ioPtr != NULL) {
Itcl_InitHierIter(&hier, ioPtr->iclsPtr);
while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) {
hPtr = Tcl_FindHashEntry(&iclsPtr->components,
(char *)componentPtr);
if (hPtr != NULL) {
break;
}
}
Itcl_DeleteHierIter(&hier);
} else {
Itcl_InitHierIter(&hier, iclsPtr);
while ((iclsPtr2 = Itcl_AdvanceHierIter(&hier)) != NULL) {
hPtr = Tcl_FindHashEntry(&iclsPtr2->components,
(char *)componentPtr);
if (hPtr != NULL) {
break;
}
}
Itcl_DeleteHierIter(&hier);
}
if (hPtr == NULL) {
if (componentPtr != NULL) {
if (ItclCreateComponent(interp, iclsPtr, componentPtr,
ITCL_COMMON, &icPtr) != TCL_OK) {
goto errorOut1;
}
hPtr = Tcl_FindHashEntry(&iclsPtr->components,
(char *)componentPtr);
}
}
if (hPtr != NULL) {
icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr);
}
if (*option != '*') {
/* FIXME !!! */
/* check for valid option name */
if (ioPtr != NULL) {
hPtr = Tcl_FindHashEntry(&ioPtr->objectOptions,
(char *)optionNamePtr);
} else {
Itcl_InitHierIter(&hier, iclsPtr);
while ((iclsPtr2 = Itcl_AdvanceHierIter(&hier)) != NULL) {
hPtr = Tcl_FindHashEntry(&iclsPtr2->options,
(char *)optionNamePtr);
if (hPtr != NULL) {
break;
}
}
}
if (hPtr != NULL) {
Tcl_AppendResult(interp, "option \"", option,
"\" has been defined locally", NULL);
goto errorOut1;
return TCL_ERROR;
}
}
idoPtr = (ItclDelegatedOption *)Itcl_Alloc(sizeof(ItclDelegatedOption));
Tcl_InitObjHashTable(&idoPtr->exceptions);
if (*option != '*') {
if (targetPtr == NULL) {
targetPtr = optionNamePtr;
}
if (resourceNamePtr == NULL) {
resourceNamePtr = Tcl_NewStringObj(option+1, -1);
Tcl_IncrRefCount(resourceNamePtr);
}
if (classNamePtr == NULL) {
classNamePtr = ItclCapitalize(Tcl_GetString(resourceNamePtr));
}
idoPtr->namePtr = optionNamePtr;
idoPtr->resourceNamePtr = resourceNamePtr;
idoPtr->classNamePtr = Tcl_NewStringObj(
Tcl_GetString(classNamePtr), -1);
Tcl_IncrRefCount(idoPtr->classNamePtr);
Tcl_DecrRefCount(classNamePtr);
} else {
idoPtr->namePtr = optionNamePtr;
}
Itcl_PreserveData(idoPtr);
Itcl_EventuallyFree(idoPtr, (Tcl_FreeProc *) ItclDeleteDelegatedOption);
idoPtr->icPtr = icPtr;
idoPtr->asPtr = targetPtr;
if (idoPtr->asPtr != NULL) {
Tcl_IncrRefCount(idoPtr->asPtr);
}
if (exceptionsPtr != NULL) {
ckfree((char *)argv);
argv = NULL;
if (Tcl_SplitList(interp, Tcl_GetString(exceptionsPtr), &argc, &argv)
!= TCL_OK) {
goto errorOut2;
}
for(i=0;i<argc;i++) {
Tcl_Obj *objPtr;
objPtr = Tcl_NewStringObj(argv[i], -1);
hPtr = Tcl_CreateHashEntry(&idoPtr->exceptions, (char *)objPtr,
&isNew);
}
}
if (idoPtrPtr != NULL) {
*idoPtrPtr = idoPtr;
}
ckfree((char *)argv);
ItclAddDelegatedOptionDictInfo(interp, iclsPtr, idoPtr);
return TCL_OK;
errorOut2:
Itcl_ReleaseData(idoPtr);
errorOut1:
Tcl_DecrRefCount(optionNamePtr);
if (resourceNamePtr != NULL) {
Tcl_DecrRefCount(resourceNamePtr);
}
if (classNamePtr != NULL) {
Tcl_DecrRefCount(classNamePtr);
}
if (argv) {
ckfree((char *)argv);
}
return TCL_ERROR;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassDelegateOptionCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "delegate option" command is invoked to define a
* Handles the following syntax:
*
* delegate option
*
* ------------------------------------------------------------------------
*/
static int
Itcl_ClassDelegateOptionCmd(
ClientData 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;
ItclObjectInfo *infoPtr;
ItclClass *iclsPtr;
ItclDelegatedOption *idoPtr;
const char *usageStr;
int isNew;
int result;
ItclShowArgs(1, "Itcl_ClassDelegateOptionCmd", objc, objv);
usageStr = "<optionDef> to <targetDef> ?as <script>? ?except <script>?";
if (objc < 4) {
Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL);
return TCL_ERROR;
}
infoPtr = (ItclObjectInfo *)clientData;
iclsPtr = (ItclClass *)Itcl_PeekStack(&infoPtr->clsStack);
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::delegateoption called from",
" not within a class", NULL);
return TCL_ERROR;
}
if (iclsPtr->flags & ITCL_CLASS) {
Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr),
" is no ::itcl::widget/::itcl::widgetadaptor/::itcl::type",
"/::itcl::extendedclass.",
" Only these can delegate options", NULL);
return TCL_ERROR;
}
result = Itcl_HandleDelegateOptionCmd(interp, NULL, iclsPtr, &idoPtr,
objc, objv);
if (result != TCL_OK) {
return result;
}
hPtr = Tcl_CreateHashEntry(&iclsPtr->delegatedOptions,
(char *)idoPtr->namePtr, &isNew);
Tcl_SetHashValue(hPtr, idoPtr);
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassDelegateTypeMethodCmd()
*
* Invoked by Tcl during the parsing of a class definition whenever
* the "delegate typemethod" command is invoked to define a
* Handles the following syntax:
*
* delegate typemethod
*
* ------------------------------------------------------------------------
*/
static int
Itcl_ClassDelegateTypeMethodCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
Tcl_Obj *typeMethodNamePtr;
Tcl_Obj *componentPtr;
Tcl_Obj *targetPtr;
Tcl_Obj *usingPtr;
Tcl_Obj *exceptionsPtr;
Tcl_HashEntry *hPtr;
ItclObjectInfo *infoPtr;
ItclClass *iclsPtr;
ItclComponent *icPtr;
ItclDelegatedFunction *idmPtr;
const char *usageStr;
const char *typeMethodName;
const char *component;
const char *token;
const char **argv;
int foundOpt;
int argc;
int isNew;
int i;
ItclShowArgs(1, "Itcl_ClassDelegateTypeMethodCmd", objc, objv);
usageStr = "delegate typemethod <typeMethodName> to <componentName> ?as <targetName>?\n\
delegate typemethod <typeMethodName> ?to <componentName>? using <pattern>\n\
delegate typemethod * ?to <componentName>? ?using <pattern>? ?except <typemethods>?";
componentPtr = NULL;
icPtr = NULL;
infoPtr = (ItclObjectInfo*)clientData;
iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::delegatetypemethod called from",
" not within a class", NULL);
return TCL_ERROR;
}
if (iclsPtr->flags & ITCL_CLASS) {
Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr),
" is no ::itcl::widget/::itcl::widgetadaptor/::itcl::type.",
" Only these can delegate typemethods", NULL);
return TCL_ERROR;
}
if (objc < 4) {
Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL);
return TCL_ERROR;
}
typeMethodName = Tcl_GetString(objv[1]);
/* check if typeMethodName has been delegated */
component = NULL;
targetPtr = NULL;
usingPtr = NULL;
exceptionsPtr = NULL;
for(i=2;i<objc;i++) {
token = Tcl_GetString(objv[i]);
if (i+1 == objc) {
Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL);
return TCL_ERROR;
}
foundOpt = 0;
if (strcmp(token, "to") == 0) {
i++;
component = Tcl_GetString(objv[i]);
componentPtr = objv[i];
foundOpt++;
}
if (strcmp(token, "as") == 0) {
i++;
targetPtr = objv[i];
foundOpt++;
}
if (strcmp(token, "except") == 0) {
i++;
exceptionsPtr = objv[i];
foundOpt++;
}
if (strcmp(token, "using") == 0) {
i++;
usingPtr = objv[i];
foundOpt++;
}
if (!foundOpt) {
Tcl_AppendResult(interp, "bad option \"", token, "\" should be ",
usageStr, NULL);
return TCL_ERROR;
}
}
if ((component == NULL) && (usingPtr == NULL)) {
Tcl_AppendResult(interp, "missing to should be: ", usageStr, NULL);
return TCL_ERROR;
}
if ((*typeMethodName == '*') && (targetPtr != NULL)) {
Tcl_AppendResult(interp,
"cannot specify \"as\" with \"delegate typemethod *\"", NULL);
return TCL_ERROR;
}
if (componentPtr != NULL) {
hPtr = Tcl_FindHashEntry(&iclsPtr->components, (char *)componentPtr);
if (hPtr == NULL) {
if (ItclCreateComponent(interp, iclsPtr, componentPtr,
ITCL_COMMON, &icPtr) != TCL_OK) {
return TCL_ERROR;
}
} else {
icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr);
}
} else {
icPtr = NULL;
}
idmPtr = (ItclDelegatedFunction *)ckalloc(sizeof(ItclDelegatedFunction));
memset(idmPtr, 0, sizeof(ItclDelegatedFunction));
Tcl_InitObjHashTable(&idmPtr->exceptions);
typeMethodNamePtr = Tcl_NewStringObj(typeMethodName, -1);
if (*typeMethodName != '*') {
/* FIXME !!! */
/* check for locally defined typemethod */
hPtr = Tcl_FindHashEntry(&iclsPtr->functions,
(char *)typeMethodNamePtr);
if (hPtr != NULL) {
Tcl_AppendResult(interp, "Error in \"delegate typemethod ",
typeMethodName, "...\", \"", typeMethodName,
"\" has been defined locally.", NULL);
Tcl_DeleteHashTable(&idmPtr->exceptions);
ckfree((char *)idmPtr);
Tcl_DecrRefCount(typeMethodNamePtr);
return TCL_ERROR;
}
idmPtr->namePtr = Tcl_NewStringObj(
Tcl_GetString(typeMethodNamePtr), -1);
Tcl_IncrRefCount(idmPtr->namePtr);
} else {
Tcl_DecrRefCount(typeMethodNamePtr);
typeMethodNamePtr = Tcl_NewStringObj("*", -1);
Tcl_IncrRefCount(typeMethodNamePtr);
idmPtr->namePtr = typeMethodNamePtr;
Tcl_IncrRefCount(typeMethodNamePtr);
if (exceptionsPtr != NULL) {
if (Tcl_SplitList(interp, Tcl_GetString(exceptionsPtr),
&argc, &argv) != TCL_OK) {
return TCL_ERROR;
}
for(i = 0; i < argc; i++) {
Tcl_Obj *objPtr;
objPtr = Tcl_NewStringObj(argv[i], -1);
hPtr = Tcl_CreateHashEntry(&idmPtr->exceptions, (char *)objPtr,
&isNew);
}
ckfree((char *) argv);
}
}
idmPtr->icPtr = icPtr;
idmPtr->asPtr = targetPtr;
if (idmPtr->asPtr != NULL) {
Tcl_IncrRefCount(idmPtr->asPtr);
}
idmPtr->usingPtr = usingPtr;
if (idmPtr->usingPtr != NULL) {
Tcl_IncrRefCount(idmPtr->usingPtr);
}
idmPtr->flags = ITCL_COMMON|ITCL_TYPE_METHOD;
hPtr = Tcl_CreateHashEntry(&iclsPtr->delegatedFunctions,
(char *)idmPtr->namePtr, &isNew);
if (!isNew) {
ItclDeleteDelegatedFunction((ItclDelegatedFunction *)
Tcl_GetHashValue(hPtr));
}
Tcl_SetHashValue(hPtr, idmPtr);
Tcl_DecrRefCount(typeMethodNamePtr);
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassForwardCmd()
*
* Used similar to interp alias to forward the call of a method
* to another method within the class
*
* Returns TCL_OK/TCL_ERROR to indicate success/failure.
* ------------------------------------------------------------------------
*/
/* ARGSUSED */
static int
Itcl_ClassForwardCmd(
ClientData clientData, /* unused */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
Tcl_Obj *prefixObj;
Tcl_Method mPtr;
ItclObjectInfo *infoPtr;
ItclClass *iclsPtr;
ItclShowArgs(1, "Itcl_ClassForwardCmd", objc, objv);
infoPtr = (ItclObjectInfo*)clientData;
iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::forward called from",
" not within a class", NULL);
return TCL_ERROR;
}
if (iclsPtr->flags & ITCL_CLASS) {
Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr),
" is no ::itcl::widget/::itcl::widgetadaptor/",
"::itcl::type/::itcl::extendedclass.",
" Only these can forward", NULL);
return TCL_ERROR;
}
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "<forwardName> <targetName> ?<arg> ...?");
return TCL_ERROR;
}
prefixObj = Tcl_NewListObj(objc-2, objv+2);
mPtr = Itcl_NewForwardClassMethod(interp, iclsPtr->clsPtr, 1,
objv[1], prefixObj);
if (mPtr == NULL) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassMethodVariableCmd()
*
* Used to similar to iterp alias to forward the call of a method
* to another method within the class
*
* Returns TCL_OK/TCL_ERROR to indicate success/failure.
* ------------------------------------------------------------------------
*/
/* ARGSUSED */
static int
Itcl_ClassMethodVariableCmd(
ClientData clientData, /* unused */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
Tcl_Obj *namePtr;
Tcl_Obj *defaultPtr;
Tcl_Obj *callbackPtr;
ItclObjectInfo *infoPtr;
ItclClass *iclsPtr;
ItclVariable *ivPtr;
ItclMemberFunc *imPtr;
ItclMethodVariable *imvPtr;
const char *token;
const char *usageStr;
int i;
int foundOpt;
int result;
Tcl_Obj *objPtr;
ItclShowArgs(1, "Itcl_ClassMethodVariableCmd", objc, objv);
infoPtr = (ItclObjectInfo*)clientData;
iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::methodvariable called from",
" not within a class", NULL);
return TCL_ERROR;
}
if (iclsPtr->flags & ITCL_CLASS) {
Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr),
" is no ::itcl::widget/::itcl::widgetadaptor/",
"::itcl::type/::itcl::extendedclass.",
" Only these can have methodvariables", NULL);
return TCL_ERROR;
}
usageStr = "<name> ?-default value? ?-callback script?";
if ((objc < 2) || (objc > 6)) {
Tcl_WrongNumArgs(interp, 1, objv, usageStr);
return TCL_ERROR;
}
/*
* Make sure that the variable name does not contain anything
* goofy like a "::" scope qualifier.
*/
namePtr = objv[1];
if (strstr(Tcl_GetString(namePtr), "::")) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad variable name \"", Tcl_GetString(namePtr), "\"",
NULL);
return TCL_ERROR;
}
defaultPtr = NULL;
callbackPtr = NULL;
for (i=2;i<objc;i++) {
foundOpt = 0;
token = Tcl_GetString(objv[i]);
if (strcmp(token, "-default") == 0) {
if (i+1 > objc) {
Tcl_WrongNumArgs(interp, 1, objv, usageStr);
return TCL_ERROR;
}
defaultPtr = objv[i+1];
i++;
foundOpt++;
}
if (strcmp(token, "-callback") == 0) {
if (i+1 > objc) {
Tcl_WrongNumArgs(interp, 1, objv, usageStr);
return TCL_ERROR;
}
callbackPtr = objv[i+1];
i++;
foundOpt++;
}
if (!foundOpt) {
Tcl_WrongNumArgs(interp, 1, objv, usageStr);
return TCL_ERROR;
}
}
if (Itcl_CreateVariable(interp, iclsPtr, namePtr,
Tcl_GetString(defaultPtr), NULL, &ivPtr) != TCL_OK) {
return TCL_ERROR;
}
iclsPtr->numVariables++;
result = ItclCreateMethodVariable(interp, ivPtr, defaultPtr,
callbackPtr, &imvPtr);
if (result != TCL_OK) {
return result;
}
objPtr = Tcl_NewStringObj("@itcl-builtin-setget ", -1);
Tcl_AppendToObj(objPtr, Tcl_GetString(namePtr), -1);
Tcl_AppendToObj(objPtr, " ", 1);
result = ItclCreateMethod(interp, iclsPtr, namePtr, "args",
Tcl_GetString(objPtr), &imPtr);
if (result != TCL_OK) {
return result;
}
/* install a write trace if callbackPtr != NULL */
/* FIXME to be done */
ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr);
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassTypeConstructorCmd()
*
* Invoked by Tcl during the parsing of a type class definition whenever
* the "typeconstructor" command is invoked to define the typeconstructor
* for an object. Handles the following syntax:
*
* typeconstructor <body>
*
* ------------------------------------------------------------------------
*/
static int
Itcl_ClassTypeConstructorCmd(
ClientData clientData, /* info for all known objects */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
Tcl_Obj *namePtr;
ItclShowArgs(1, "Itcl_ClassTypeConstructorCmd", objc, objv);
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "Error: ::itcl::parser::typeconstructor called from",
" not within a class", NULL);
return TCL_ERROR;
}
if (iclsPtr->flags & ITCL_CLASS) {
Tcl_AppendResult(interp, "a \"class\" cannot have a typeconstructor",
NULL);
return TCL_ERROR;
}
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "body");
return TCL_ERROR;
}
namePtr = objv[0];
if (iclsPtr->typeConstructorPtr != NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"\"", Tcl_GetString(namePtr), "\" already defined in class \"",
Tcl_GetString(iclsPtr->fullNamePtr), "\"",
NULL);
return TCL_ERROR;
}
iclsPtr->typeConstructorPtr = Tcl_NewStringObj(Tcl_GetString(objv[1]), -1);
Tcl_IncrRefCount(iclsPtr->typeConstructorPtr);
return TCL_OK;
}