/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* PACKAGE: [incr Tcl]
|
* PACKAGE: [incr Tcl]
|
* DESCRIPTION: Object-Oriented Extensions to Tcl
|
* DESCRIPTION: Object-Oriented Extensions to Tcl
|
*
|
*
|
* [incr Tcl] provides object-oriented extensions to Tcl, much as
|
* [incr Tcl] provides object-oriented extensions to Tcl, much as
|
* C++ provides object-oriented extensions to C. It provides a means
|
* C++ provides object-oriented extensions to C. It provides a means
|
* of encapsulating related procedures together with their shared data
|
* of encapsulating related procedures together with their shared data
|
* in a local namespace that is hidden from the outside world. It
|
* in a local namespace that is hidden from the outside world. It
|
* promotes code re-use through inheritance. More than anything else,
|
* promotes code re-use through inheritance. More than anything else,
|
* it encourages better organization of Tcl applications through the
|
* it encourages better organization of Tcl applications through the
|
* object-oriented paradigm, leading to code that is easier to
|
* object-oriented paradigm, leading to code that is easier to
|
* understand and maintain.
|
* understand and maintain.
|
*
|
*
|
* Procedures in this file support the new syntax for [incr Tcl]
|
* Procedures in this file support the new syntax for [incr Tcl]
|
* class definitions:
|
* class definitions:
|
*
|
*
|
* itcl_class <className> {
|
* itcl_class <className> {
|
* inherit <base-class>...
|
* inherit <base-class>...
|
*
|
*
|
* constructor {<arglist>} ?{<init>}? {<body>}
|
* constructor {<arglist>} ?{<init>}? {<body>}
|
* destructor {<body>}
|
* destructor {<body>}
|
*
|
*
|
* method <name> {<arglist>} {<body>}
|
* method <name> {<arglist>} {<body>}
|
* proc <name> {<arglist>} {<body>}
|
* proc <name> {<arglist>} {<body>}
|
* variable <name> ?<init>? ?<config>?
|
* variable <name> ?<init>? ?<config>?
|
* common <name> ?<init>?
|
* common <name> ?<init>?
|
*
|
*
|
* public <thing> ?<args>...?
|
* public <thing> ?<args>...?
|
* protected <thing> ?<args>...?
|
* protected <thing> ?<args>...?
|
* private <thing> ?<args>...?
|
* private <thing> ?<args>...?
|
* }
|
* }
|
*
|
*
|
* ========================================================================
|
* ========================================================================
|
* AUTHOR: Michael J. McLennan
|
* AUTHOR: Michael J. McLennan
|
* Bell Labs Innovations for Lucent Technologies
|
* Bell Labs Innovations for Lucent Technologies
|
* mmclennan@lucent.com
|
* mmclennan@lucent.com
|
* http://www.tcltk.com/itcl
|
* http://www.tcltk.com/itcl
|
*
|
*
|
* RCS: $Id: itcl_parse.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $
|
* RCS: $Id: itcl_parse.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $
|
* ========================================================================
|
* ========================================================================
|
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* See the file "license.terms" for information on usage and redistribution
|
* See the file "license.terms" for information on usage and redistribution
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
*/
|
*/
|
#include "itclInt.h"
|
#include "itclInt.h"
|
|
|
/*
|
/*
|
* Info needed for public/protected/private commands:
|
* Info needed for public/protected/private commands:
|
*/
|
*/
|
typedef struct ProtectionCmdInfo {
|
typedef struct ProtectionCmdInfo {
|
int pLevel; /* protection level */
|
int pLevel; /* protection level */
|
ItclObjectInfo *info; /* info regarding all known objects */
|
ItclObjectInfo *info; /* info regarding all known objects */
|
} ProtectionCmdInfo;
|
} ProtectionCmdInfo;
|
|
|
/*
|
/*
|
* FORWARD DECLARATIONS
|
* FORWARD DECLARATIONS
|
*/
|
*/
|
static void ItclFreeParserCommandData _ANSI_ARGS_((char* cdata));
|
static void ItclFreeParserCommandData _ANSI_ARGS_((char* cdata));
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ParseInit()
|
* Itcl_ParseInit()
|
*
|
*
|
* Invoked by Itcl_Init() whenever a new interpeter is created to add
|
* Invoked by Itcl_Init() whenever a new interpeter is created to add
|
* [incr Tcl] facilities. Adds the commands needed to parse class
|
* [incr Tcl] facilities. Adds the commands needed to parse class
|
* definitions.
|
* definitions.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ParseInit(interp, info)
|
Itcl_ParseInit(interp, info)
|
Tcl_Interp *interp; /* interpreter to be updated */
|
Tcl_Interp *interp; /* interpreter to be updated */
|
ItclObjectInfo *info; /* info regarding all known objects */
|
ItclObjectInfo *info; /* info regarding all known objects */
|
{
|
{
|
Tcl_Namespace *parserNs;
|
Tcl_Namespace *parserNs;
|
ProtectionCmdInfo *pInfo;
|
ProtectionCmdInfo *pInfo;
|
|
|
/*
|
/*
|
* Create the "itcl::parser" namespace used to parse class
|
* Create the "itcl::parser" namespace used to parse class
|
* definitions.
|
* definitions.
|
*/
|
*/
|
parserNs = Tcl_CreateNamespace(interp, "::itcl::parser",
|
parserNs = Tcl_CreateNamespace(interp, "::itcl::parser",
|
(ClientData)info, Itcl_ReleaseData);
|
(ClientData)info, Itcl_ReleaseData);
|
|
|
if (!parserNs) {
|
if (!parserNs) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
" (cannot initialize itcl parser)",
|
" (cannot initialize itcl parser)",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Itcl_PreserveData((ClientData)info);
|
Itcl_PreserveData((ClientData)info);
|
|
|
/*
|
/*
|
* Add commands for parsing class definitions.
|
* Add commands for parsing class definitions.
|
*/
|
*/
|
Tcl_CreateObjCommand(interp, "::itcl::parser::inherit",
|
Tcl_CreateObjCommand(interp, "::itcl::parser::inherit",
|
Itcl_ClassInheritCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
Itcl_ClassInheritCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::parser::constructor",
|
Tcl_CreateObjCommand(interp, "::itcl::parser::constructor",
|
Itcl_ClassConstructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
Itcl_ClassConstructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::parser::destructor",
|
Tcl_CreateObjCommand(interp, "::itcl::parser::destructor",
|
Itcl_ClassDestructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
Itcl_ClassDestructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::parser::method",
|
Tcl_CreateObjCommand(interp, "::itcl::parser::method",
|
Itcl_ClassMethodCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
Itcl_ClassMethodCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::parser::proc",
|
Tcl_CreateObjCommand(interp, "::itcl::parser::proc",
|
Itcl_ClassProcCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
Itcl_ClassProcCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::parser::common",
|
Tcl_CreateObjCommand(interp, "::itcl::parser::common",
|
Itcl_ClassCommonCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
Itcl_ClassCommonCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::parser::variable",
|
Tcl_CreateObjCommand(interp, "::itcl::parser::variable",
|
Itcl_ClassVariableCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
Itcl_ClassVariableCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
|
|
pInfo = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo));
|
pInfo = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo));
|
pInfo->pLevel = ITCL_PUBLIC;
|
pInfo->pLevel = ITCL_PUBLIC;
|
pInfo->info = info;
|
pInfo->info = info;
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::parser::public",
|
Tcl_CreateObjCommand(interp, "::itcl::parser::public",
|
Itcl_ClassProtectionCmd, (ClientData)pInfo,
|
Itcl_ClassProtectionCmd, (ClientData)pInfo,
|
(Tcl_CmdDeleteProc*) ItclFreeParserCommandData);
|
(Tcl_CmdDeleteProc*) ItclFreeParserCommandData);
|
|
|
pInfo = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo));
|
pInfo = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo));
|
pInfo->pLevel = ITCL_PROTECTED;
|
pInfo->pLevel = ITCL_PROTECTED;
|
pInfo->info = info;
|
pInfo->info = info;
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::parser::protected",
|
Tcl_CreateObjCommand(interp, "::itcl::parser::protected",
|
Itcl_ClassProtectionCmd, (ClientData)pInfo,
|
Itcl_ClassProtectionCmd, (ClientData)pInfo,
|
(Tcl_CmdDeleteProc*) ItclFreeParserCommandData);
|
(Tcl_CmdDeleteProc*) ItclFreeParserCommandData);
|
|
|
pInfo = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo));
|
pInfo = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo));
|
pInfo->pLevel = ITCL_PRIVATE;
|
pInfo->pLevel = ITCL_PRIVATE;
|
pInfo->info = info;
|
pInfo->info = info;
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::parser::private",
|
Tcl_CreateObjCommand(interp, "::itcl::parser::private",
|
Itcl_ClassProtectionCmd, (ClientData)pInfo,
|
Itcl_ClassProtectionCmd, (ClientData)pInfo,
|
(Tcl_CmdDeleteProc*) ItclFreeParserCommandData);
|
(Tcl_CmdDeleteProc*) ItclFreeParserCommandData);
|
|
|
/*
|
/*
|
* Set the runtime variable resolver for the parser namespace,
|
* Set the runtime variable resolver for the parser namespace,
|
* to control access to "common" data members while parsing
|
* to control access to "common" data members while parsing
|
* the class definition.
|
* the class definition.
|
*/
|
*/
|
Tcl_SetNamespaceResolvers(parserNs, (Tcl_ResolveCmdProc*)NULL,
|
Tcl_SetNamespaceResolvers(parserNs, (Tcl_ResolveCmdProc*)NULL,
|
Itcl_ParseVarResolver, (Tcl_ResolveCompiledVarProc*)NULL);
|
Itcl_ParseVarResolver, (Tcl_ResolveCompiledVarProc*)NULL);
|
|
|
/*
|
/*
|
* Install the "class" command for defining new classes.
|
* Install the "class" command for defining new classes.
|
*/
|
*/
|
Tcl_CreateObjCommand(interp, "::itcl::class", Itcl_ClassCmd,
|
Tcl_CreateObjCommand(interp, "::itcl::class", Itcl_ClassCmd,
|
(ClientData)info, Itcl_ReleaseData);
|
(ClientData)info, Itcl_ReleaseData);
|
Itcl_PreserveData((ClientData)info);
|
Itcl_PreserveData((ClientData)info);
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ClassCmd()
|
* Itcl_ClassCmd()
|
*
|
*
|
* Invoked by Tcl whenever the user issues an "itcl::class" command to
|
* Invoked by Tcl whenever the user issues an "itcl::class" command to
|
* specify a class definition. Handles the following syntax:
|
* specify a class definition. Handles the following syntax:
|
*
|
*
|
* itcl::class <className> {
|
* itcl::class <className> {
|
* inherit <base-class>...
|
* inherit <base-class>...
|
*
|
*
|
* constructor {<arglist>} ?{<init>}? {<body>}
|
* constructor {<arglist>} ?{<init>}? {<body>}
|
* destructor {<body>}
|
* destructor {<body>}
|
*
|
*
|
* method <name> {<arglist>} {<body>}
|
* method <name> {<arglist>} {<body>}
|
* proc <name> {<arglist>} {<body>}
|
* proc <name> {<arglist>} {<body>}
|
* variable <varname> ?<init>? ?<config>?
|
* variable <varname> ?<init>? ?<config>?
|
* common <varname> ?<init>?
|
* common <varname> ?<init>?
|
*
|
*
|
* public <args>...
|
* public <args>...
|
* protected <args>...
|
* protected <args>...
|
* private <args>...
|
* private <args>...
|
* }
|
* }
|
*
|
*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ClassCmd(clientData, interp, objc, objv)
|
Itcl_ClassCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* info for all known objects */
|
ClientData clientData; /* info for all known objects */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
ItclObjectInfo* info = (ItclObjectInfo*)clientData;
|
ItclObjectInfo* info = (ItclObjectInfo*)clientData;
|
|
|
int result;
|
int result;
|
char *className;
|
char *className;
|
Tcl_Namespace *parserNs;
|
Tcl_Namespace *parserNs;
|
ItclClass *cdefnPtr;
|
ItclClass *cdefnPtr;
|
Tcl_CallFrame frame;
|
Tcl_CallFrame frame;
|
|
|
if (objc != 3) {
|
if (objc != 3) {
|
Tcl_WrongNumArgs(interp, 1, objv, "name { definition }");
|
Tcl_WrongNumArgs(interp, 1, objv, "name { definition }");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
className = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
className = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
|
|
/*
|
/*
|
* Find the namespace to use as a parser for the class definition.
|
* Find the namespace to use as a parser for the class definition.
|
* If for some reason it is destroyed, bail out here.
|
* If for some reason it is destroyed, bail out here.
|
*/
|
*/
|
parserNs = Tcl_FindNamespace(interp, "::itcl::parser",
|
parserNs = Tcl_FindNamespace(interp, "::itcl::parser",
|
(Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);
|
(Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);
|
|
|
if (parserNs == NULL) {
|
if (parserNs == NULL) {
|
char msg[256];
|
char msg[256];
|
sprintf(msg, "\n (while parsing class definition for \"%.100s\")",
|
sprintf(msg, "\n (while parsing class definition for \"%.100s\")",
|
className);
|
className);
|
Tcl_AddErrorInfo(interp, msg);
|
Tcl_AddErrorInfo(interp, msg);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Try to create the specified class and its namespace.
|
* Try to create the specified class and its namespace.
|
*/
|
*/
|
if (Itcl_CreateClass(interp, className, info, &cdefnPtr) != TCL_OK) {
|
if (Itcl_CreateClass(interp, className, info, &cdefnPtr) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Import the built-in commands from the itcl::builtin namespace.
|
* Import the built-in commands from the itcl::builtin namespace.
|
* Do this before parsing the class definition, so methods/procs
|
* Do this before parsing the class definition, so methods/procs
|
* can override the built-in commands.
|
* can override the built-in commands.
|
*/
|
*/
|
result = Tcl_Import(interp, cdefnPtr->namesp, "::itcl::builtin::*",
|
result = Tcl_Import(interp, cdefnPtr->namesp, "::itcl::builtin::*",
|
/* allowOverwrite */ 1);
|
/* allowOverwrite */ 1);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
char msg[256];
|
char msg[256];
|
sprintf(msg, "\n (while installing built-in commands for class \"%.100s\")", className);
|
sprintf(msg, "\n (while installing built-in commands for class \"%.100s\")", className);
|
Tcl_AddErrorInfo(interp, msg);
|
Tcl_AddErrorInfo(interp, msg);
|
|
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Push this class onto the class definition stack so that it
|
* Push this class onto the class definition stack so that it
|
* becomes the current context for all commands in the parser.
|
* becomes the current context for all commands in the parser.
|
* Activate the parser and evaluate the class definition.
|
* Activate the parser and evaluate the class definition.
|
*/
|
*/
|
Itcl_PushStack((ClientData)cdefnPtr, &info->cdefnStack);
|
Itcl_PushStack((ClientData)cdefnPtr, &info->cdefnStack);
|
|
|
result = Tcl_PushCallFrame(interp, &frame, parserNs,
|
result = Tcl_PushCallFrame(interp, &frame, parserNs,
|
/* isProcCallFrame */ 0);
|
/* isProcCallFrame */ 0);
|
|
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
/* CYGNUS LOCAL - Fix for Tcl8.1 */
|
/* CYGNUS LOCAL - Fix for Tcl8.1 */
|
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
|
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
|
result = Tcl_EvalObj(interp, objv[2]);
|
result = Tcl_EvalObj(interp, objv[2]);
|
#else
|
#else
|
result = Tcl_EvalObj(interp, objv[2], 0);
|
result = Tcl_EvalObj(interp, objv[2], 0);
|
#endif
|
#endif
|
/* END CYGNUS LOCAL */
|
/* END CYGNUS LOCAL */
|
Tcl_PopCallFrame(interp);
|
Tcl_PopCallFrame(interp);
|
}
|
}
|
Itcl_PopStack(&info->cdefnStack);
|
Itcl_PopStack(&info->cdefnStack);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
char msg[256];
|
char msg[256];
|
sprintf(msg, "\n (class \"%.200s\" body line %d)",
|
sprintf(msg, "\n (class \"%.200s\" body line %d)",
|
className, interp->errorLine);
|
className, interp->errorLine);
|
Tcl_AddErrorInfo(interp, msg);
|
Tcl_AddErrorInfo(interp, msg);
|
|
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* At this point, parsing of the class definition has succeeded.
|
* At this point, parsing of the class definition has succeeded.
|
* Add built-in methods such as "configure" and "cget"--as long
|
* Add built-in methods such as "configure" and "cget"--as long
|
* as they don't conflict with those defined in the class.
|
* as they don't conflict with those defined in the class.
|
*/
|
*/
|
if (Itcl_InstallBiMethods(interp, cdefnPtr) != TCL_OK) {
|
if (Itcl_InstallBiMethods(interp, cdefnPtr) != TCL_OK) {
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Build the name resolution tables for all data members.
|
* Build the name resolution tables for all data members.
|
*/
|
*/
|
Itcl_BuildVirtualTables(cdefnPtr);
|
Itcl_BuildVirtualTables(cdefnPtr);
|
|
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ClassInheritCmd()
|
* Itcl_ClassInheritCmd()
|
*
|
*
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* the "inherit" command is invoked to define one or more base classes.
|
* the "inherit" command is invoked to define one or more base classes.
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* inherit <baseclass> ?<baseclass>...?
|
* inherit <baseclass> ?<baseclass>...?
|
*
|
*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ClassInheritCmd(clientData, interp, objc, objv)
|
Itcl_ClassInheritCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* info for all known objects */
|
ClientData clientData; /* info for all known objects */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
|
|
int result, i, newEntry;
|
int result, i, newEntry;
|
char *token;
|
char *token;
|
Itcl_ListElem *elem, *elem2;
|
Itcl_ListElem *elem, *elem2;
|
ItclClass *cdPtr, *baseCdefnPtr, *badCdPtr;
|
ItclClass *cdPtr, *baseCdefnPtr, *badCdPtr;
|
ItclHierIter hier;
|
ItclHierIter hier;
|
Itcl_Stack stack;
|
Itcl_Stack stack;
|
Tcl_CallFrame frame;
|
Tcl_CallFrame frame;
|
|
|
if (objc < 2) {
|
if (objc < 2) {
|
Tcl_WrongNumArgs(interp, 1, objv, "class ?class...?");
|
Tcl_WrongNumArgs(interp, 1, objv, "class ?class...?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* In "inherit" statement can only be included once in a
|
* In "inherit" statement can only be included once in a
|
* class definition.
|
* class definition.
|
*/
|
*/
|
elem = Itcl_FirstListElem(&cdefnPtr->bases);
|
elem = Itcl_FirstListElem(&cdefnPtr->bases);
|
if (elem != NULL) {
|
if (elem != NULL) {
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), "inheritance \"", -1);
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), "inheritance \"", -1);
|
|
|
while (elem) {
|
while (elem) {
|
cdPtr = (ItclClass*)Itcl_GetListValue(elem);
|
cdPtr = (ItclClass*)Itcl_GetListValue(elem);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
cdPtr->name, " ", (char*)NULL);
|
cdPtr->name, " ", (char*)NULL);
|
|
|
elem = Itcl_NextListElem(elem);
|
elem = Itcl_NextListElem(elem);
|
}
|
}
|
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\" already defined for class \"", cdefnPtr->fullname, "\"",
|
"\" already defined for class \"", cdefnPtr->fullname, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Validate each base class and add it to the "bases" list.
|
* Validate each base class and add it to the "bases" list.
|
*/
|
*/
|
result = Tcl_PushCallFrame(interp, &frame, cdefnPtr->namesp->parentPtr,
|
result = Tcl_PushCallFrame(interp, &frame, cdefnPtr->namesp->parentPtr,
|
/* isProcCallFrame */ 0);
|
/* isProcCallFrame */ 0);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
for (objc--,objv++; objc > 0; objc--,objv++) {
|
for (objc--,objv++; objc > 0; objc--,objv++) {
|
|
|
/*
|
/*
|
* Make sure that the base class name is known in the
|
* Make sure that the base class name is known in the
|
* parent namespace (currently active). If not, try
|
* parent namespace (currently active). If not, try
|
* to autoload its definition.
|
* to autoload its definition.
|
*/
|
*/
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
baseCdefnPtr = Itcl_FindClass(interp, token, /* autoload */ 1);
|
baseCdefnPtr = Itcl_FindClass(interp, token, /* autoload */ 1);
|
if (!baseCdefnPtr) {
|
if (!baseCdefnPtr) {
|
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
|
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
|
int errlen;
|
int errlen;
|
char *errmsg;
|
char *errmsg;
|
|
|
Tcl_IncrRefCount(resultPtr);
|
Tcl_IncrRefCount(resultPtr);
|
errmsg = Tcl_GetStringFromObj(resultPtr, &errlen);
|
errmsg = Tcl_GetStringFromObj(resultPtr, &errlen);
|
|
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"cannot inherit from \"", token, "\"",
|
"cannot inherit from \"", token, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
|
|
if (errlen > 0) {
|
if (errlen > 0) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
" (", errmsg, ")", (char*)NULL);
|
" (", errmsg, ")", (char*)NULL);
|
}
|
}
|
Tcl_DecrRefCount(resultPtr);
|
Tcl_DecrRefCount(resultPtr);
|
goto inheritError;
|
goto inheritError;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure that the base class is not the same as the
|
* Make sure that the base class is not the same as the
|
* class that is being built.
|
* class that is being built.
|
*/
|
*/
|
if (baseCdefnPtr == cdefnPtr) {
|
if (baseCdefnPtr == cdefnPtr) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"class \"", cdefnPtr->name, "\" cannot inherit from itself",
|
"class \"", cdefnPtr->name, "\" cannot inherit from itself",
|
(char*)NULL);
|
(char*)NULL);
|
goto inheritError;
|
goto inheritError;
|
}
|
}
|
|
|
Itcl_AppendList(&cdefnPtr->bases, (ClientData)baseCdefnPtr);
|
Itcl_AppendList(&cdefnPtr->bases, (ClientData)baseCdefnPtr);
|
Itcl_PreserveData((ClientData)baseCdefnPtr);
|
Itcl_PreserveData((ClientData)baseCdefnPtr);
|
}
|
}
|
|
|
/*
|
/*
|
* Scan through the inheritance list to make sure that no
|
* Scan through the inheritance list to make sure that no
|
* class appears twice.
|
* class appears twice.
|
*/
|
*/
|
elem = Itcl_FirstListElem(&cdefnPtr->bases);
|
elem = Itcl_FirstListElem(&cdefnPtr->bases);
|
while (elem) {
|
while (elem) {
|
elem2 = Itcl_NextListElem(elem);
|
elem2 = Itcl_NextListElem(elem);
|
while (elem2) {
|
while (elem2) {
|
if (Itcl_GetListValue(elem) == Itcl_GetListValue(elem2)) {
|
if (Itcl_GetListValue(elem) == Itcl_GetListValue(elem2)) {
|
cdPtr = (ItclClass*)Itcl_GetListValue(elem);
|
cdPtr = (ItclClass*)Itcl_GetListValue(elem);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"class \"", cdefnPtr->fullname,
|
"class \"", cdefnPtr->fullname,
|
"\" cannot inherit base class \"",
|
"\" cannot inherit base class \"",
|
cdPtr->fullname, "\" more than once",
|
cdPtr->fullname, "\" more than once",
|
(char*)NULL);
|
(char*)NULL);
|
goto inheritError;
|
goto inheritError;
|
}
|
}
|
elem2 = Itcl_NextListElem(elem2);
|
elem2 = Itcl_NextListElem(elem2);
|
}
|
}
|
elem = Itcl_NextListElem(elem);
|
elem = Itcl_NextListElem(elem);
|
}
|
}
|
|
|
/*
|
/*
|
* Add each base class and all of its base classes into
|
* Add each base class and all of its base classes into
|
* the heritage for the current class. Along the way, make
|
* the heritage for the current class. Along the way, make
|
* sure that no class appears twice in the heritage.
|
* sure that no class appears twice in the heritage.
|
*/
|
*/
|
Itcl_InitHierIter(&hier, cdefnPtr);
|
Itcl_InitHierIter(&hier, cdefnPtr);
|
cdPtr = Itcl_AdvanceHierIter(&hier); /* skip the class itself */
|
cdPtr = Itcl_AdvanceHierIter(&hier); /* skip the class itself */
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
while (cdPtr != NULL) {
|
while (cdPtr != NULL) {
|
(void) Tcl_CreateHashEntry(&cdefnPtr->heritage,
|
(void) Tcl_CreateHashEntry(&cdefnPtr->heritage,
|
(char*)cdPtr, &newEntry);
|
(char*)cdPtr, &newEntry);
|
|
|
if (!newEntry) {
|
if (!newEntry) {
|
break;
|
break;
|
}
|
}
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
}
|
}
|
Itcl_DeleteHierIter(&hier);
|
Itcl_DeleteHierIter(&hier);
|
|
|
/*
|
/*
|
* Same base class found twice in the hierarchy?
|
* Same base class found twice in the hierarchy?
|
* Then flag error. Show the list of multiple paths
|
* Then flag error. Show the list of multiple paths
|
* leading to the same base class.
|
* leading to the same base class.
|
*/
|
*/
|
if (!newEntry) {
|
if (!newEntry) {
|
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
|
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
|
|
|
badCdPtr = cdPtr;
|
badCdPtr = cdPtr;
|
Tcl_AppendStringsToObj(resultPtr,
|
Tcl_AppendStringsToObj(resultPtr,
|
"class \"", cdefnPtr->fullname, "\" inherits base class \"",
|
"class \"", cdefnPtr->fullname, "\" inherits base class \"",
|
badCdPtr->fullname, "\" more than once:",
|
badCdPtr->fullname, "\" more than once:",
|
(char*)NULL);
|
(char*)NULL);
|
|
|
cdPtr = cdefnPtr;
|
cdPtr = cdefnPtr;
|
Itcl_InitStack(&stack);
|
Itcl_InitStack(&stack);
|
Itcl_PushStack((ClientData)cdPtr, &stack);
|
Itcl_PushStack((ClientData)cdPtr, &stack);
|
|
|
/*
|
/*
|
* Show paths leading to bad base class
|
* Show paths leading to bad base class
|
*/
|
*/
|
while (Itcl_GetStackSize(&stack) > 0) {
|
while (Itcl_GetStackSize(&stack) > 0) {
|
cdPtr = (ItclClass*)Itcl_PopStack(&stack);
|
cdPtr = (ItclClass*)Itcl_PopStack(&stack);
|
|
|
if (cdPtr == badCdPtr) {
|
if (cdPtr == badCdPtr) {
|
Tcl_AppendToObj(resultPtr, "\n ", -1);
|
Tcl_AppendToObj(resultPtr, "\n ", -1);
|
for (i=0; i < Itcl_GetStackSize(&stack); i++) {
|
for (i=0; i < Itcl_GetStackSize(&stack); i++) {
|
if (Itcl_GetStackValue(&stack, i) == NULL) {
|
if (Itcl_GetStackValue(&stack, i) == NULL) {
|
cdPtr = (ItclClass*)Itcl_GetStackValue(&stack, i-1);
|
cdPtr = (ItclClass*)Itcl_GetStackValue(&stack, i-1);
|
Tcl_AppendStringsToObj(resultPtr,
|
Tcl_AppendStringsToObj(resultPtr,
|
cdPtr->name, "->",
|
cdPtr->name, "->",
|
(char*)NULL);
|
(char*)NULL);
|
}
|
}
|
}
|
}
|
Tcl_AppendToObj(resultPtr, badCdPtr->name, -1);
|
Tcl_AppendToObj(resultPtr, badCdPtr->name, -1);
|
}
|
}
|
else if (!cdPtr) {
|
else if (!cdPtr) {
|
(void)Itcl_PopStack(&stack);
|
(void)Itcl_PopStack(&stack);
|
}
|
}
|
else {
|
else {
|
elem = Itcl_LastListElem(&cdPtr->bases);
|
elem = Itcl_LastListElem(&cdPtr->bases);
|
if (elem) {
|
if (elem) {
|
Itcl_PushStack((ClientData)cdPtr, &stack);
|
Itcl_PushStack((ClientData)cdPtr, &stack);
|
Itcl_PushStack((ClientData)NULL, &stack);
|
Itcl_PushStack((ClientData)NULL, &stack);
|
while (elem) {
|
while (elem) {
|
Itcl_PushStack(Itcl_GetListValue(elem), &stack);
|
Itcl_PushStack(Itcl_GetListValue(elem), &stack);
|
elem = Itcl_PrevListElem(elem);
|
elem = Itcl_PrevListElem(elem);
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
Itcl_DeleteStack(&stack);
|
Itcl_DeleteStack(&stack);
|
goto inheritError;
|
goto inheritError;
|
}
|
}
|
|
|
/*
|
/*
|
* At this point, everything looks good.
|
* At this point, everything looks good.
|
* Finish the installation of the base classes. Update
|
* Finish the installation of the base classes. Update
|
* each base class to recognize the current class as a
|
* each base class to recognize the current class as a
|
* derived class.
|
* derived class.
|
*/
|
*/
|
elem = Itcl_FirstListElem(&cdefnPtr->bases);
|
elem = Itcl_FirstListElem(&cdefnPtr->bases);
|
while (elem) {
|
while (elem) {
|
baseCdefnPtr = (ItclClass*)Itcl_GetListValue(elem);
|
baseCdefnPtr = (ItclClass*)Itcl_GetListValue(elem);
|
|
|
Itcl_AppendList(&baseCdefnPtr->derived, (ClientData)cdefnPtr);
|
Itcl_AppendList(&baseCdefnPtr->derived, (ClientData)cdefnPtr);
|
Itcl_PreserveData((ClientData)cdefnPtr);
|
Itcl_PreserveData((ClientData)cdefnPtr);
|
|
|
elem = Itcl_NextListElem(elem);
|
elem = Itcl_NextListElem(elem);
|
}
|
}
|
|
|
Tcl_PopCallFrame(interp);
|
Tcl_PopCallFrame(interp);
|
return TCL_OK;
|
return TCL_OK;
|
|
|
|
|
/*
|
/*
|
* If the "inherit" list cannot be built properly, tear it
|
* If the "inherit" list cannot be built properly, tear it
|
* down and return an error.
|
* down and return an error.
|
*/
|
*/
|
inheritError:
|
inheritError:
|
Tcl_PopCallFrame(interp);
|
Tcl_PopCallFrame(interp);
|
|
|
elem = Itcl_FirstListElem(&cdefnPtr->bases);
|
elem = Itcl_FirstListElem(&cdefnPtr->bases);
|
while (elem) {
|
while (elem) {
|
Itcl_ReleaseData( Itcl_GetListValue(elem) );
|
Itcl_ReleaseData( Itcl_GetListValue(elem) );
|
elem = Itcl_DeleteListElem(elem);
|
elem = Itcl_DeleteListElem(elem);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ClassProtectionCmd()
|
* Itcl_ClassProtectionCmd()
|
*
|
*
|
* Invoked by Tcl whenever the user issues a protection setting
|
* Invoked by Tcl whenever the user issues a protection setting
|
* command like "public" or "private". Creates commands and
|
* command like "public" or "private". Creates commands and
|
* variables, and assigns a protection level to them. Protection
|
* variables, and assigns a protection level to them. Protection
|
* levels are defined as follows:
|
* levels are defined as follows:
|
*
|
*
|
* public => accessible from any namespace
|
* public => accessible from any namespace
|
* protected => accessible from selected namespaces
|
* protected => accessible from selected namespaces
|
* private => accessible only in the namespace where it was defined
|
* private => accessible only in the namespace where it was defined
|
*
|
*
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* public <command> ?<arg> <arg>...?
|
* public <command> ?<arg> <arg>...?
|
*
|
*
|
* Returns TCL_OK/TCL_ERROR to indicate success/failure.
|
* Returns TCL_OK/TCL_ERROR to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ClassProtectionCmd(clientData, interp, objc, objv)
|
Itcl_ClassProtectionCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* protection level (public/protected/private) */
|
ClientData clientData; /* protection level (public/protected/private) */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
ProtectionCmdInfo *pInfo = (ProtectionCmdInfo*)clientData;
|
ProtectionCmdInfo *pInfo = (ProtectionCmdInfo*)clientData;
|
|
|
int result;
|
int result;
|
int oldLevel;
|
int oldLevel;
|
|
|
if (objc < 2) {
|
if (objc < 2) {
|
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg arg...?");
|
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg arg...?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
oldLevel = Itcl_Protection(interp, pInfo->pLevel);
|
oldLevel = Itcl_Protection(interp, pInfo->pLevel);
|
|
|
if (objc == 2) {
|
if (objc == 2) {
|
/* CYGNUS LOCAL - Fix for Tcl8.1 */
|
/* CYGNUS LOCAL - Fix for Tcl8.1 */
|
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
|
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
|
result = Tcl_EvalObj(interp, objv[1]);
|
result = Tcl_EvalObj(interp, objv[1]);
|
#else
|
#else
|
result = Tcl_EvalObj(interp, objv[1], 0);
|
result = Tcl_EvalObj(interp, objv[1], 0);
|
#endif
|
#endif
|
/* END CYGNUS LOCAL */
|
/* END CYGNUS LOCAL */
|
} else {
|
} else {
|
result = Itcl_EvalArgs(interp, objc-1, objv+1);
|
result = Itcl_EvalArgs(interp, objc-1, objv+1);
|
}
|
}
|
|
|
if (result == TCL_BREAK) {
|
if (result == TCL_BREAK) {
|
Tcl_SetResult(interp, "invoked \"break\" outside of a loop",
|
Tcl_SetResult(interp, "invoked \"break\" outside of a loop",
|
TCL_STATIC);
|
TCL_STATIC);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
}
|
}
|
else if (result == TCL_CONTINUE) {
|
else if (result == TCL_CONTINUE) {
|
Tcl_SetResult(interp, "invoked \"continue\" outside of a loop",
|
Tcl_SetResult(interp, "invoked \"continue\" outside of a loop",
|
TCL_STATIC);
|
TCL_STATIC);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
}
|
}
|
else if (result != TCL_OK) {
|
else if (result != TCL_OK) {
|
char mesg[256], *token;
|
char mesg[256], *token;
|
token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
sprintf(mesg, "\n (%.100s body line %d)", token, interp->errorLine);
|
sprintf(mesg, "\n (%.100s body line %d)", token, interp->errorLine);
|
Tcl_AddErrorInfo(interp, mesg);
|
Tcl_AddErrorInfo(interp, mesg);
|
}
|
}
|
|
|
Itcl_Protection(interp, oldLevel);
|
Itcl_Protection(interp, oldLevel);
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ClassConstructorCmd()
|
* Itcl_ClassConstructorCmd()
|
*
|
*
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* the "constructor" command is invoked to define the constructor
|
* the "constructor" command is invoked to define the constructor
|
* for an object. Handles the following syntax:
|
* for an object. Handles the following syntax:
|
*
|
*
|
* constructor <arglist> ?<init>? <body>
|
* constructor <arglist> ?<init>? <body>
|
*
|
*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ClassConstructorCmd(clientData, interp, objc, objv)
|
Itcl_ClassConstructorCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* info for all known objects */
|
ClientData clientData; /* info for all known objects */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
|
|
char *name, *arglist, *body;
|
char *name, *arglist, *body;
|
|
|
if (objc < 3 || objc > 4) {
|
if (objc < 3 || objc > 4) {
|
Tcl_WrongNumArgs(interp, 1, objv, "args ?init? body");
|
Tcl_WrongNumArgs(interp, 1, objv, "args ?init? body");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
if (Tcl_FindHashEntry(&cdefnPtr->functions, name)) {
|
if (Tcl_FindHashEntry(&cdefnPtr->functions, name)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\"", name, "\" already defined in class \"",
|
"\"", name, "\" already defined in class \"",
|
cdefnPtr->fullname, "\"",
|
cdefnPtr->fullname, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If there is an object initialization statement, pick this
|
* If there is an object initialization statement, pick this
|
* out and take the last argument as the constructor body.
|
* out and take the last argument as the constructor body.
|
*/
|
*/
|
arglist = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
arglist = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
if (objc == 3) {
|
if (objc == 3) {
|
body = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
body = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
} else {
|
} else {
|
cdefnPtr->initCode = objv[2];
|
cdefnPtr->initCode = objv[2];
|
Tcl_IncrRefCount(cdefnPtr->initCode);
|
Tcl_IncrRefCount(cdefnPtr->initCode);
|
body = Tcl_GetStringFromObj(objv[3], (int*)NULL);
|
body = Tcl_GetStringFromObj(objv[3], (int*)NULL);
|
}
|
}
|
|
|
if (Itcl_CreateMethod(interp, cdefnPtr, name, arglist, body) != TCL_OK) {
|
if (Itcl_CreateMethod(interp, cdefnPtr, name, arglist, body) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ClassDestructorCmd()
|
* Itcl_ClassDestructorCmd()
|
*
|
*
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* the "destructor" command is invoked to define the destructor
|
* the "destructor" command is invoked to define the destructor
|
* for an object. Handles the following syntax:
|
* for an object. Handles the following syntax:
|
*
|
*
|
* destructor <body>
|
* destructor <body>
|
*
|
*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ClassDestructorCmd(clientData, interp, objc, objv)
|
Itcl_ClassDestructorCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* info for all known objects */
|
ClientData clientData; /* info for all known objects */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
|
|
char *name, *body;
|
char *name, *body;
|
|
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 1, objv, "body");
|
Tcl_WrongNumArgs(interp, 1, objv, "body");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
body = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
body = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
|
|
if (Tcl_FindHashEntry(&cdefnPtr->functions, name)) {
|
if (Tcl_FindHashEntry(&cdefnPtr->functions, name)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\"", name, "\" already defined in class \"",
|
"\"", name, "\" already defined in class \"",
|
cdefnPtr->fullname, "\"",
|
cdefnPtr->fullname, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (Itcl_CreateMethod(interp, cdefnPtr, name, (char*)NULL, body)
|
if (Itcl_CreateMethod(interp, cdefnPtr, name, (char*)NULL, body)
|
!= TCL_OK) {
|
!= TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ClassMethodCmd()
|
* Itcl_ClassMethodCmd()
|
*
|
*
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* the "method" command is invoked to define an object method.
|
* the "method" command is invoked to define an object method.
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* method <name> ?<arglist>? ?<body>?
|
* method <name> ?<arglist>? ?<body>?
|
*
|
*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ClassMethodCmd(clientData, interp, objc, objv)
|
Itcl_ClassMethodCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* info for all known objects */
|
ClientData clientData; /* info for all known objects */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
|
|
char *name, *arglist, *body;
|
char *name, *arglist, *body;
|
|
|
if (objc < 2 || objc > 4) {
|
if (objc < 2 || objc > 4) {
|
Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?");
|
Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
|
|
arglist = NULL;
|
arglist = NULL;
|
body = NULL;
|
body = NULL;
|
if (objc >= 3) {
|
if (objc >= 3) {
|
arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
}
|
}
|
if (objc >= 4) {
|
if (objc >= 4) {
|
body = Tcl_GetStringFromObj(objv[3], (int*)NULL);
|
body = Tcl_GetStringFromObj(objv[3], (int*)NULL);
|
}
|
}
|
|
|
if (Itcl_CreateMethod(interp, cdefnPtr, name, arglist, body) != TCL_OK) {
|
if (Itcl_CreateMethod(interp, cdefnPtr, name, arglist, body) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ClassProcCmd()
|
* Itcl_ClassProcCmd()
|
*
|
*
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* the "proc" command is invoked to define a common class proc.
|
* the "proc" command is invoked to define a common class proc.
|
* A "proc" is like a "method", but only has access to "common"
|
* A "proc" is like a "method", but only has access to "common"
|
* class variables. Handles the following syntax:
|
* class variables. Handles the following syntax:
|
*
|
*
|
* proc <name> ?<arglist>? ?<body>?
|
* proc <name> ?<arglist>? ?<body>?
|
*
|
*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ClassProcCmd(clientData, interp, objc, objv)
|
Itcl_ClassProcCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* info for all known objects */
|
ClientData clientData; /* info for all known objects */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
char *name, *arglist, *body;
|
char *name, *arglist, *body;
|
|
|
if (objc < 2 || objc > 4) {
|
if (objc < 2 || objc > 4) {
|
Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?");
|
Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
|
|
arglist = NULL;
|
arglist = NULL;
|
body = NULL;
|
body = NULL;
|
if (objc >= 3) {
|
if (objc >= 3) {
|
arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
}
|
}
|
if (objc >= 4) {
|
if (objc >= 4) {
|
body = Tcl_GetStringFromObj(objv[3], (int*)NULL);
|
body = Tcl_GetStringFromObj(objv[3], (int*)NULL);
|
}
|
}
|
|
|
if (Itcl_CreateProc(interp, cdefnPtr, name, arglist, body) != TCL_OK) {
|
if (Itcl_CreateProc(interp, cdefnPtr, name, arglist, body) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ClassVariableCmd()
|
* Itcl_ClassVariableCmd()
|
*
|
*
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* the "variable" command is invoked to define an instance variable.
|
* the "variable" command is invoked to define an instance variable.
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* variable <varname> ?<init>? ?<config>?
|
* variable <varname> ?<init>? ?<config>?
|
*
|
*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ClassVariableCmd(clientData, interp, objc, objv)
|
Itcl_ClassVariableCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* info for all known objects */
|
ClientData clientData; /* info for all known objects */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
|
|
int pLevel;
|
int pLevel;
|
ItclVarDefn *vdefn;
|
ItclVarDefn *vdefn;
|
char *name, *init, *config;
|
char *name, *init, *config;
|
|
|
pLevel = Itcl_Protection(interp, 0);
|
pLevel = Itcl_Protection(interp, 0);
|
|
|
if (pLevel == ITCL_PUBLIC) {
|
if (pLevel == ITCL_PUBLIC) {
|
if (objc < 2 || objc > 4) {
|
if (objc < 2 || objc > 4) {
|
Tcl_WrongNumArgs(interp, 1, objv, "name ?init? ?config?");
|
Tcl_WrongNumArgs(interp, 1, objv, "name ?init? ?config?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
else if ((objc < 2) || (objc > 3)) {
|
else if ((objc < 2) || (objc > 3)) {
|
Tcl_WrongNumArgs(interp, 1, objv, "name ?init?");
|
Tcl_WrongNumArgs(interp, 1, objv, "name ?init?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure that the variable name does not contain anything
|
* Make sure that the variable name does not contain anything
|
* goofy like a "::" scope qualifier.
|
* goofy like a "::" scope qualifier.
|
*/
|
*/
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
if (strstr(name, "::")) {
|
if (strstr(name, "::")) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad variable name \"", name, "\"",
|
"bad variable name \"", name, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
init = NULL;
|
init = NULL;
|
config = NULL;
|
config = NULL;
|
if (objc >= 3) {
|
if (objc >= 3) {
|
init = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
init = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
}
|
}
|
if (objc >= 4) {
|
if (objc >= 4) {
|
config = Tcl_GetStringFromObj(objv[3], (int*)NULL);
|
config = Tcl_GetStringFromObj(objv[3], (int*)NULL);
|
}
|
}
|
|
|
if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, config,
|
if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, config,
|
&vdefn) != TCL_OK) {
|
&vdefn) != TCL_OK) {
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ClassCommonCmd()
|
* Itcl_ClassCommonCmd()
|
*
|
*
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* the "common" command is invoked to define a variable that is
|
* the "common" command is invoked to define a variable that is
|
* common to all objects in the class. Handles the following syntax:
|
* common to all objects in the class. Handles the following syntax:
|
*
|
*
|
* common <varname> ?<init>?
|
* common <varname> ?<init>?
|
*
|
*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ClassCommonCmd(clientData, interp, objc, objv)
|
Itcl_ClassCommonCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* info for all known objects */
|
ClientData clientData; /* info for all known objects */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
|
|
int newEntry;
|
int newEntry;
|
char *name, *init;
|
char *name, *init;
|
ItclVarDefn *vdefn;
|
ItclVarDefn *vdefn;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
Namespace *nsPtr;
|
Namespace *nsPtr;
|
Var *varPtr;
|
Var *varPtr;
|
|
|
if ((objc < 2) || (objc > 3)) {
|
if ((objc < 2) || (objc > 3)) {
|
Tcl_WrongNumArgs(interp, 1, objv, "varname ?init?");
|
Tcl_WrongNumArgs(interp, 1, objv, "varname ?init?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure that the variable name does not contain anything
|
* Make sure that the variable name does not contain anything
|
* goofy like a "::" scope qualifier.
|
* goofy like a "::" scope qualifier.
|
*/
|
*/
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
if (strstr(name, "::")) {
|
if (strstr(name, "::")) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad variable name \"", name, "\"",
|
"bad variable name \"", name, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
init = NULL;
|
init = NULL;
|
if (objc >= 3) {
|
if (objc >= 3) {
|
init = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
init = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
}
|
}
|
|
|
if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, (char*)NULL,
|
if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, (char*)NULL,
|
&vdefn) != TCL_OK) {
|
&vdefn) != TCL_OK) {
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
vdefn->member->flags |= ITCL_COMMON;
|
vdefn->member->flags |= ITCL_COMMON;
|
|
|
/*
|
/*
|
* Create the variable in the namespace associated with the
|
* Create the variable in the namespace associated with the
|
* class. Do this the hard way, to avoid the variable resolver
|
* class. Do this the hard way, to avoid the variable resolver
|
* procedures. These procedures won't work until we rebuild
|
* procedures. These procedures won't work until we rebuild
|
* the virtual tables below.
|
* the virtual tables below.
|
*/
|
*/
|
nsPtr = (Namespace*)cdefnPtr->namesp;
|
nsPtr = (Namespace*)cdefnPtr->namesp;
|
entry = Tcl_CreateHashEntry(&nsPtr->varTable,
|
entry = Tcl_CreateHashEntry(&nsPtr->varTable,
|
vdefn->member->name, &newEntry);
|
vdefn->member->name, &newEntry);
|
|
|
varPtr = _TclNewVar();
|
varPtr = _TclNewVar();
|
varPtr->hPtr = entry;
|
varPtr->hPtr = entry;
|
varPtr->nsPtr = nsPtr;
|
varPtr->nsPtr = nsPtr;
|
varPtr->flags |= VAR_NAMESPACE_VAR;
|
varPtr->flags |= VAR_NAMESPACE_VAR;
|
varPtr->refCount++; /* one use by namespace */
|
varPtr->refCount++; /* one use by namespace */
|
varPtr->refCount++; /* another use by class */
|
varPtr->refCount++; /* another use by class */
|
|
|
Tcl_SetHashValue(entry, varPtr);
|
Tcl_SetHashValue(entry, varPtr);
|
|
|
/*
|
/*
|
* TRICKY NOTE: Make sure to rebuild the virtual tables for this
|
* TRICKY NOTE: Make sure to rebuild the virtual tables for this
|
* class so that this variable is ready to access. The variable
|
* class so that this variable is ready to access. The variable
|
* resolver for the parser namespace needs this info to find the
|
* resolver for the parser namespace needs this info to find the
|
* variable if the developer tries to set it within the class
|
* variable if the developer tries to set it within the class
|
* definition.
|
* definition.
|
*
|
*
|
* If an initialization value was specified, then initialize
|
* If an initialization value was specified, then initialize
|
* the variable now.
|
* the variable now.
|
*/
|
*/
|
Itcl_BuildVirtualTables(cdefnPtr);
|
Itcl_BuildVirtualTables(cdefnPtr);
|
|
|
if (init) {
|
if (init) {
|
init = Tcl_SetVar(interp, vdefn->member->name, init,
|
init = Tcl_SetVar(interp, vdefn->member->name, init,
|
TCL_NAMESPACE_ONLY);
|
TCL_NAMESPACE_ONLY);
|
|
|
if (!init) {
|
if (!init) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"cannot initialize common variable \"",
|
"cannot initialize common variable \"",
|
vdefn->member->name, "\"",
|
vdefn->member->name, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ParseVarResolver()
|
* Itcl_ParseVarResolver()
|
*
|
*
|
* Used by the "parser" namespace to resolve variable accesses to
|
* Used by the "parser" namespace to resolve variable accesses to
|
* common variables. The runtime resolver procedure is consulted
|
* common variables. The runtime resolver procedure is consulted
|
* whenever a variable is accessed within the namespace. It can
|
* whenever a variable is accessed within the namespace. It can
|
* deny access to certain variables, or perform special lookups itself.
|
* deny access to certain variables, or perform special lookups itself.
|
*
|
*
|
* This procedure allows access only to "common" class variables that
|
* This procedure allows access only to "common" class variables that
|
* have been declared within the class or inherited from another class.
|
* have been declared within the class or inherited from another class.
|
* A "set" command can be used to initialized common data members within
|
* A "set" command can be used to initialized common data members within
|
* the body of the class definition itself:
|
* the body of the class definition itself:
|
*
|
*
|
* itcl::class Foo {
|
* itcl::class Foo {
|
* common colors
|
* common colors
|
* set colors(red) #ff0000
|
* set colors(red) #ff0000
|
* set colors(green) #00ff00
|
* set colors(green) #00ff00
|
* set colors(blue) #0000ff
|
* set colors(blue) #0000ff
|
* ...
|
* ...
|
* }
|
* }
|
*
|
*
|
* itcl::class Bar {
|
* itcl::class Bar {
|
* inherit Foo
|
* inherit Foo
|
* set colors(gray) #a0a0a0
|
* set colors(gray) #a0a0a0
|
* set colors(white) #ffffff
|
* set colors(white) #ffffff
|
*
|
*
|
* common numbers
|
* common numbers
|
* set numbers(0) zero
|
* set numbers(0) zero
|
* set numbers(1) one
|
* set numbers(1) one
|
* }
|
* }
|
*
|
*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Itcl_ParseVarResolver(interp, name, contextNs, flags, rPtr)
|
Itcl_ParseVarResolver(interp, name, contextNs, flags, rPtr)
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
char* name; /* name of the variable being accessed */
|
char* name; /* name of the variable being accessed */
|
Tcl_Namespace *contextNs; /* namespace context */
|
Tcl_Namespace *contextNs; /* namespace context */
|
int flags; /* TCL_GLOBAL_ONLY => global variable
|
int flags; /* TCL_GLOBAL_ONLY => global variable
|
* TCL_NAMESPACE_ONLY => namespace variable */
|
* TCL_NAMESPACE_ONLY => namespace variable */
|
Tcl_Var* rPtr; /* returns: Tcl_Var for desired variable */
|
Tcl_Var* rPtr; /* returns: Tcl_Var for desired variable */
|
{
|
{
|
ItclObjectInfo *info = (ItclObjectInfo*)contextNs->clientData;
|
ItclObjectInfo *info = (ItclObjectInfo*)contextNs->clientData;
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
|
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclVarLookup *vlookup;
|
ItclVarLookup *vlookup;
|
|
|
/*
|
/*
|
* See if the requested variable is a recognized "common" member.
|
* See if the requested variable is a recognized "common" member.
|
* If it is, make sure that access is allowed.
|
* If it is, make sure that access is allowed.
|
*/
|
*/
|
entry = Tcl_FindHashEntry(&cdefnPtr->resolveVars, name);
|
entry = Tcl_FindHashEntry(&cdefnPtr->resolveVars, name);
|
if (entry) {
|
if (entry) {
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
|
|
if ((vlookup->vdefn->member->flags & ITCL_COMMON) != 0) {
|
if ((vlookup->vdefn->member->flags & ITCL_COMMON) != 0) {
|
if (!vlookup->accessible) {
|
if (!vlookup->accessible) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"can't access \"", name, "\": ",
|
"can't access \"", name, "\": ",
|
Itcl_ProtectionStr(vlookup->vdefn->member->protection),
|
Itcl_ProtectionStr(vlookup->vdefn->member->protection),
|
" variable",
|
" variable",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
*rPtr = vlookup->var.common;
|
*rPtr = vlookup->var.common;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* If the variable is not recognized, return TCL_CONTINUE and
|
* If the variable is not recognized, return TCL_CONTINUE and
|
* let lookup continue via the normal name resolution rules.
|
* let lookup continue via the normal name resolution rules.
|
* This is important for variables like "errorInfo"
|
* This is important for variables like "errorInfo"
|
* that might get set while the parser namespace is active.
|
* that might get set while the parser namespace is active.
|
*/
|
*/
|
return TCL_CONTINUE;
|
return TCL_CONTINUE;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclFreeParserCommandData()
|
* ItclFreeParserCommandData()
|
*
|
*
|
* This callback will free() up memory dynamically allocated
|
* This callback will free() up memory dynamically allocated
|
* and passed as the ClientData argument to Tcl_CreateObjCommand.
|
* and passed as the ClientData argument to Tcl_CreateObjCommand.
|
* This callback is required because one can not simply pass
|
* This callback is required because one can not simply pass
|
* a pointer to the free() or ckfree() to Tcl_CreateObjCommand.
|
* a pointer to the free() or ckfree() to Tcl_CreateObjCommand.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
static void
|
static void
|
ItclFreeParserCommandData(cdata)
|
ItclFreeParserCommandData(cdata)
|
char* cdata; /* client data to be destroyed */
|
char* cdata; /* client data to be destroyed */
|
{
|
{
|
ckfree(cdata);
|
ckfree(cdata);
|
}
|
}
|
|
|