/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* 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.
|
*
|
*
|
* These procedures handle commands available within a class scope.
|
* These procedures handle commands available within a class scope.
|
* In [incr Tcl], the term "method" is used for a procedure that has
|
* In [incr Tcl], the term "method" is used for a procedure that has
|
* access to object-specific data, while the term "proc" is used for
|
* access to object-specific data, while the term "proc" is used for
|
* a procedure that has access only to common class data.
|
* a procedure that has access only to common class data.
|
*
|
*
|
* ========================================================================
|
* ========================================================================
|
* 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_methods.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $
|
* RCS: $Id: itcl_methods.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"
|
#include "tclCompile.h"
|
#include "tclCompile.h"
|
|
|
/* CYGNUS LOCAL */
|
/* CYGNUS LOCAL */
|
/* FIXME - it looks like Michael removed the dependance on these... */
|
/* FIXME - it looks like Michael removed the dependance on these... */
|
#if 0
|
#if 0
|
#ifdef __CYGWIN32__
|
#ifdef __CYGWIN32__
|
|
|
/* On cygwin32, this is how we import these variables from the Tcl DLL. */
|
/* On cygwin32, this is how we import these variables from the Tcl DLL. */
|
|
|
extern int *_imp__tclTraceCompile;
|
extern int *_imp__tclTraceCompile;
|
|
|
#define tclTraceCompile (*_imp__tclTraceCompile)
|
#define tclTraceCompile (*_imp__tclTraceCompile)
|
|
|
extern int *_imp__tclTraceExec;
|
extern int *_imp__tclTraceExec;
|
|
|
#define tclTraceExec (*_imp__tclTraceExec)
|
#define tclTraceExec (*_imp__tclTraceExec)
|
|
|
extern Tcl_ObjType *_imp__tclByteCodeType;
|
extern Tcl_ObjType *_imp__tclByteCodeType;
|
|
|
#define tclByteCodeType (*_imp__tclByteCodeType)
|
#define tclByteCodeType (*_imp__tclByteCodeType)
|
|
|
#endif
|
#endif
|
#endif
|
#endif
|
/* END CYGNUS LOCAL */
|
/* END CYGNUS LOCAL */
|
|
|
/*
|
/*
|
* FORWARD DECLARATIONS
|
* FORWARD DECLARATIONS
|
*/
|
*/
|
static int ItclParseConfig _ANSI_ARGS_((Tcl_Interp *interp,
|
static int ItclParseConfig _ANSI_ARGS_((Tcl_Interp *interp,
|
int objc, Tcl_Obj *CONST objv[], ItclObject *contextObj,
|
int objc, Tcl_Obj *CONST objv[], ItclObject *contextObj,
|
int *rargc, ItclVarDefn ***rvars, char ***rvals));
|
int *rargc, ItclVarDefn ***rvars, char ***rvals));
|
|
|
static int ItclHandleConfig _ANSI_ARGS_((Tcl_Interp *interp,
|
static int ItclHandleConfig _ANSI_ARGS_((Tcl_Interp *interp,
|
int argc, ItclVarDefn **vars, char **vals, ItclObject *contextObj));
|
int argc, ItclVarDefn **vars, char **vals, ItclObject *contextObj));
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_BodyCmd()
|
* Itcl_BodyCmd()
|
*
|
*
|
* Invoked by Tcl whenever the user issues an "itcl::body" command to
|
* Invoked by Tcl whenever the user issues an "itcl::body" command to
|
* define or redefine the implementation for a class method/proc.
|
* define or redefine the implementation for a class method/proc.
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* itcl::body <class>::<func> <arglist> <body>
|
* itcl::body <class>::<func> <arglist> <body>
|
*
|
*
|
* Looks for an existing class member function with the name <func>,
|
* Looks for an existing class member function with the name <func>,
|
* and if found, tries to assign the implementation. If an argument
|
* and if found, tries to assign the implementation. If an argument
|
* list was specified in the original declaration, it must match
|
* list was specified in the original declaration, it must match
|
* <arglist> or an error is flagged. If <body> has the form "@name"
|
* <arglist> or an error is flagged. If <body> has the form "@name"
|
* then it is treated as a reference to a C handling procedure;
|
* then it is treated as a reference to a C handling procedure;
|
* otherwise, it is taken as a body of Tcl statements.
|
* otherwise, it is taken as a body of Tcl statements.
|
*
|
*
|
* Returns TCL_OK/TCL_ERROR to indicate success/failure.
|
* Returns TCL_OK/TCL_ERROR to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Itcl_BodyCmd(dummy, interp, objc, objv)
|
Itcl_BodyCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* unused */
|
ClientData dummy; /* unused */
|
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 */
|
{
|
{
|
int status = TCL_OK;
|
int status = TCL_OK;
|
|
|
char *head, *tail, *token, *arglist, *body;
|
char *head, *tail, *token, *arglist, *body;
|
ItclClass *cdefn;
|
ItclClass *cdefn;
|
ItclMemberFunc *mfunc;
|
ItclMemberFunc *mfunc;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
Tcl_DString buffer;
|
Tcl_DString buffer;
|
|
|
if (objc != 4) {
|
if (objc != 4) {
|
token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"wrong # args: should be \"",
|
"wrong # args: should be \"",
|
token, " class::func arglist body\"",
|
token, " class::func arglist body\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Parse the member name "namesp::namesp::class::func".
|
* Parse the member name "namesp::namesp::class::func".
|
* Make sure that a class name was specified, and that the
|
* Make sure that a class name was specified, and that the
|
* class exists.
|
* class exists.
|
*/
|
*/
|
token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
Itcl_ParseNamespPath(token, &buffer, &head, &tail);
|
Itcl_ParseNamespPath(token, &buffer, &head, &tail);
|
|
|
if (!head || *head == '\0') {
|
if (!head || *head == '\0') {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"missing class specifier for body declaration \"", token, "\"",
|
"missing class specifier for body declaration \"", token, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
status = TCL_ERROR;
|
status = TCL_ERROR;
|
goto bodyCmdDone;
|
goto bodyCmdDone;
|
}
|
}
|
|
|
cdefn = Itcl_FindClass(interp, head, /* autoload */ 1);
|
cdefn = Itcl_FindClass(interp, head, /* autoload */ 1);
|
if (cdefn == NULL) {
|
if (cdefn == NULL) {
|
status = TCL_ERROR;
|
status = TCL_ERROR;
|
goto bodyCmdDone;
|
goto bodyCmdDone;
|
}
|
}
|
|
|
/*
|
/*
|
* Find the function and try to change its implementation.
|
* Find the function and try to change its implementation.
|
* Note that command resolution table contains *all* functions,
|
* Note that command resolution table contains *all* functions,
|
* even those in a base class. Make sure that the class
|
* even those in a base class. Make sure that the class
|
* containing the method definition is the requested class.
|
* containing the method definition is the requested class.
|
*/
|
*/
|
if (objc != 4) {
|
if (objc != 4) {
|
token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"wrong # args: should be \"",
|
"wrong # args: should be \"",
|
token, " class::func arglist body\"",
|
token, " class::func arglist body\"",
|
(char*)NULL);
|
(char*)NULL);
|
status = TCL_ERROR;
|
status = TCL_ERROR;
|
goto bodyCmdDone;
|
goto bodyCmdDone;
|
}
|
}
|
|
|
mfunc = NULL;
|
mfunc = NULL;
|
entry = Tcl_FindHashEntry(&cdefn->resolveCmds, tail);
|
entry = Tcl_FindHashEntry(&cdefn->resolveCmds, tail);
|
if (entry) {
|
if (entry) {
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
if (mfunc->member->classDefn != cdefn) {
|
if (mfunc->member->classDefn != cdefn) {
|
mfunc = NULL;
|
mfunc = NULL;
|
}
|
}
|
}
|
}
|
|
|
if (mfunc == NULL) {
|
if (mfunc == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"function \"", tail, "\" is not defined in class \"",
|
"function \"", tail, "\" is not defined in class \"",
|
cdefn->fullname, "\"",
|
cdefn->fullname, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
status = TCL_ERROR;
|
status = TCL_ERROR;
|
goto bodyCmdDone;
|
goto bodyCmdDone;
|
}
|
}
|
|
|
arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
body = Tcl_GetStringFromObj(objv[3], (int*)NULL);
|
body = Tcl_GetStringFromObj(objv[3], (int*)NULL);
|
|
|
if (Itcl_ChangeMemberFunc(interp, mfunc, arglist, body) != TCL_OK) {
|
if (Itcl_ChangeMemberFunc(interp, mfunc, arglist, body) != TCL_OK) {
|
status = TCL_ERROR;
|
status = TCL_ERROR;
|
goto bodyCmdDone;
|
goto bodyCmdDone;
|
}
|
}
|
|
|
bodyCmdDone:
|
bodyCmdDone:
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
return status;
|
return status;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ConfigBodyCmd()
|
* Itcl_ConfigBodyCmd()
|
*
|
*
|
* Invoked by Tcl whenever the user issues an "itcl::configbody" command
|
* Invoked by Tcl whenever the user issues an "itcl::configbody" command
|
* to define or redefine the configuration code associated with a
|
* to define or redefine the configuration code associated with a
|
* public variable. Handles the following syntax:
|
* public variable. Handles the following syntax:
|
*
|
*
|
* itcl::configbody <class>::<publicVar> <body>
|
* itcl::configbody <class>::<publicVar> <body>
|
*
|
*
|
* Looks for an existing public variable with the name <publicVar>,
|
* Looks for an existing public variable with the name <publicVar>,
|
* and if found, tries to assign the implementation. If <body> has
|
* and if found, tries to assign the implementation. If <body> has
|
* the form "@name" then it is treated as a reference to a C handling
|
* the form "@name" then it is treated as a reference to a C handling
|
* procedure; otherwise, it is taken as a body of Tcl statements.
|
* procedure; otherwise, it is taken as a body of Tcl statements.
|
*
|
*
|
* Returns TCL_OK/TCL_ERROR to indicate success/failure.
|
* Returns TCL_OK/TCL_ERROR to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Itcl_ConfigBodyCmd(dummy, interp, objc, objv)
|
Itcl_ConfigBodyCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* unused */
|
ClientData dummy; /* unused */
|
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 */
|
{
|
{
|
int status = TCL_OK;
|
int status = TCL_OK;
|
|
|
char *head, *tail, *token;
|
char *head, *tail, *token;
|
Tcl_DString buffer;
|
Tcl_DString buffer;
|
ItclClass *cdefn;
|
ItclClass *cdefn;
|
ItclVarLookup *vlookup;
|
ItclVarLookup *vlookup;
|
ItclMember *member;
|
ItclMember *member;
|
ItclMemberCode *mcode;
|
ItclMemberCode *mcode;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
|
|
if (objc != 3) {
|
if (objc != 3) {
|
Tcl_WrongNumArgs(interp, 1, objv, "class::option body");
|
Tcl_WrongNumArgs(interp, 1, objv, "class::option body");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Parse the member name "namesp::namesp::class::option".
|
* Parse the member name "namesp::namesp::class::option".
|
* Make sure that a class name was specified, and that the
|
* Make sure that a class name was specified, and that the
|
* class exists.
|
* class exists.
|
*/
|
*/
|
token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
Itcl_ParseNamespPath(token, &buffer, &head, &tail);
|
Itcl_ParseNamespPath(token, &buffer, &head, &tail);
|
|
|
if (!head || *head == '\0') {
|
if (!head || *head == '\0') {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"missing class specifier for body declaration \"", token, "\"",
|
"missing class specifier for body declaration \"", token, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
status = TCL_ERROR;
|
status = TCL_ERROR;
|
goto configBodyCmdDone;
|
goto configBodyCmdDone;
|
}
|
}
|
|
|
cdefn = Itcl_FindClass(interp, head, /* autoload */ 1);
|
cdefn = Itcl_FindClass(interp, head, /* autoload */ 1);
|
if (cdefn == NULL) {
|
if (cdefn == NULL) {
|
status = TCL_ERROR;
|
status = TCL_ERROR;
|
goto configBodyCmdDone;
|
goto configBodyCmdDone;
|
}
|
}
|
|
|
/*
|
/*
|
* Find the variable and change its implementation.
|
* Find the variable and change its implementation.
|
* Note that variable resolution table has *all* variables,
|
* Note that variable resolution table has *all* variables,
|
* even those in a base class. Make sure that the class
|
* even those in a base class. Make sure that the class
|
* containing the variable definition is the requested class.
|
* containing the variable definition is the requested class.
|
*/
|
*/
|
vlookup = NULL;
|
vlookup = NULL;
|
entry = Tcl_FindHashEntry(&cdefn->resolveVars, tail);
|
entry = Tcl_FindHashEntry(&cdefn->resolveVars, tail);
|
if (entry) {
|
if (entry) {
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
if (vlookup->vdefn->member->classDefn != cdefn) {
|
if (vlookup->vdefn->member->classDefn != cdefn) {
|
vlookup = NULL;
|
vlookup = NULL;
|
}
|
}
|
}
|
}
|
|
|
if (vlookup == NULL) {
|
if (vlookup == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"option \"", tail, "\" is not defined in class \"",
|
"option \"", tail, "\" is not defined in class \"",
|
cdefn->fullname, "\"",
|
cdefn->fullname, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
status = TCL_ERROR;
|
status = TCL_ERROR;
|
goto configBodyCmdDone;
|
goto configBodyCmdDone;
|
}
|
}
|
member = vlookup->vdefn->member;
|
member = vlookup->vdefn->member;
|
|
|
if (member->protection != ITCL_PUBLIC) {
|
if (member->protection != ITCL_PUBLIC) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"option \"", member->fullname,
|
"option \"", member->fullname,
|
"\" is not a public configuration option",
|
"\" is not a public configuration option",
|
(char*)NULL);
|
(char*)NULL);
|
status = TCL_ERROR;
|
status = TCL_ERROR;
|
goto configBodyCmdDone;
|
goto configBodyCmdDone;
|
}
|
}
|
|
|
token = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
token = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
|
|
if (Itcl_CreateMemberCode(interp, cdefn, (char*)NULL, token,
|
if (Itcl_CreateMemberCode(interp, cdefn, (char*)NULL, token,
|
&mcode) != TCL_OK) {
|
&mcode) != TCL_OK) {
|
|
|
status = TCL_ERROR;
|
status = TCL_ERROR;
|
goto configBodyCmdDone;
|
goto configBodyCmdDone;
|
}
|
}
|
|
|
Itcl_PreserveData((ClientData)mcode);
|
Itcl_PreserveData((ClientData)mcode);
|
Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode);
|
Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode);
|
|
|
if (member->code) {
|
if (member->code) {
|
Itcl_ReleaseData((ClientData)member->code);
|
Itcl_ReleaseData((ClientData)member->code);
|
}
|
}
|
member->code = mcode;
|
member->code = mcode;
|
|
|
configBodyCmdDone:
|
configBodyCmdDone:
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
return status;
|
return status;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_CreateMethod()
|
* Itcl_CreateMethod()
|
*
|
*
|
* Installs a method into the namespace associated with a class.
|
* Installs a method into the namespace associated with a class.
|
* If another command with the same name is already installed, then
|
* If another command with the same name is already installed, then
|
* it is overwritten.
|
* it is overwritten.
|
*
|
*
|
* Returns TCL_OK on success, or TCL_ERROR (along with an error message
|
* Returns TCL_OK on success, or TCL_ERROR (along with an error message
|
* in the specified interp) if anything goes wrong.
|
* in the specified interp) if anything goes wrong.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_CreateMethod(interp, cdefn, name, arglist, body)
|
Itcl_CreateMethod(interp, cdefn, name, arglist, body)
|
Tcl_Interp* interp; /* interpreter managing this action */
|
Tcl_Interp* interp; /* interpreter managing this action */
|
ItclClass *cdefn; /* class definition */
|
ItclClass *cdefn; /* class definition */
|
char* name; /* name of new method */
|
char* name; /* name of new method */
|
char* arglist; /* space-separated list of arg names */
|
char* arglist; /* space-separated list of arg names */
|
char* body; /* body of commands for the method */
|
char* body; /* body of commands for the method */
|
{
|
{
|
ItclMemberFunc *mfunc;
|
ItclMemberFunc *mfunc;
|
Tcl_DString buffer;
|
Tcl_DString buffer;
|
|
|
/*
|
/*
|
* Make sure that the method name does not contain anything
|
* Make sure that the method name does not contain anything
|
* goofy like a "::" scope qualifier.
|
* goofy like a "::" scope qualifier.
|
*/
|
*/
|
if (strstr(name,"::")) {
|
if (strstr(name,"::")) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad method name \"", name, "\"",
|
"bad method name \"", name, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Create the method definition.
|
* Create the method definition.
|
*/
|
*/
|
if (Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, &mfunc)
|
if (Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, &mfunc)
|
!= TCL_OK) {
|
!= TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Build a fully-qualified name for the method, and install
|
* Build a fully-qualified name for the method, and install
|
* the command handler.
|
* the command handler.
|
*/
|
*/
|
Tcl_DStringInit(&buffer);
|
Tcl_DStringInit(&buffer);
|
Tcl_DStringAppend(&buffer, cdefn->namesp->fullName, -1);
|
Tcl_DStringAppend(&buffer, cdefn->namesp->fullName, -1);
|
Tcl_DStringAppend(&buffer, "::", 2);
|
Tcl_DStringAppend(&buffer, "::", 2);
|
Tcl_DStringAppend(&buffer, name, -1);
|
Tcl_DStringAppend(&buffer, name, -1);
|
name = Tcl_DStringValue(&buffer);
|
name = Tcl_DStringValue(&buffer);
|
|
|
Itcl_PreserveData((ClientData)mfunc);
|
Itcl_PreserveData((ClientData)mfunc);
|
mfunc->accessCmd = Tcl_CreateObjCommand(interp, name, Itcl_ExecMethod,
|
mfunc->accessCmd = Tcl_CreateObjCommand(interp, name, Itcl_ExecMethod,
|
(ClientData)mfunc, Itcl_ReleaseData);
|
(ClientData)mfunc, Itcl_ReleaseData);
|
|
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_CreateProc()
|
* Itcl_CreateProc()
|
*
|
*
|
* Installs a class proc into the namespace associated with a class.
|
* Installs a class proc into the namespace associated with a class.
|
* If another command with the same name is already installed, then
|
* If another command with the same name is already installed, then
|
* it is overwritten. Returns TCL_OK on success, or TCL_ERROR (along
|
* it is overwritten. Returns TCL_OK on success, or TCL_ERROR (along
|
* with an error message in the specified interp) if anything goes
|
* with an error message in the specified interp) if anything goes
|
* wrong.
|
* wrong.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_CreateProc(interp, cdefn, name, arglist, body)
|
Itcl_CreateProc(interp, cdefn, name, arglist, body)
|
Tcl_Interp* interp; /* interpreter managing this action */
|
Tcl_Interp* interp; /* interpreter managing this action */
|
ItclClass *cdefn; /* class definition */
|
ItclClass *cdefn; /* class definition */
|
char* name; /* name of new proc */
|
char* name; /* name of new proc */
|
char* arglist; /* space-separated list of arg names */
|
char* arglist; /* space-separated list of arg names */
|
char* body; /* body of commands for the proc */
|
char* body; /* body of commands for the proc */
|
{
|
{
|
ItclMemberFunc *mfunc;
|
ItclMemberFunc *mfunc;
|
Tcl_DString buffer;
|
Tcl_DString buffer;
|
|
|
/*
|
/*
|
* Make sure that the proc name does not contain anything
|
* Make sure that the proc name does not contain anything
|
* goofy like a "::" scope qualifier.
|
* goofy like a "::" scope qualifier.
|
*/
|
*/
|
if (strstr(name,"::")) {
|
if (strstr(name,"::")) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad proc name \"", name, "\"",
|
"bad proc name \"", name, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Create the proc definition.
|
* Create the proc definition.
|
*/
|
*/
|
if (Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, &mfunc)
|
if (Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, &mfunc)
|
!= TCL_OK) {
|
!= TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Mark procs as "common". This distinguishes them from methods.
|
* Mark procs as "common". This distinguishes them from methods.
|
*/
|
*/
|
mfunc->member->flags |= ITCL_COMMON;
|
mfunc->member->flags |= ITCL_COMMON;
|
|
|
/*
|
/*
|
* Build a fully-qualified name for the proc, and install
|
* Build a fully-qualified name for the proc, and install
|
* the command handler.
|
* the command handler.
|
*/
|
*/
|
Tcl_DStringInit(&buffer);
|
Tcl_DStringInit(&buffer);
|
Tcl_DStringAppend(&buffer, cdefn->namesp->fullName, -1);
|
Tcl_DStringAppend(&buffer, cdefn->namesp->fullName, -1);
|
Tcl_DStringAppend(&buffer, "::", 2);
|
Tcl_DStringAppend(&buffer, "::", 2);
|
Tcl_DStringAppend(&buffer, name, -1);
|
Tcl_DStringAppend(&buffer, name, -1);
|
name = Tcl_DStringValue(&buffer);
|
name = Tcl_DStringValue(&buffer);
|
|
|
Itcl_PreserveData((ClientData)mfunc);
|
Itcl_PreserveData((ClientData)mfunc);
|
mfunc->accessCmd = Tcl_CreateObjCommand(interp, name, Itcl_ExecProc,
|
mfunc->accessCmd = Tcl_CreateObjCommand(interp, name, Itcl_ExecProc,
|
(ClientData)mfunc, Itcl_ReleaseData);
|
(ClientData)mfunc, Itcl_ReleaseData);
|
|
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_CreateMemberFunc()
|
* Itcl_CreateMemberFunc()
|
*
|
*
|
* Creates the data record representing a member function. This
|
* Creates the data record representing a member function. This
|
* includes the argument list and the body of the function. If the
|
* includes the argument list and the body of the function. If the
|
* body is of the form "@name", then it is treated as a label for
|
* body is of the form "@name", then it is treated as a label for
|
* a C procedure registered by Itcl_RegisterC().
|
* a C procedure registered by Itcl_RegisterC().
|
*
|
*
|
* If any errors are encountered, this procedure returns TCL_ERROR
|
* If any errors are encountered, this procedure returns TCL_ERROR
|
* along with an error message in the interpreter. Otherwise, it
|
* along with an error message in the interpreter. Otherwise, it
|
* returns TCL_OK, and "mfuncPtr" returns a pointer to the new
|
* returns TCL_OK, and "mfuncPtr" returns a pointer to the new
|
* member function.
|
* member function.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, mfuncPtr)
|
Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, mfuncPtr)
|
Tcl_Interp* interp; /* interpreter managing this action */
|
Tcl_Interp* interp; /* interpreter managing this action */
|
ItclClass *cdefn; /* class definition */
|
ItclClass *cdefn; /* class definition */
|
char* name; /* name of new member */
|
char* name; /* name of new member */
|
char* arglist; /* space-separated list of arg names */
|
char* arglist; /* space-separated list of arg names */
|
char* body; /* body of commands for the method */
|
char* body; /* body of commands for the method */
|
ItclMemberFunc** mfuncPtr; /* returns: pointer to new method defn */
|
ItclMemberFunc** mfuncPtr; /* returns: pointer to new method defn */
|
{
|
{
|
int newEntry;
|
int newEntry;
|
ItclMemberFunc *mfunc;
|
ItclMemberFunc *mfunc;
|
ItclMemberCode *mcode;
|
ItclMemberCode *mcode;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
|
|
/*
|
/*
|
* Add the member function to the list of functions for
|
* Add the member function to the list of functions for
|
* the class. Make sure that a member function with the
|
* the class. Make sure that a member function with the
|
* same name doesn't already exist.
|
* same name doesn't already exist.
|
*/
|
*/
|
entry = Tcl_CreateHashEntry(&cdefn->functions, name, &newEntry);
|
entry = Tcl_CreateHashEntry(&cdefn->functions, name, &newEntry);
|
|
|
if (!newEntry) {
|
if (!newEntry) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\"", name, "\" already defined in class \"",
|
"\"", name, "\" already defined in class \"",
|
cdefn->fullname, "\"",
|
cdefn->fullname, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Try to create the implementation for this command member.
|
* Try to create the implementation for this command member.
|
*/
|
*/
|
if (Itcl_CreateMemberCode(interp, cdefn, arglist, body,
|
if (Itcl_CreateMemberCode(interp, cdefn, arglist, body,
|
&mcode) != TCL_OK) {
|
&mcode) != TCL_OK) {
|
|
|
Tcl_DeleteHashEntry(entry);
|
Tcl_DeleteHashEntry(entry);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Itcl_PreserveData((ClientData)mcode);
|
Itcl_PreserveData((ClientData)mcode);
|
Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode);
|
Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode);
|
|
|
/*
|
/*
|
* Allocate a member function definition and return.
|
* Allocate a member function definition and return.
|
*/
|
*/
|
mfunc = (ItclMemberFunc*)ckalloc(sizeof(ItclMemberFunc));
|
mfunc = (ItclMemberFunc*)ckalloc(sizeof(ItclMemberFunc));
|
mfunc->member = Itcl_CreateMember(interp, cdefn, name);
|
mfunc->member = Itcl_CreateMember(interp, cdefn, name);
|
mfunc->member->code = mcode;
|
mfunc->member->code = mcode;
|
|
|
if (mfunc->member->protection == ITCL_DEFAULT_PROTECT) {
|
if (mfunc->member->protection == ITCL_DEFAULT_PROTECT) {
|
mfunc->member->protection = ITCL_PUBLIC;
|
mfunc->member->protection = ITCL_PUBLIC;
|
}
|
}
|
|
|
mfunc->arglist = NULL;
|
mfunc->arglist = NULL;
|
mfunc->argcount = 0;
|
mfunc->argcount = 0;
|
mfunc->accessCmd = NULL;
|
mfunc->accessCmd = NULL;
|
|
|
if (arglist) {
|
if (arglist) {
|
mfunc->member->flags |= ITCL_ARG_SPEC;
|
mfunc->member->flags |= ITCL_ARG_SPEC;
|
}
|
}
|
if (mcode->arglist) {
|
if (mcode->arglist) {
|
Itcl_CreateArgList(interp, arglist, &mfunc->argcount, &mfunc->arglist);
|
Itcl_CreateArgList(interp, arglist, &mfunc->argcount, &mfunc->arglist);
|
}
|
}
|
|
|
if (strcmp(name,"constructor") == 0) {
|
if (strcmp(name,"constructor") == 0) {
|
mfunc->member->flags |= ITCL_CONSTRUCTOR;
|
mfunc->member->flags |= ITCL_CONSTRUCTOR;
|
}
|
}
|
if (strcmp(name,"destructor") == 0) {
|
if (strcmp(name,"destructor") == 0) {
|
mfunc->member->flags |= ITCL_DESTRUCTOR;
|
mfunc->member->flags |= ITCL_DESTRUCTOR;
|
}
|
}
|
|
|
Tcl_SetHashValue(entry, (ClientData)mfunc);
|
Tcl_SetHashValue(entry, (ClientData)mfunc);
|
Itcl_PreserveData((ClientData)mfunc);
|
Itcl_PreserveData((ClientData)mfunc);
|
Itcl_EventuallyFree((ClientData)mfunc, Itcl_DeleteMemberFunc);
|
Itcl_EventuallyFree((ClientData)mfunc, Itcl_DeleteMemberFunc);
|
|
|
*mfuncPtr = mfunc;
|
*mfuncPtr = mfunc;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ChangeMemberFunc()
|
* Itcl_ChangeMemberFunc()
|
*
|
*
|
* Modifies the data record representing a member function. This
|
* Modifies the data record representing a member function. This
|
* is usually the body of the function, but can include the argument
|
* is usually the body of the function, but can include the argument
|
* list if it was not defined when the member was first created.
|
* list if it was not defined when the member was first created.
|
* If the body is of the form "@name", then it is treated as a label
|
* If the body is of the form "@name", then it is treated as a label
|
* for a C procedure registered by Itcl_RegisterC().
|
* for a C procedure registered by Itcl_RegisterC().
|
*
|
*
|
* If any errors are encountered, this procedure returns TCL_ERROR
|
* If any errors are encountered, this procedure returns TCL_ERROR
|
* along with an error message in the interpreter. Otherwise, it
|
* along with an error message in the interpreter. Otherwise, it
|
* returns TCL_OK, and "mfuncPtr" returns a pointer to the new
|
* returns TCL_OK, and "mfuncPtr" returns a pointer to the new
|
* member function.
|
* member function.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ChangeMemberFunc(interp, mfunc, arglist, body)
|
Itcl_ChangeMemberFunc(interp, mfunc, arglist, body)
|
Tcl_Interp* interp; /* interpreter managing this action */
|
Tcl_Interp* interp; /* interpreter managing this action */
|
ItclMemberFunc* mfunc; /* command member being changed */
|
ItclMemberFunc* mfunc; /* command member being changed */
|
char* arglist; /* space-separated list of arg names */
|
char* arglist; /* space-separated list of arg names */
|
char* body; /* body of commands for the method */
|
char* body; /* body of commands for the method */
|
{
|
{
|
ItclMemberCode *mcode = NULL;
|
ItclMemberCode *mcode = NULL;
|
Tcl_Obj *objPtr;
|
Tcl_Obj *objPtr;
|
|
|
/*
|
/*
|
* Try to create the implementation for this command member.
|
* Try to create the implementation for this command member.
|
*/
|
*/
|
if (Itcl_CreateMemberCode(interp, mfunc->member->classDefn,
|
if (Itcl_CreateMemberCode(interp, mfunc->member->classDefn,
|
arglist, body, &mcode) != TCL_OK) {
|
arglist, body, &mcode) != TCL_OK) {
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If the argument list was defined when the function was
|
* If the argument list was defined when the function was
|
* created, compare the arg lists or usage strings to make sure
|
* created, compare the arg lists or usage strings to make sure
|
* that the interface is not being redefined.
|
* that the interface is not being redefined.
|
*/
|
*/
|
if ((mfunc->member->flags & ITCL_ARG_SPEC) != 0 &&
|
if ((mfunc->member->flags & ITCL_ARG_SPEC) != 0 &&
|
!Itcl_EquivArgLists(mfunc->arglist, mfunc->argcount,
|
!Itcl_EquivArgLists(mfunc->arglist, mfunc->argcount,
|
mcode->arglist, mcode->argcount)) {
|
mcode->arglist, mcode->argcount)) {
|
|
|
objPtr = Itcl_ArgList(mfunc->argcount, mfunc->arglist);
|
objPtr = Itcl_ArgList(mfunc->argcount, mfunc->arglist);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"argument list changed for function \"",
|
"argument list changed for function \"",
|
mfunc->member->fullname, "\": should be \"",
|
mfunc->member->fullname, "\": should be \"",
|
Tcl_GetStringFromObj(objPtr, (int*)NULL), "\"",
|
Tcl_GetStringFromObj(objPtr, (int*)NULL), "\"",
|
(char*)NULL);
|
(char*)NULL);
|
Tcl_DecrRefCount(objPtr);
|
Tcl_DecrRefCount(objPtr);
|
|
|
Itcl_DeleteMemberCode((char*)mcode);
|
Itcl_DeleteMemberCode((char*)mcode);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Free up the old implementation and install the new one.
|
* Free up the old implementation and install the new one.
|
*/
|
*/
|
Itcl_PreserveData((ClientData)mcode);
|
Itcl_PreserveData((ClientData)mcode);
|
Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode);
|
Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode);
|
|
|
Itcl_ReleaseData((ClientData)mfunc->member->code);
|
Itcl_ReleaseData((ClientData)mfunc->member->code);
|
mfunc->member->code = mcode;
|
mfunc->member->code = mcode;
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_DeleteMemberFunc()
|
* Itcl_DeleteMemberFunc()
|
*
|
*
|
* Destroys all data associated with the given member function definition.
|
* Destroys all data associated with the given member function definition.
|
* Usually invoked by the interpreter when a member function is deleted.
|
* Usually invoked by the interpreter when a member function is deleted.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_DeleteMemberFunc(cdata)
|
Itcl_DeleteMemberFunc(cdata)
|
char* cdata; /* pointer to member function definition */
|
char* cdata; /* pointer to member function definition */
|
{
|
{
|
ItclMemberFunc* mfunc = (ItclMemberFunc*)cdata;
|
ItclMemberFunc* mfunc = (ItclMemberFunc*)cdata;
|
|
|
if (mfunc) {
|
if (mfunc) {
|
Itcl_DeleteMember(mfunc->member);
|
Itcl_DeleteMember(mfunc->member);
|
|
|
if (mfunc->arglist) {
|
if (mfunc->arglist) {
|
Itcl_DeleteArgList(mfunc->arglist);
|
Itcl_DeleteArgList(mfunc->arglist);
|
}
|
}
|
ckfree((char*)mfunc);
|
ckfree((char*)mfunc);
|
}
|
}
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_CreateMemberCode()
|
* Itcl_CreateMemberCode()
|
*
|
*
|
* Creates the data record representing the implementation behind a
|
* Creates the data record representing the implementation behind a
|
* class member function. This includes the argument list and the body
|
* class member function. This includes the argument list and the body
|
* of the function. If the body is of the form "@name", then it is
|
* of the function. If the body is of the form "@name", then it is
|
* treated as a label for a C procedure registered by Itcl_RegisterC().
|
* treated as a label for a C procedure registered by Itcl_RegisterC().
|
*
|
*
|
* The implementation is kept by the member function definition, and
|
* The implementation is kept by the member function definition, and
|
* controlled by a preserve/release paradigm. That way, if it is in
|
* controlled by a preserve/release paradigm. That way, if it is in
|
* use while it is being redefined, it will stay around long enough
|
* use while it is being redefined, it will stay around long enough
|
* to avoid a core dump.
|
* to avoid a core dump.
|
*
|
*
|
* If any errors are encountered, this procedure returns TCL_ERROR
|
* If any errors are encountered, this procedure returns TCL_ERROR
|
* along with an error message in the interpreter. Otherwise, it
|
* along with an error message in the interpreter. Otherwise, it
|
* returns TCL_OK, and "mcodePtr" returns a pointer to the new
|
* returns TCL_OK, and "mcodePtr" returns a pointer to the new
|
* implementation.
|
* implementation.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_CreateMemberCode(interp, cdefn, arglist, body, mcodePtr)
|
Itcl_CreateMemberCode(interp, cdefn, arglist, body, mcodePtr)
|
Tcl_Interp* interp; /* interpreter managing this action */
|
Tcl_Interp* interp; /* interpreter managing this action */
|
ItclClass *cdefn; /* class containing this member */
|
ItclClass *cdefn; /* class containing this member */
|
char* arglist; /* space-separated list of arg names */
|
char* arglist; /* space-separated list of arg names */
|
char* body; /* body of commands for the method */
|
char* body; /* body of commands for the method */
|
ItclMemberCode** mcodePtr; /* returns: pointer to new implementation */
|
ItclMemberCode** mcodePtr; /* returns: pointer to new implementation */
|
{
|
{
|
int argc;
|
int argc;
|
CompiledLocal *args, *localPtr;
|
CompiledLocal *args, *localPtr;
|
ItclMemberCode *mcode;
|
ItclMemberCode *mcode;
|
Proc *procPtr;
|
Proc *procPtr;
|
|
|
/*
|
/*
|
* Allocate some space to hold the implementation.
|
* Allocate some space to hold the implementation.
|
*/
|
*/
|
mcode = (ItclMemberCode*)ckalloc(sizeof(ItclMemberCode));
|
mcode = (ItclMemberCode*)ckalloc(sizeof(ItclMemberCode));
|
mcode->flags = 0;
|
mcode->flags = 0;
|
mcode->argcount = 0;
|
mcode->argcount = 0;
|
mcode->arglist = NULL;
|
mcode->arglist = NULL;
|
mcode->procPtr = NULL;
|
mcode->procPtr = NULL;
|
mcode->cfunc.objCmd = NULL;
|
mcode->cfunc.objCmd = NULL;
|
mcode->clientData = NULL;
|
mcode->clientData = NULL;
|
|
|
if (arglist) {
|
if (arglist) {
|
if (Itcl_CreateArgList(interp, arglist, &argc, &args)
|
if (Itcl_CreateArgList(interp, arglist, &argc, &args)
|
!= TCL_OK) {
|
!= TCL_OK) {
|
|
|
Itcl_DeleteMemberCode((char*)mcode);
|
Itcl_DeleteMemberCode((char*)mcode);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
mcode->argcount = argc;
|
mcode->argcount = argc;
|
mcode->arglist = args;
|
mcode->arglist = args;
|
mcode->flags |= ITCL_ARG_SPEC;
|
mcode->flags |= ITCL_ARG_SPEC;
|
} else {
|
} else {
|
argc = 0;
|
argc = 0;
|
args = NULL;
|
args = NULL;
|
}
|
}
|
|
|
/*
|
/*
|
* Create a standard Tcl Proc representation for this code body.
|
* Create a standard Tcl Proc representation for this code body.
|
* This is required, since the Tcl compiler looks for a proc
|
* This is required, since the Tcl compiler looks for a proc
|
* when handling things such as the call frame context and
|
* when handling things such as the call frame context and
|
* compiled locals.
|
* compiled locals.
|
*/
|
*/
|
procPtr = (Proc*)ckalloc(sizeof(Proc));
|
procPtr = (Proc*)ckalloc(sizeof(Proc));
|
mcode->procPtr = procPtr;
|
mcode->procPtr = procPtr;
|
|
|
procPtr->iPtr = (Interp*)interp;
|
procPtr->iPtr = (Interp*)interp;
|
procPtr->refCount = 1;
|
procPtr->refCount = 1;
|
procPtr->cmdPtr = (Command*)ckalloc(sizeof(Command));
|
procPtr->cmdPtr = (Command*)ckalloc(sizeof(Command));
|
procPtr->cmdPtr->nsPtr = (Namespace*)cdefn->namesp;
|
procPtr->cmdPtr->nsPtr = (Namespace*)cdefn->namesp;
|
|
|
if (body) {
|
if (body) {
|
procPtr->bodyPtr = Tcl_NewStringObj(body, -1);
|
procPtr->bodyPtr = Tcl_NewStringObj(body, -1);
|
Tcl_IncrRefCount(procPtr->bodyPtr);
|
Tcl_IncrRefCount(procPtr->bodyPtr);
|
} else {
|
} else {
|
procPtr->bodyPtr = NULL;
|
procPtr->bodyPtr = NULL;
|
}
|
}
|
|
|
/*
|
/*
|
* Plug the argument list into the "compiled locals" list.
|
* Plug the argument list into the "compiled locals" list.
|
*
|
*
|
* NOTE: The storage for this argument list is owned by
|
* NOTE: The storage for this argument list is owned by
|
* the caller, so although we plug it in here, it is not
|
* the caller, so although we plug it in here, it is not
|
* our responsibility to free it.
|
* our responsibility to free it.
|
*/
|
*/
|
procPtr->firstLocalPtr = args;
|
procPtr->firstLocalPtr = args;
|
procPtr->lastLocalPtr = NULL;
|
procPtr->lastLocalPtr = NULL;
|
|
|
for (localPtr=mcode->arglist; localPtr; localPtr=localPtr->nextPtr) {
|
for (localPtr=mcode->arglist; localPtr; localPtr=localPtr->nextPtr) {
|
procPtr->lastLocalPtr = localPtr;
|
procPtr->lastLocalPtr = localPtr;
|
}
|
}
|
procPtr->numArgs = argc;
|
procPtr->numArgs = argc;
|
procPtr->numCompiledLocals = argc;
|
procPtr->numCompiledLocals = argc;
|
|
|
/*
|
/*
|
* If the body definition starts with '@', then treat the value
|
* If the body definition starts with '@', then treat the value
|
* as a symbolic name for a C procedure.
|
* as a symbolic name for a C procedure.
|
*/
|
*/
|
if (body == NULL) {
|
if (body == NULL) {
|
mcode->flags |= ITCL_IMPLEMENT_NONE;
|
mcode->flags |= ITCL_IMPLEMENT_NONE;
|
}
|
}
|
else if (*body == '@') {
|
else if (*body == '@') {
|
Tcl_CmdProc *argCmdProc;
|
Tcl_CmdProc *argCmdProc;
|
Tcl_ObjCmdProc *objCmdProc;
|
Tcl_ObjCmdProc *objCmdProc;
|
ClientData cdata;
|
ClientData cdata;
|
|
|
if (!Itcl_FindC(interp, body+1, &argCmdProc, &objCmdProc, &cdata)) {
|
if (!Itcl_FindC(interp, body+1, &argCmdProc, &objCmdProc, &cdata)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"no registered C procedure with name \"", body+1, "\"",
|
"no registered C procedure with name \"", body+1, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
Itcl_DeleteMemberCode((char*)mcode);
|
Itcl_DeleteMemberCode((char*)mcode);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (objCmdProc != NULL) {
|
if (objCmdProc != NULL) {
|
mcode->flags |= ITCL_IMPLEMENT_OBJCMD;
|
mcode->flags |= ITCL_IMPLEMENT_OBJCMD;
|
mcode->cfunc.objCmd = objCmdProc;
|
mcode->cfunc.objCmd = objCmdProc;
|
mcode->clientData = cdata;
|
mcode->clientData = cdata;
|
}
|
}
|
else if (argCmdProc != NULL) {
|
else if (argCmdProc != NULL) {
|
mcode->flags |= ITCL_IMPLEMENT_ARGCMD;
|
mcode->flags |= ITCL_IMPLEMENT_ARGCMD;
|
mcode->cfunc.argCmd = argCmdProc;
|
mcode->cfunc.argCmd = argCmdProc;
|
mcode->clientData = cdata;
|
mcode->clientData = cdata;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Otherwise, treat the body as a chunk of Tcl code.
|
* Otherwise, treat the body as a chunk of Tcl code.
|
*/
|
*/
|
else {
|
else {
|
mcode->flags |= ITCL_IMPLEMENT_TCL;
|
mcode->flags |= ITCL_IMPLEMENT_TCL;
|
}
|
}
|
|
|
*mcodePtr = mcode;
|
*mcodePtr = mcode;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_DeleteMemberCode()
|
* Itcl_DeleteMemberCode()
|
*
|
*
|
* Destroys all data associated with the given command implementation.
|
* Destroys all data associated with the given command implementation.
|
* Invoked automatically by Itcl_ReleaseData() when the implementation
|
* Invoked automatically by Itcl_ReleaseData() when the implementation
|
* is no longer being used.
|
* is no longer being used.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_DeleteMemberCode(cdata)
|
Itcl_DeleteMemberCode(cdata)
|
char* cdata; /* pointer to member function definition */
|
char* cdata; /* pointer to member function definition */
|
{
|
{
|
ItclMemberCode* mcode = (ItclMemberCode*)cdata;
|
ItclMemberCode* mcode = (ItclMemberCode*)cdata;
|
|
|
if (mcode->arglist) {
|
if (mcode->arglist) {
|
Itcl_DeleteArgList(mcode->arglist);
|
Itcl_DeleteArgList(mcode->arglist);
|
}
|
}
|
if (mcode->procPtr) {
|
if (mcode->procPtr) {
|
ckfree((char*) mcode->procPtr->cmdPtr);
|
ckfree((char*) mcode->procPtr->cmdPtr);
|
|
|
/* don't free compiled locals -- that is handled by arglist above */
|
/* don't free compiled locals -- that is handled by arglist above */
|
|
|
if (mcode->procPtr->bodyPtr) {
|
if (mcode->procPtr->bodyPtr) {
|
Tcl_DecrRefCount(mcode->procPtr->bodyPtr);
|
Tcl_DecrRefCount(mcode->procPtr->bodyPtr);
|
}
|
}
|
ckfree((char*)mcode->procPtr);
|
ckfree((char*)mcode->procPtr);
|
}
|
}
|
ckfree((char*)mcode);
|
ckfree((char*)mcode);
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_GetMemberCode()
|
* Itcl_GetMemberCode()
|
*
|
*
|
* Makes sure that the implementation for an [incr Tcl] code body is
|
* Makes sure that the implementation for an [incr Tcl] code body is
|
* ready to run. Note that a member function can be declared without
|
* ready to run. Note that a member function can be declared without
|
* being defined. The class definition may contain a declaration of
|
* being defined. The class definition may contain a declaration of
|
* the member function, but its body may be defined in a separate file.
|
* the member function, but its body may be defined in a separate file.
|
* If an undefined function is encountered, this routine automatically
|
* If an undefined function is encountered, this routine automatically
|
* attempts to autoload it. If the body is implemented via Tcl code,
|
* attempts to autoload it. If the body is implemented via Tcl code,
|
* then it is compiled here as well.
|
* then it is compiled here as well.
|
*
|
*
|
* Returns TCL_ERROR (along with an error message in the interpreter)
|
* Returns TCL_ERROR (along with an error message in the interpreter)
|
* if an error is encountered, or if the implementation is not defined
|
* if an error is encountered, or if the implementation is not defined
|
* and cannot be autoloaded. Returns TCL_OK if implementation is
|
* and cannot be autoloaded. Returns TCL_OK if implementation is
|
* ready to use.
|
* ready to use.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_GetMemberCode(interp, member)
|
Itcl_GetMemberCode(interp, member)
|
Tcl_Interp* interp; /* interpreter managing this action */
|
Tcl_Interp* interp; /* interpreter managing this action */
|
ItclMember* member; /* member containing code body */
|
ItclMember* member; /* member containing code body */
|
{
|
{
|
ItclMemberCode *mcode = member->code;
|
ItclMemberCode *mcode = member->code;
|
|
|
int result;
|
int result;
|
|
|
/*
|
/*
|
* If the implementation has not yet been defined, try to
|
* If the implementation has not yet been defined, try to
|
* autoload it now.
|
* autoload it now.
|
*/
|
*/
|
if ((mcode->flags & ITCL_IMPLEMENT_NONE) != 0) {
|
if ((mcode->flags & ITCL_IMPLEMENT_NONE) != 0) {
|
result = Tcl_VarEval(interp, "::auto_load ", member->fullname,
|
result = Tcl_VarEval(interp, "::auto_load ", member->fullname,
|
(char*)NULL);
|
(char*)NULL);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
char msg[256];
|
char msg[256];
|
sprintf(msg, "\n (while autoloading code for \"%.100s\")",
|
sprintf(msg, "\n (while autoloading code for \"%.100s\")",
|
member->fullname);
|
member->fullname);
|
Tcl_AddErrorInfo(interp, msg);
|
Tcl_AddErrorInfo(interp, msg);
|
return result;
|
return result;
|
}
|
}
|
Tcl_ResetResult(interp); /* get rid of 1/0 status */
|
Tcl_ResetResult(interp); /* get rid of 1/0 status */
|
}
|
}
|
|
|
/*
|
/*
|
* If the implementation is still not available, then
|
* If the implementation is still not available, then
|
* autoloading must have failed.
|
* autoloading must have failed.
|
*
|
*
|
* TRICKY NOTE: If code has been autoloaded, then the
|
* TRICKY NOTE: If code has been autoloaded, then the
|
* old mcode pointer is probably invalid. Go back to
|
* old mcode pointer is probably invalid. Go back to
|
* the member and look at the current code pointer again.
|
* the member and look at the current code pointer again.
|
*/
|
*/
|
mcode = member->code;
|
mcode = member->code;
|
|
|
if ((mcode->flags & ITCL_IMPLEMENT_NONE) != 0) {
|
if ((mcode->flags & ITCL_IMPLEMENT_NONE) != 0) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"member function \"", member->fullname,
|
"member function \"", member->fullname,
|
"\" is not defined and cannot be autoloaded",
|
"\" is not defined and cannot be autoloaded",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If the member is a constructor and the class has an
|
* If the member is a constructor and the class has an
|
* initialization command, compile it here.
|
* initialization command, compile it here.
|
*/
|
*/
|
if ((member->flags & ITCL_CONSTRUCTOR) != 0 &&
|
if ((member->flags & ITCL_CONSTRUCTOR) != 0 &&
|
(member->classDefn->initCode != NULL)) {
|
(member->classDefn->initCode != NULL)) {
|
|
|
result = TclProcCompileProc(interp, mcode->procPtr,
|
result = TclProcCompileProc(interp, mcode->procPtr,
|
member->classDefn->initCode, (Namespace*)member->classDefn->namesp,
|
member->classDefn->initCode, (Namespace*)member->classDefn->namesp,
|
"initialization code for", member->fullname);
|
"initialization code for", member->fullname);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* If the code body has a Tcl implementation, then compile it here.
|
* If the code body has a Tcl implementation, then compile it here.
|
*/
|
*/
|
if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0) {
|
if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0) {
|
|
|
result = TclProcCompileProc(interp, mcode->procPtr,
|
result = TclProcCompileProc(interp, mcode->procPtr,
|
mcode->procPtr->bodyPtr, (Namespace*)member->classDefn->namesp,
|
mcode->procPtr->bodyPtr, (Namespace*)member->classDefn->namesp,
|
"body for", member->fullname);
|
"body for", member->fullname);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_EvalMemberCode()
|
* Itcl_EvalMemberCode()
|
*
|
*
|
* Used to execute an ItclMemberCode representation of a code
|
* Used to execute an ItclMemberCode representation of a code
|
* fragment. This code may be a body of Tcl commands, or a C handler
|
* fragment. This code may be a body of Tcl commands, or a C handler
|
* procedure.
|
* procedure.
|
*
|
*
|
* Executes the command with the given arguments (objc,objv) and
|
* Executes the command with the given arguments (objc,objv) and
|
* returns an integer status code (TCL_OK/TCL_ERROR). Returns the
|
* returns an integer status code (TCL_OK/TCL_ERROR). Returns the
|
* result string or an error message in the interpreter.
|
* result string or an error message in the interpreter.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_EvalMemberCode(interp, mfunc, member, contextObj, objc, objv)
|
Itcl_EvalMemberCode(interp, mfunc, member, contextObj, objc, objv)
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
ItclMemberFunc *mfunc; /* member func, or NULL (for error messages) */
|
ItclMemberFunc *mfunc; /* member func, or NULL (for error messages) */
|
ItclMember *member; /* command member containing code */
|
ItclMember *member; /* command member containing code */
|
ItclObject *contextObj; /* object context, or NULL */
|
ItclObject *contextObj; /* object context, or NULL */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
int result = TCL_OK;
|
int result = TCL_OK;
|
Tcl_CallFrame *oldFramePtr = NULL;
|
Tcl_CallFrame *oldFramePtr = NULL;
|
|
|
int i, transparent, newEntry;
|
int i, transparent, newEntry;
|
ItclObjectInfo *info;
|
ItclObjectInfo *info;
|
ItclMemberCode *mcode;
|
ItclMemberCode *mcode;
|
ItclContext context;
|
ItclContext context;
|
Tcl_CallFrame *framePtr, *transFramePtr;
|
Tcl_CallFrame *framePtr, *transFramePtr;
|
|
|
/*
|
/*
|
* If this code does not have an implementation yet, then
|
* If this code does not have an implementation yet, then
|
* try to autoload one. Also, if this is Tcl code, make sure
|
* try to autoload one. Also, if this is Tcl code, make sure
|
* that it's compiled and ready to use.
|
* that it's compiled and ready to use.
|
*/
|
*/
|
if (Itcl_GetMemberCode(interp, member) != TCL_OK) {
|
if (Itcl_GetMemberCode(interp, member) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
mcode = member->code;
|
mcode = member->code;
|
|
|
/*
|
/*
|
* Bump the reference count on this code, in case it is
|
* Bump the reference count on this code, in case it is
|
* redefined or deleted during execution.
|
* redefined or deleted during execution.
|
*/
|
*/
|
Itcl_PreserveData((ClientData)mcode);
|
Itcl_PreserveData((ClientData)mcode);
|
|
|
/*
|
/*
|
* Install a new call frame context for the current code.
|
* Install a new call frame context for the current code.
|
* If the current call frame is marked as "transparent", then
|
* If the current call frame is marked as "transparent", then
|
* do an "uplevel" operation to move past it. Transparent
|
* do an "uplevel" operation to move past it. Transparent
|
* call frames are installed by Itcl_HandleInstance. They
|
* call frames are installed by Itcl_HandleInstance. They
|
* provide a way of entering an object context without
|
* provide a way of entering an object context without
|
* interfering with the normal call stack.
|
* interfering with the normal call stack.
|
*/
|
*/
|
transparent = 0;
|
transparent = 0;
|
|
|
info = member->classDefn->info;
|
info = member->classDefn->info;
|
framePtr = _Tcl_GetCallFrame(interp, 0);
|
framePtr = _Tcl_GetCallFrame(interp, 0);
|
for (i = Itcl_GetStackSize(&info->transparentFrames)-1; i >= 0; i--) {
|
for (i = Itcl_GetStackSize(&info->transparentFrames)-1; i >= 0; i--) {
|
transFramePtr = (Tcl_CallFrame*)
|
transFramePtr = (Tcl_CallFrame*)
|
Itcl_GetStackValue(&info->transparentFrames, i);
|
Itcl_GetStackValue(&info->transparentFrames, i);
|
|
|
if (framePtr == transFramePtr) {
|
if (framePtr == transFramePtr) {
|
transparent = 1;
|
transparent = 1;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
if (transparent) {
|
if (transparent) {
|
framePtr = _Tcl_GetCallFrame(interp, 1);
|
framePtr = _Tcl_GetCallFrame(interp, 1);
|
oldFramePtr = _Tcl_ActivateCallFrame(interp, framePtr);
|
oldFramePtr = _Tcl_ActivateCallFrame(interp, framePtr);
|
}
|
}
|
|
|
if (Itcl_PushContext(interp, member, member->classDefn, contextObj,
|
if (Itcl_PushContext(interp, member, member->classDefn, contextObj,
|
&context) != TCL_OK) {
|
&context) != TCL_OK) {
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If this is a method with a Tcl implementation, or a
|
* If this is a method with a Tcl implementation, or a
|
* constructor with initCode, then parse its arguments now.
|
* constructor with initCode, then parse its arguments now.
|
*/
|
*/
|
if (mfunc && objc > 0) {
|
if (mfunc && objc > 0) {
|
if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0 ||
|
if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0 ||
|
( (member->flags & ITCL_CONSTRUCTOR) != 0 &&
|
( (member->flags & ITCL_CONSTRUCTOR) != 0 &&
|
(member->classDefn->initCode != NULL) ) ) {
|
(member->classDefn->initCode != NULL) ) ) {
|
|
|
if (Itcl_AssignArgs(interp, objc, objv, mfunc) != TCL_OK) {
|
if (Itcl_AssignArgs(interp, objc, objv, mfunc) != TCL_OK) {
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
goto evalMemberCodeDone;
|
goto evalMemberCodeDone;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* If this code is a constructor, and if it is being invoked
|
* If this code is a constructor, and if it is being invoked
|
* when an object is first constructed (i.e., the "constructed"
|
* when an object is first constructed (i.e., the "constructed"
|
* table is still active within the object), then handle the
|
* table is still active within the object), then handle the
|
* "initCode" associated with the constructor and make sure that
|
* "initCode" associated with the constructor and make sure that
|
* all base classes are properly constructed.
|
* all base classes are properly constructed.
|
*
|
*
|
* TRICKY NOTE:
|
* TRICKY NOTE:
|
* The "initCode" must be executed here. This is the only
|
* The "initCode" must be executed here. This is the only
|
* opportunity where the arguments of the constructor are
|
* opportunity where the arguments of the constructor are
|
* available in a call frame.
|
* available in a call frame.
|
*/
|
*/
|
if ((member->flags & ITCL_CONSTRUCTOR) && contextObj &&
|
if ((member->flags & ITCL_CONSTRUCTOR) && contextObj &&
|
contextObj->constructed) {
|
contextObj->constructed) {
|
|
|
result = Itcl_ConstructBase(interp, contextObj, member->classDefn);
|
result = Itcl_ConstructBase(interp, contextObj, member->classDefn);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
goto evalMemberCodeDone;
|
goto evalMemberCodeDone;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Execute the code body...
|
* Execute the code body...
|
*/
|
*/
|
if ((mcode->flags & ITCL_IMPLEMENT_OBJCMD) != 0) {
|
if ((mcode->flags & ITCL_IMPLEMENT_OBJCMD) != 0) {
|
result = (*mcode->cfunc.objCmd)(mcode->clientData,
|
result = (*mcode->cfunc.objCmd)(mcode->clientData,
|
interp, objc, objv);
|
interp, objc, objv);
|
}
|
}
|
else if ((mcode->flags & ITCL_IMPLEMENT_ARGCMD) != 0) {
|
else if ((mcode->flags & ITCL_IMPLEMENT_ARGCMD) != 0) {
|
char **argv;
|
char **argv;
|
argv = (char**)ckalloc( (unsigned)(objc*sizeof(char*)) );
|
argv = (char**)ckalloc( (unsigned)(objc*sizeof(char*)) );
|
for (i=0; i < objc; i++) {
|
for (i=0; i < objc; i++) {
|
argv[i] = Tcl_GetStringFromObj(objv[i], (int*)NULL);
|
argv[i] = Tcl_GetStringFromObj(objv[i], (int*)NULL);
|
}
|
}
|
|
|
result = (*mcode->cfunc.argCmd)(mcode->clientData,
|
result = (*mcode->cfunc.argCmd)(mcode->clientData,
|
interp, objc, argv);
|
interp, objc, argv);
|
|
|
ckfree((char*)argv);
|
ckfree((char*)argv);
|
}
|
}
|
else if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0) {
|
else if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0) {
|
/* 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, mcode->procPtr->bodyPtr);
|
result = Tcl_EvalObj(interp, mcode->procPtr->bodyPtr);
|
#else
|
#else
|
result = Tcl_EvalObj(interp, mcode->procPtr->bodyPtr, 0);
|
result = Tcl_EvalObj(interp, mcode->procPtr->bodyPtr, 0);
|
#endif
|
#endif
|
/* END CYGNUS LOCAL */
|
/* END CYGNUS LOCAL */
|
}
|
}
|
else {
|
else {
|
panic("itcl: bad implementation flag for %s", member->fullname);
|
panic("itcl: bad implementation flag for %s", member->fullname);
|
}
|
}
|
|
|
/*
|
/*
|
* If this is a constructor or destructor, and if it is being
|
* If this is a constructor or destructor, and if it is being
|
* invoked at the appropriate time, keep track of which methods
|
* invoked at the appropriate time, keep track of which methods
|
* have been called. This information is used to implicitly
|
* have been called. This information is used to implicitly
|
* invoke constructors/destructors as needed.
|
* invoke constructors/destructors as needed.
|
*/
|
*/
|
if ((member->flags & ITCL_DESTRUCTOR) && contextObj &&
|
if ((member->flags & ITCL_DESTRUCTOR) && contextObj &&
|
contextObj->destructed) {
|
contextObj->destructed) {
|
|
|
Tcl_CreateHashEntry(contextObj->destructed,
|
Tcl_CreateHashEntry(contextObj->destructed,
|
member->classDefn->name, &newEntry);
|
member->classDefn->name, &newEntry);
|
}
|
}
|
if ((member->flags & ITCL_CONSTRUCTOR) && contextObj &&
|
if ((member->flags & ITCL_CONSTRUCTOR) && contextObj &&
|
contextObj->constructed) {
|
contextObj->constructed) {
|
|
|
Tcl_CreateHashEntry(contextObj->constructed,
|
Tcl_CreateHashEntry(contextObj->constructed,
|
member->classDefn->name, &newEntry);
|
member->classDefn->name, &newEntry);
|
}
|
}
|
|
|
evalMemberCodeDone:
|
evalMemberCodeDone:
|
Itcl_PopContext(interp, &context);
|
Itcl_PopContext(interp, &context);
|
|
|
if (transparent) {
|
if (transparent) {
|
(void) _Tcl_ActivateCallFrame(interp, oldFramePtr);
|
(void) _Tcl_ActivateCallFrame(interp, oldFramePtr);
|
}
|
}
|
Itcl_ReleaseData((ClientData)mcode);
|
Itcl_ReleaseData((ClientData)mcode);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_CreateArgList()
|
* Itcl_CreateArgList()
|
*
|
*
|
* Parses a Tcl list representing an argument declaration and returns
|
* Parses a Tcl list representing an argument declaration and returns
|
* a linked list of CompiledLocal values. Usually invoked as part
|
* a linked list of CompiledLocal values. Usually invoked as part
|
* of Itcl_CreateMemberFunc() when a new method or procedure is being
|
* of Itcl_CreateMemberFunc() when a new method or procedure is being
|
* defined.
|
* defined.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_CreateArgList(interp, decl, argcPtr, argPtr)
|
Itcl_CreateArgList(interp, decl, argcPtr, argPtr)
|
Tcl_Interp* interp; /* interpreter managing this function */
|
Tcl_Interp* interp; /* interpreter managing this function */
|
char* decl; /* string representing argument list */
|
char* decl; /* string representing argument list */
|
int* argcPtr; /* returns number of args in argument list */
|
int* argcPtr; /* returns number of args in argument list */
|
CompiledLocal** argPtr; /* returns pointer to parsed argument list */
|
CompiledLocal** argPtr; /* returns pointer to parsed argument list */
|
{
|
{
|
int status = TCL_OK; /* assume that this will succeed */
|
int status = TCL_OK; /* assume that this will succeed */
|
|
|
int i, argc, fargc;
|
int i, argc, fargc;
|
char **argv, **fargv;
|
char **argv, **fargv;
|
CompiledLocal *localPtr, *last;
|
CompiledLocal *localPtr, *last;
|
|
|
*argPtr = last = NULL;
|
*argPtr = last = NULL;
|
*argcPtr = 0;
|
*argcPtr = 0;
|
|
|
if (decl) {
|
if (decl) {
|
if (Tcl_SplitList(interp, decl, &argc, &argv) != TCL_OK) {
|
if (Tcl_SplitList(interp, decl, &argc, &argv) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
for (i=0; i < argc && status == TCL_OK; i++) {
|
for (i=0; i < argc && status == TCL_OK; i++) {
|
if (Tcl_SplitList(interp, argv[i], &fargc, &fargv) != TCL_OK) {
|
if (Tcl_SplitList(interp, argv[i], &fargc, &fargv) != TCL_OK) {
|
status = TCL_ERROR;
|
status = TCL_ERROR;
|
}
|
}
|
else {
|
else {
|
localPtr = NULL;
|
localPtr = NULL;
|
|
|
if (fargc == 0 || *fargv[0] == '\0') {
|
if (fargc == 0 || *fargv[0] == '\0') {
|
char mesg[100];
|
char mesg[100];
|
sprintf(mesg, "argument #%d has no name", i);
|
sprintf(mesg, "argument #%d has no name", i);
|
Tcl_SetResult(interp, mesg, TCL_VOLATILE);
|
Tcl_SetResult(interp, mesg, TCL_VOLATILE);
|
status = TCL_ERROR;
|
status = TCL_ERROR;
|
}
|
}
|
else if (fargc > 2) {
|
else if (fargc > 2) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"too many fields in argument specifier \"",
|
"too many fields in argument specifier \"",
|
argv[i], "\"",
|
argv[i], "\"",
|
(char*)NULL);
|
(char*)NULL);
|
status = TCL_ERROR;
|
status = TCL_ERROR;
|
}
|
}
|
else if (strstr(fargv[0],"::")) {
|
else if (strstr(fargv[0],"::")) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad argument name \"", fargv[0], "\"",
|
"bad argument name \"", fargv[0], "\"",
|
(char*)NULL);
|
(char*)NULL);
|
status = TCL_ERROR;
|
status = TCL_ERROR;
|
}
|
}
|
else if (fargc == 1) {
|
else if (fargc == 1) {
|
localPtr = Itcl_CreateArg(fargv[0], (char*)NULL);
|
localPtr = Itcl_CreateArg(fargv[0], (char*)NULL);
|
}
|
}
|
else {
|
else {
|
localPtr = Itcl_CreateArg(fargv[0], fargv[1]);
|
localPtr = Itcl_CreateArg(fargv[0], fargv[1]);
|
}
|
}
|
|
|
if (localPtr) {
|
if (localPtr) {
|
localPtr->frameIndex = i;
|
localPtr->frameIndex = i;
|
|
|
if (*argPtr == NULL) {
|
if (*argPtr == NULL) {
|
*argPtr = last = localPtr;
|
*argPtr = last = localPtr;
|
}
|
}
|
else {
|
else {
|
last->nextPtr = localPtr;
|
last->nextPtr = localPtr;
|
last = localPtr;
|
last = localPtr;
|
}
|
}
|
}
|
}
|
}
|
}
|
ckfree((char*)fargv);
|
ckfree((char*)fargv);
|
}
|
}
|
ckfree((char*)argv);
|
ckfree((char*)argv);
|
}
|
}
|
|
|
/*
|
/*
|
* If anything went wrong, destroy whatever arguments were
|
* If anything went wrong, destroy whatever arguments were
|
* created and return an error.
|
* created and return an error.
|
*/
|
*/
|
if (status == TCL_OK) {
|
if (status == TCL_OK) {
|
*argcPtr = argc;
|
*argcPtr = argc;
|
} else {
|
} else {
|
Itcl_DeleteArgList(*argPtr);
|
Itcl_DeleteArgList(*argPtr);
|
*argPtr = NULL;
|
*argPtr = NULL;
|
}
|
}
|
return status;
|
return status;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_CreateArg()
|
* Itcl_CreateArg()
|
*
|
*
|
* Creates a new Tcl Arg structure and fills it with the given
|
* Creates a new Tcl Arg structure and fills it with the given
|
* information. Returns a pointer to the new Arg structure.
|
* information. Returns a pointer to the new Arg structure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
CompiledLocal*
|
CompiledLocal*
|
Itcl_CreateArg(name, init)
|
Itcl_CreateArg(name, init)
|
char* name; /* name of new argument */
|
char* name; /* name of new argument */
|
char* init; /* initial value */
|
char* init; /* initial value */
|
{
|
{
|
CompiledLocal *localPtr = NULL;
|
CompiledLocal *localPtr = NULL;
|
int nameLen;
|
int nameLen;
|
|
|
if (name == NULL) {
|
if (name == NULL) {
|
name = "";
|
name = "";
|
}
|
}
|
nameLen = strlen(name);
|
nameLen = strlen(name);
|
|
|
localPtr = (CompiledLocal*)ckalloc(
|
localPtr = (CompiledLocal*)ckalloc(
|
(unsigned)(sizeof(CompiledLocal)-sizeof(localPtr->name) + nameLen+1)
|
(unsigned)(sizeof(CompiledLocal)-sizeof(localPtr->name) + nameLen+1)
|
);
|
);
|
|
|
localPtr->nextPtr = NULL;
|
localPtr->nextPtr = NULL;
|
localPtr->nameLength = nameLen;
|
localPtr->nameLength = nameLen;
|
localPtr->frameIndex = 0; /* set this later */
|
localPtr->frameIndex = 0; /* set this later */
|
localPtr->flags = VAR_SCALAR | VAR_ARGUMENT;
|
localPtr->flags = VAR_SCALAR | VAR_ARGUMENT;
|
localPtr->resolveInfo = NULL;
|
localPtr->resolveInfo = NULL;
|
|
|
if (init != NULL) {
|
if (init != NULL) {
|
localPtr->defValuePtr = Tcl_NewStringObj(init, -1);
|
localPtr->defValuePtr = Tcl_NewStringObj(init, -1);
|
Tcl_IncrRefCount(localPtr->defValuePtr);
|
Tcl_IncrRefCount(localPtr->defValuePtr);
|
} else {
|
} else {
|
localPtr->defValuePtr = NULL;
|
localPtr->defValuePtr = NULL;
|
}
|
}
|
|
|
strcpy(localPtr->name, name);
|
strcpy(localPtr->name, name);
|
|
|
return localPtr;
|
return localPtr;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_DeleteArgList()
|
* Itcl_DeleteArgList()
|
*
|
*
|
* Destroys a chain of arguments acting as an argument list. Usually
|
* Destroys a chain of arguments acting as an argument list. Usually
|
* invoked when a method/proc is being destroyed, to discard its
|
* invoked when a method/proc is being destroyed, to discard its
|
* argument list.
|
* argument list.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_DeleteArgList(arglist)
|
Itcl_DeleteArgList(arglist)
|
CompiledLocal *arglist; /* first argument in arg list chain */
|
CompiledLocal *arglist; /* first argument in arg list chain */
|
{
|
{
|
CompiledLocal *localPtr, *next;
|
CompiledLocal *localPtr, *next;
|
|
|
for (localPtr=arglist; localPtr; localPtr=next) {
|
for (localPtr=arglist; localPtr; localPtr=next) {
|
if (localPtr->defValuePtr != NULL) {
|
if (localPtr->defValuePtr != NULL) {
|
Tcl_DecrRefCount(localPtr->defValuePtr);
|
Tcl_DecrRefCount(localPtr->defValuePtr);
|
}
|
}
|
if (localPtr->resolveInfo) {
|
if (localPtr->resolveInfo) {
|
if (localPtr->resolveInfo->deleteProc) {
|
if (localPtr->resolveInfo->deleteProc) {
|
localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
|
localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
|
} else {
|
} else {
|
ckfree((char*)localPtr->resolveInfo);
|
ckfree((char*)localPtr->resolveInfo);
|
}
|
}
|
localPtr->resolveInfo = NULL;
|
localPtr->resolveInfo = NULL;
|
}
|
}
|
next = localPtr->nextPtr;
|
next = localPtr->nextPtr;
|
ckfree((char*)localPtr);
|
ckfree((char*)localPtr);
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ArgList()
|
* Itcl_ArgList()
|
*
|
*
|
* Returns a Tcl_Obj containing the string representation for the
|
* Returns a Tcl_Obj containing the string representation for the
|
* given argument list. This object has a reference count of 1.
|
* given argument list. This object has a reference count of 1.
|
* The reference count should be decremented when the string is no
|
* The reference count should be decremented when the string is no
|
* longer needed, and it will free itself.
|
* longer needed, and it will free itself.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
Tcl_Obj*
|
Tcl_Obj*
|
Itcl_ArgList(argc, arglist)
|
Itcl_ArgList(argc, arglist)
|
int argc; /* number of arguments */
|
int argc; /* number of arguments */
|
CompiledLocal* arglist; /* first argument in arglist */
|
CompiledLocal* arglist; /* first argument in arglist */
|
{
|
{
|
char *val;
|
char *val;
|
Tcl_Obj *objPtr;
|
Tcl_Obj *objPtr;
|
Tcl_DString buffer;
|
Tcl_DString buffer;
|
|
|
Tcl_DStringInit(&buffer);
|
Tcl_DStringInit(&buffer);
|
|
|
while (arglist && argc-- > 0) {
|
while (arglist && argc-- > 0) {
|
if (arglist->defValuePtr) {
|
if (arglist->defValuePtr) {
|
val = Tcl_GetStringFromObj(arglist->defValuePtr, (int*)NULL);
|
val = Tcl_GetStringFromObj(arglist->defValuePtr, (int*)NULL);
|
Tcl_DStringStartSublist(&buffer);
|
Tcl_DStringStartSublist(&buffer);
|
Tcl_DStringAppendElement(&buffer, arglist->name);
|
Tcl_DStringAppendElement(&buffer, arglist->name);
|
Tcl_DStringAppendElement(&buffer, val);
|
Tcl_DStringAppendElement(&buffer, val);
|
Tcl_DStringEndSublist(&buffer);
|
Tcl_DStringEndSublist(&buffer);
|
}
|
}
|
else {
|
else {
|
Tcl_DStringAppendElement(&buffer, arglist->name);
|
Tcl_DStringAppendElement(&buffer, arglist->name);
|
}
|
}
|
arglist = arglist->nextPtr;
|
arglist = arglist->nextPtr;
|
}
|
}
|
|
|
objPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer),
|
objPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer),
|
Tcl_DStringLength(&buffer));
|
Tcl_DStringLength(&buffer));
|
|
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
|
|
return objPtr;
|
return objPtr;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_EquivArgLists()
|
* Itcl_EquivArgLists()
|
*
|
*
|
* Compares two argument lists to see if they are equivalent. The
|
* Compares two argument lists to see if they are equivalent. The
|
* first list is treated as a prototype, and the second list must
|
* first list is treated as a prototype, and the second list must
|
* match it. Argument names may be different, but they must match in
|
* match it. Argument names may be different, but they must match in
|
* meaning. If one argument is optional, the corresponding argument
|
* meaning. If one argument is optional, the corresponding argument
|
* must also be optional. If the prototype list ends with the magic
|
* must also be optional. If the prototype list ends with the magic
|
* "args" argument, then it matches everything in the other list.
|
* "args" argument, then it matches everything in the other list.
|
*
|
*
|
* Returns non-zero if the argument lists are equivalent.
|
* Returns non-zero if the argument lists are equivalent.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_EquivArgLists(arg1, arg1c, arg2, arg2c)
|
Itcl_EquivArgLists(arg1, arg1c, arg2, arg2c)
|
CompiledLocal* arg1; /* prototype argument list */
|
CompiledLocal* arg1; /* prototype argument list */
|
int arg1c; /* number of args in prototype arg list */
|
int arg1c; /* number of args in prototype arg list */
|
CompiledLocal* arg2; /* another argument list to match against */
|
CompiledLocal* arg2; /* another argument list to match against */
|
int arg2c; /* number of args in matching list */
|
int arg2c; /* number of args in matching list */
|
{
|
{
|
char *dval1, *dval2;
|
char *dval1, *dval2;
|
|
|
while (arg1 && arg1c > 0 && arg2 && arg2c > 0) {
|
while (arg1 && arg1c > 0 && arg2 && arg2c > 0) {
|
/*
|
/*
|
* If the prototype argument list ends with the magic "args"
|
* If the prototype argument list ends with the magic "args"
|
* argument, then it matches everything in the other list.
|
* argument, then it matches everything in the other list.
|
*/
|
*/
|
if (arg1c == 1 && strcmp(arg1->name,"args") == 0) {
|
if (arg1c == 1 && strcmp(arg1->name,"args") == 0) {
|
return 1;
|
return 1;
|
}
|
}
|
|
|
/*
|
/*
|
* If one has a default value, then the other must have the
|
* If one has a default value, then the other must have the
|
* same default value.
|
* same default value.
|
*/
|
*/
|
if (arg1->defValuePtr) {
|
if (arg1->defValuePtr) {
|
if (arg2->defValuePtr == NULL) {
|
if (arg2->defValuePtr == NULL) {
|
return 0;
|
return 0;
|
}
|
}
|
|
|
dval1 = Tcl_GetStringFromObj(arg1->defValuePtr, (int*)NULL);
|
dval1 = Tcl_GetStringFromObj(arg1->defValuePtr, (int*)NULL);
|
dval2 = Tcl_GetStringFromObj(arg2->defValuePtr, (int*)NULL);
|
dval2 = Tcl_GetStringFromObj(arg2->defValuePtr, (int*)NULL);
|
if (strcmp(dval1, dval2) != 0) {
|
if (strcmp(dval1, dval2) != 0) {
|
return 0;
|
return 0;
|
}
|
}
|
}
|
}
|
else if (arg2->defValuePtr) {
|
else if (arg2->defValuePtr) {
|
return 0;
|
return 0;
|
}
|
}
|
|
|
arg1 = arg1->nextPtr; arg1c--;
|
arg1 = arg1->nextPtr; arg1c--;
|
arg2 = arg2->nextPtr; arg2c--;
|
arg2 = arg2->nextPtr; arg2c--;
|
}
|
}
|
if (arg1c == 1 && strcmp(arg1->name,"args") == 0) {
|
if (arg1c == 1 && strcmp(arg1->name,"args") == 0) {
|
return 1;
|
return 1;
|
}
|
}
|
return (arg1c == 0 && arg2c == 0);
|
return (arg1c == 0 && arg2c == 0);
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_GetMemberFuncUsage()
|
* Itcl_GetMemberFuncUsage()
|
*
|
*
|
* Returns a string showing how a command member should be invoked.
|
* Returns a string showing how a command member should be invoked.
|
* If the command member is a method, then the specified object name
|
* If the command member is a method, then the specified object name
|
* is reported as part of the invocation path:
|
* is reported as part of the invocation path:
|
*
|
*
|
* obj method arg ?arg arg ...?
|
* obj method arg ?arg arg ...?
|
*
|
*
|
* Otherwise, the "obj" pointer is ignored, and the class name is
|
* Otherwise, the "obj" pointer is ignored, and the class name is
|
* used as the invocation path:
|
* used as the invocation path:
|
*
|
*
|
* class::proc arg ?arg arg ...?
|
* class::proc arg ?arg arg ...?
|
*
|
*
|
* Returns the string by appending it onto the Tcl_Obj passed in as
|
* Returns the string by appending it onto the Tcl_Obj passed in as
|
* an argument.
|
* an argument.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr)
|
Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr)
|
ItclMemberFunc *mfunc; /* command member being examined */
|
ItclMemberFunc *mfunc; /* command member being examined */
|
ItclObject *contextObj; /* invoked with respect to this object */
|
ItclObject *contextObj; /* invoked with respect to this object */
|
Tcl_Obj *objPtr; /* returns: string showing usage */
|
Tcl_Obj *objPtr; /* returns: string showing usage */
|
{
|
{
|
int argcount;
|
int argcount;
|
char *name;
|
char *name;
|
CompiledLocal *arglist, *argPtr;
|
CompiledLocal *arglist, *argPtr;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclMemberFunc *mf;
|
ItclMemberFunc *mf;
|
ItclClass *cdefnPtr;
|
ItclClass *cdefnPtr;
|
|
|
/*
|
/*
|
* If the command is a method and an object context was
|
* If the command is a method and an object context was
|
* specified, then add the object context. If the method
|
* specified, then add the object context. If the method
|
* was a constructor, and if the object is being created,
|
* was a constructor, and if the object is being created,
|
* then report the invocation via the class creation command.
|
* then report the invocation via the class creation command.
|
*/
|
*/
|
if ((mfunc->member->flags & ITCL_COMMON) == 0) {
|
if ((mfunc->member->flags & ITCL_COMMON) == 0) {
|
if ((mfunc->member->flags & ITCL_CONSTRUCTOR) != 0 &&
|
if ((mfunc->member->flags & ITCL_CONSTRUCTOR) != 0 &&
|
contextObj->constructed) {
|
contextObj->constructed) {
|
|
|
cdefnPtr = (ItclClass*)contextObj->classDefn;
|
cdefnPtr = (ItclClass*)contextObj->classDefn;
|
mf = NULL;
|
mf = NULL;
|
entry = Tcl_FindHashEntry(&cdefnPtr->resolveCmds, "constructor");
|
entry = Tcl_FindHashEntry(&cdefnPtr->resolveCmds, "constructor");
|
if (entry) {
|
if (entry) {
|
mf = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mf = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
}
|
}
|
|
|
if (mf == mfunc) {
|
if (mf == mfunc) {
|
Tcl_GetCommandFullName(contextObj->classDefn->interp,
|
Tcl_GetCommandFullName(contextObj->classDefn->interp,
|
contextObj->classDefn->accessCmd, objPtr);
|
contextObj->classDefn->accessCmd, objPtr);
|
Tcl_AppendToObj(objPtr, " ", -1);
|
Tcl_AppendToObj(objPtr, " ", -1);
|
name = Tcl_GetCommandName(contextObj->classDefn->interp,
|
name = Tcl_GetCommandName(contextObj->classDefn->interp,
|
contextObj->accessCmd);
|
contextObj->accessCmd);
|
Tcl_AppendToObj(objPtr, name, -1);
|
Tcl_AppendToObj(objPtr, name, -1);
|
} else {
|
} else {
|
Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1);
|
Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1);
|
}
|
}
|
}
|
}
|
else if (contextObj && contextObj->accessCmd) {
|
else if (contextObj && contextObj->accessCmd) {
|
name = Tcl_GetCommandName(contextObj->classDefn->interp,
|
name = Tcl_GetCommandName(contextObj->classDefn->interp,
|
contextObj->accessCmd);
|
contextObj->accessCmd);
|
Tcl_AppendStringsToObj(objPtr, name, " ", mfunc->member->name,
|
Tcl_AppendStringsToObj(objPtr, name, " ", mfunc->member->name,
|
(char*)NULL);
|
(char*)NULL);
|
}
|
}
|
else {
|
else {
|
Tcl_AppendStringsToObj(objPtr, "<object> ", mfunc->member->name,
|
Tcl_AppendStringsToObj(objPtr, "<object> ", mfunc->member->name,
|
(char*)NULL);
|
(char*)NULL);
|
}
|
}
|
}
|
}
|
else {
|
else {
|
Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1);
|
Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1);
|
}
|
}
|
|
|
/*
|
/*
|
* Add the argument usage info.
|
* Add the argument usage info.
|
*/
|
*/
|
if (mfunc->member->code) {
|
if (mfunc->member->code) {
|
arglist = mfunc->member->code->arglist;
|
arglist = mfunc->member->code->arglist;
|
argcount = mfunc->member->code->argcount;
|
argcount = mfunc->member->code->argcount;
|
} else if (mfunc->arglist) {
|
} else if (mfunc->arglist) {
|
arglist = mfunc->arglist;
|
arglist = mfunc->arglist;
|
argcount = mfunc->argcount;
|
argcount = mfunc->argcount;
|
} else {
|
} else {
|
arglist = NULL;
|
arglist = NULL;
|
argcount = 0;
|
argcount = 0;
|
}
|
}
|
|
|
if (arglist) {
|
if (arglist) {
|
for (argPtr=arglist;
|
for (argPtr=arglist;
|
argPtr && argcount > 0;
|
argPtr && argcount > 0;
|
argPtr=argPtr->nextPtr, argcount--) {
|
argPtr=argPtr->nextPtr, argcount--) {
|
|
|
if (argcount == 1 && strcmp(argPtr->name, "args") == 0) {
|
if (argcount == 1 && strcmp(argPtr->name, "args") == 0) {
|
Tcl_AppendToObj(objPtr, " ?arg arg ...?", -1);
|
Tcl_AppendToObj(objPtr, " ?arg arg ...?", -1);
|
}
|
}
|
else if (argPtr->defValuePtr) {
|
else if (argPtr->defValuePtr) {
|
Tcl_AppendStringsToObj(objPtr, " ?", argPtr->name, "?",
|
Tcl_AppendStringsToObj(objPtr, " ?", argPtr->name, "?",
|
(char*)NULL);
|
(char*)NULL);
|
}
|
}
|
else {
|
else {
|
Tcl_AppendStringsToObj(objPtr, " ", argPtr->name,
|
Tcl_AppendStringsToObj(objPtr, " ", argPtr->name,
|
(char*)NULL);
|
(char*)NULL);
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ExecMethod()
|
* Itcl_ExecMethod()
|
*
|
*
|
* Invoked by Tcl to handle the execution of a user-defined method.
|
* Invoked by Tcl to handle the execution of a user-defined method.
|
* A method is similar to the usual Tcl proc, but has access to
|
* A method is similar to the usual Tcl proc, but has access to
|
* object-specific data. If for some reason there is no current
|
* object-specific data. If for some reason there is no current
|
* object context, then a method call is inappropriate, and an error
|
* object context, then a method call is inappropriate, and an error
|
* is returned.
|
* is returned.
|
*
|
*
|
* Methods are implemented either as Tcl code fragments, or as C-coded
|
* Methods are implemented either as Tcl code fragments, or as C-coded
|
* procedures. For Tcl code fragments, command arguments are parsed
|
* procedures. For Tcl code fragments, command arguments are parsed
|
* according to the argument list, and the body is executed in the
|
* according to the argument list, and the body is executed in the
|
* scope of the class where it was defined. For C procedures, the
|
* scope of the class where it was defined. For C procedures, the
|
* arguments are passed in "as-is", and the procedure is executed in
|
* arguments are passed in "as-is", and the procedure is executed in
|
* the most-specific class scope.
|
* the most-specific class scope.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ExecMethod(clientData, interp, objc, objv)
|
Itcl_ExecMethod(clientData, interp, objc, objv)
|
ClientData clientData; /* method definition */
|
ClientData clientData; /* method definition */
|
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 */
|
{
|
{
|
ItclMemberFunc *mfunc = (ItclMemberFunc*)clientData;
|
ItclMemberFunc *mfunc = (ItclMemberFunc*)clientData;
|
ItclMember *member = mfunc->member;
|
ItclMember *member = mfunc->member;
|
int result = TCL_OK;
|
int result = TCL_OK;
|
|
|
char *token;
|
char *token;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclClass *contextClass;
|
ItclClass *contextClass;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
|
|
/*
|
/*
|
* Make sure that the current namespace context includes an
|
* Make sure that the current namespace context includes an
|
* object that is being manipulated. Methods can be executed
|
* object that is being manipulated. Methods can be executed
|
* only if an object context exists.
|
* only if an object context exists.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (contextObj == NULL) {
|
if (contextObj == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"cannot access object-specific info without an object context",
|
"cannot access object-specific info without an object context",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure that this command member can be accessed from
|
* Make sure that this command member can be accessed from
|
* the current namespace context.
|
* the current namespace context.
|
*/
|
*/
|
if (mfunc->member->protection != ITCL_PUBLIC) {
|
if (mfunc->member->protection != ITCL_PUBLIC) {
|
Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp,
|
Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp,
|
contextClass->info);
|
contextClass->info);
|
|
|
if (!Itcl_CanAccessFunc(mfunc, contextNs)) {
|
if (!Itcl_CanAccessFunc(mfunc, contextNs)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"can't access \"", member->fullname, "\": ",
|
"can't access \"", member->fullname, "\": ",
|
Itcl_ProtectionStr(member->protection), " function",
|
Itcl_ProtectionStr(member->protection), " function",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* All methods should be "virtual" unless they are invoked with
|
* All methods should be "virtual" unless they are invoked with
|
* a "::" scope qualifier.
|
* a "::" scope qualifier.
|
*
|
*
|
* To implement the "virtual" behavior, find the most-specific
|
* To implement the "virtual" behavior, find the most-specific
|
* implementation for the method by looking in the "resolveCmds"
|
* implementation for the method by looking in the "resolveCmds"
|
* table for this class.
|
* table for this class.
|
*/
|
*/
|
token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
if (strstr(token, "::") == NULL) {
|
if (strstr(token, "::") == NULL) {
|
entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveCmds,
|
entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveCmds,
|
member->name);
|
member->name);
|
|
|
if (entry) {
|
if (entry) {
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
member = mfunc->member;
|
member = mfunc->member;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Execute the code for the method. Be careful to protect
|
* Execute the code for the method. Be careful to protect
|
* the method in case it gets deleted during execution.
|
* the method in case it gets deleted during execution.
|
*/
|
*/
|
Itcl_PreserveData((ClientData)mfunc);
|
Itcl_PreserveData((ClientData)mfunc);
|
|
|
result = Itcl_EvalMemberCode(interp, mfunc, member, contextObj,
|
result = Itcl_EvalMemberCode(interp, mfunc, member, contextObj,
|
objc, objv);
|
objc, objv);
|
|
|
result = Itcl_ReportFuncErrors(interp, mfunc, contextObj, result);
|
result = Itcl_ReportFuncErrors(interp, mfunc, contextObj, result);
|
|
|
Itcl_ReleaseData((ClientData)mfunc);
|
Itcl_ReleaseData((ClientData)mfunc);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ExecProc()
|
* Itcl_ExecProc()
|
*
|
*
|
* Invoked by Tcl to handle the execution of a user-defined proc.
|
* Invoked by Tcl to handle the execution of a user-defined proc.
|
*
|
*
|
* Procs are implemented either as Tcl code fragments, or as C-coded
|
* Procs are implemented either as Tcl code fragments, or as C-coded
|
* procedures. For Tcl code fragments, command arguments are parsed
|
* procedures. For Tcl code fragments, command arguments are parsed
|
* according to the argument list, and the body is executed in the
|
* according to the argument list, and the body is executed in the
|
* scope of the class where it was defined. For C procedures, the
|
* scope of the class where it was defined. For C procedures, the
|
* arguments are passed in "as-is", and the procedure is executed in
|
* arguments are passed in "as-is", and the procedure is executed in
|
* the most-specific class scope.
|
* the most-specific class scope.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ExecProc(clientData, interp, objc, objv)
|
Itcl_ExecProc(clientData, interp, objc, objv)
|
ClientData clientData; /* proc definition */
|
ClientData clientData; /* proc definition */
|
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 */
|
{
|
{
|
ItclMemberFunc *mfunc = (ItclMemberFunc*)clientData;
|
ItclMemberFunc *mfunc = (ItclMemberFunc*)clientData;
|
ItclMember *member = mfunc->member;
|
ItclMember *member = mfunc->member;
|
int result = TCL_OK;
|
int result = TCL_OK;
|
|
|
/*
|
/*
|
* Make sure that this command member can be accessed from
|
* Make sure that this command member can be accessed from
|
* the current namespace context.
|
* the current namespace context.
|
*/
|
*/
|
if (mfunc->member->protection != ITCL_PUBLIC) {
|
if (mfunc->member->protection != ITCL_PUBLIC) {
|
Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp,
|
Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp,
|
mfunc->member->classDefn->info);
|
mfunc->member->classDefn->info);
|
|
|
if (!Itcl_CanAccessFunc(mfunc, contextNs)) {
|
if (!Itcl_CanAccessFunc(mfunc, contextNs)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"can't access \"", member->fullname, "\": ",
|
"can't access \"", member->fullname, "\": ",
|
Itcl_ProtectionStr(member->protection), " function",
|
Itcl_ProtectionStr(member->protection), " function",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Execute the code for the proc. Be careful to protect
|
* Execute the code for the proc. Be careful to protect
|
* the proc in case it gets deleted during execution.
|
* the proc in case it gets deleted during execution.
|
*/
|
*/
|
Itcl_PreserveData((ClientData)mfunc);
|
Itcl_PreserveData((ClientData)mfunc);
|
|
|
result = Itcl_EvalMemberCode(interp, mfunc, member, (ItclObject*)NULL,
|
result = Itcl_EvalMemberCode(interp, mfunc, member, (ItclObject*)NULL,
|
objc, objv);
|
objc, objv);
|
|
|
result = Itcl_ReportFuncErrors(interp, mfunc, (ItclObject*)NULL, result);
|
result = Itcl_ReportFuncErrors(interp, mfunc, (ItclObject*)NULL, result);
|
|
|
Itcl_ReleaseData((ClientData)mfunc);
|
Itcl_ReleaseData((ClientData)mfunc);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_PushContext()
|
* Itcl_PushContext()
|
*
|
*
|
* Sets up the class/object context so that a body of [incr Tcl]
|
* Sets up the class/object context so that a body of [incr Tcl]
|
* code can be executed. This procedure pushes a call frame with
|
* code can be executed. This procedure pushes a call frame with
|
* the proper namespace context for the class. If an object context
|
* the proper namespace context for the class. If an object context
|
* is supplied, the object's instance variables are integrated into
|
* is supplied, the object's instance variables are integrated into
|
* the call frame so they can be accessed as local variables.
|
* the call frame so they can be accessed as local variables.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_PushContext(interp, member, contextClass, contextObj, contextPtr)
|
Itcl_PushContext(interp, member, contextClass, contextObj, contextPtr)
|
Tcl_Interp *interp; /* interpreter managing this body of code */
|
Tcl_Interp *interp; /* interpreter managing this body of code */
|
ItclMember *member; /* member containing code body */
|
ItclMember *member; /* member containing code body */
|
ItclClass *contextClass; /* class context */
|
ItclClass *contextClass; /* class context */
|
ItclObject *contextObj; /* object context, or NULL */
|
ItclObject *contextObj; /* object context, or NULL */
|
ItclContext *contextPtr; /* storage space for class/object context */
|
ItclContext *contextPtr; /* storage space for class/object context */
|
{
|
{
|
CallFrame *framePtr = &contextPtr->frame;
|
CallFrame *framePtr = &contextPtr->frame;
|
|
|
int result, localCt, newEntry;
|
int result, localCt, newEntry;
|
ItclMemberCode *mcode;
|
ItclMemberCode *mcode;
|
Proc *procPtr;
|
Proc *procPtr;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
|
|
/*
|
/*
|
* Activate the call frame. If this fails, we'll bail out
|
* Activate the call frame. If this fails, we'll bail out
|
* before allocating any resources.
|
* before allocating any resources.
|
*
|
*
|
* NOTE: Always push a call frame that looks like a proc.
|
* NOTE: Always push a call frame that looks like a proc.
|
* This causes global variables to be handled properly
|
* This causes global variables to be handled properly
|
* inside methods/procs.
|
* inside methods/procs.
|
*/
|
*/
|
result = Tcl_PushCallFrame(interp, (Tcl_CallFrame*)framePtr,
|
result = Tcl_PushCallFrame(interp, (Tcl_CallFrame*)framePtr,
|
contextClass->namesp, /* isProcCallFrame */ 1);
|
contextClass->namesp, /* isProcCallFrame */ 1);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
|
|
contextPtr->classDefn = contextClass;
|
contextPtr->classDefn = contextClass;
|
contextPtr->compiledLocals = &contextPtr->localStorage[0];
|
contextPtr->compiledLocals = &contextPtr->localStorage[0];
|
|
|
/*
|
/*
|
* If this is an object context, register it in a hash table
|
* If this is an object context, register it in a hash table
|
* of all known contexts. We'll need this later if we
|
* of all known contexts. We'll need this later if we
|
* call Itcl_GetContext to get the object context for the
|
* call Itcl_GetContext to get the object context for the
|
* current call frame.
|
* current call frame.
|
*/
|
*/
|
if (contextObj) {
|
if (contextObj) {
|
entry = Tcl_CreateHashEntry(&contextClass->info->contextFrames,
|
entry = Tcl_CreateHashEntry(&contextClass->info->contextFrames,
|
(char*)framePtr, &newEntry);
|
(char*)framePtr, &newEntry);
|
|
|
Itcl_PreserveData((ClientData)contextObj);
|
Itcl_PreserveData((ClientData)contextObj);
|
Tcl_SetHashValue(entry, (ClientData)contextObj);
|
Tcl_SetHashValue(entry, (ClientData)contextObj);
|
}
|
}
|
|
|
/*
|
/*
|
* Set up the compiled locals in the call frame and assign
|
* Set up the compiled locals in the call frame and assign
|
* argument variables.
|
* argument variables.
|
*/
|
*/
|
if (member) {
|
if (member) {
|
mcode = member->code;
|
mcode = member->code;
|
procPtr = mcode->procPtr;
|
procPtr = mcode->procPtr;
|
|
|
/*
|
/*
|
* If there are too many compiled locals to fit in the default
|
* If there are too many compiled locals to fit in the default
|
* storage space for the context, then allocate more space.
|
* storage space for the context, then allocate more space.
|
*/
|
*/
|
localCt = procPtr->numCompiledLocals;
|
localCt = procPtr->numCompiledLocals;
|
if (localCt > sizeof(contextPtr->localStorage)/sizeof(Var)) {
|
if (localCt > sizeof(contextPtr->localStorage)/sizeof(Var)) {
|
contextPtr->compiledLocals = (Var*)ckalloc(
|
contextPtr->compiledLocals = (Var*)ckalloc(
|
(unsigned)(localCt * sizeof(Var))
|
(unsigned)(localCt * sizeof(Var))
|
);
|
);
|
}
|
}
|
|
|
/*
|
/*
|
* Initialize and resolve compiled variable references.
|
* Initialize and resolve compiled variable references.
|
* Class variables will have special resolution rules.
|
* Class variables will have special resolution rules.
|
* In that case, we call their "resolver" procs to get our
|
* In that case, we call their "resolver" procs to get our
|
* hands on the variable, and we make the compiled local a
|
* hands on the variable, and we make the compiled local a
|
* link to the real variable.
|
* link to the real variable.
|
*/
|
*/
|
|
|
framePtr->procPtr = procPtr;
|
framePtr->procPtr = procPtr;
|
framePtr->numCompiledLocals = localCt;
|
framePtr->numCompiledLocals = localCt;
|
framePtr->compiledLocals = contextPtr->compiledLocals;
|
framePtr->compiledLocals = contextPtr->compiledLocals;
|
|
|
TclInitCompiledLocals(interp, framePtr,
|
TclInitCompiledLocals(interp, framePtr,
|
(Namespace*)contextClass->namesp);
|
(Namespace*)contextClass->namesp);
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_PopContext()
|
* Itcl_PopContext()
|
*
|
*
|
* Removes a class/object context previously set up by Itcl_PushContext.
|
* Removes a class/object context previously set up by Itcl_PushContext.
|
* Usually called after an [incr Tcl] code body has been executed,
|
* Usually called after an [incr Tcl] code body has been executed,
|
* to clean up.
|
* to clean up.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_PopContext(interp, contextPtr)
|
Itcl_PopContext(interp, contextPtr)
|
Tcl_Interp *interp; /* interpreter managing this body of code */
|
Tcl_Interp *interp; /* interpreter managing this body of code */
|
ItclContext *contextPtr; /* storage space for class/object context */
|
ItclContext *contextPtr; /* storage space for class/object context */
|
{
|
{
|
Tcl_CallFrame *framePtr;
|
Tcl_CallFrame *framePtr;
|
ItclObjectInfo *info;
|
ItclObjectInfo *info;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
|
|
/*
|
/*
|
* See if the current call frame has an object context
|
* See if the current call frame has an object context
|
* associated with it. If so, release the claim on the
|
* associated with it. If so, release the claim on the
|
* object info.
|
* object info.
|
*/
|
*/
|
framePtr = _Tcl_GetCallFrame(interp, 0);
|
framePtr = _Tcl_GetCallFrame(interp, 0);
|
info = contextPtr->classDefn->info;
|
info = contextPtr->classDefn->info;
|
|
|
entry = Tcl_FindHashEntry(&info->contextFrames, (char*)framePtr);
|
entry = Tcl_FindHashEntry(&info->contextFrames, (char*)framePtr);
|
if (entry != NULL) {
|
if (entry != NULL) {
|
contextObj = (ItclObject*)Tcl_GetHashValue(entry);
|
contextObj = (ItclObject*)Tcl_GetHashValue(entry);
|
Itcl_ReleaseData((ClientData)contextObj);
|
Itcl_ReleaseData((ClientData)contextObj);
|
Tcl_DeleteHashEntry(entry);
|
Tcl_DeleteHashEntry(entry);
|
}
|
}
|
|
|
/*
|
/*
|
* Remove the call frame.
|
* Remove the call frame.
|
*/
|
*/
|
Tcl_PopCallFrame(interp);
|
Tcl_PopCallFrame(interp);
|
|
|
/*
|
/*
|
* Free the compiledLocals array if malloc'ed storage was used.
|
* Free the compiledLocals array if malloc'ed storage was used.
|
*/
|
*/
|
if (contextPtr->compiledLocals != &contextPtr->localStorage[0]) {
|
if (contextPtr->compiledLocals != &contextPtr->localStorage[0]) {
|
ckfree((char*)contextPtr->compiledLocals);
|
ckfree((char*)contextPtr->compiledLocals);
|
}
|
}
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_GetContext()
|
* Itcl_GetContext()
|
*
|
*
|
* Convenience routine for looking up the current object/class context.
|
* Convenience routine for looking up the current object/class context.
|
* Useful in implementing methods/procs to see what class, and perhaps
|
* Useful in implementing methods/procs to see what class, and perhaps
|
* what object, is active.
|
* what object, is active.
|
*
|
*
|
* Returns TCL_OK if the current namespace is a class namespace.
|
* Returns TCL_OK if the current namespace is a class namespace.
|
* Also returns pointers to the class definition, and to object
|
* Also returns pointers to the class definition, and to object
|
* data if an object context is active. Returns TCL_ERROR (along
|
* data if an object context is active. Returns TCL_ERROR (along
|
* with an error message in the interpreter) if a class namespace
|
* with an error message in the interpreter) if a class namespace
|
* is not active.
|
* is not active.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_GetContext(interp, cdefnPtr, odefnPtr)
|
Itcl_GetContext(interp, cdefnPtr, odefnPtr)
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
ItclClass **cdefnPtr; /* returns: class definition or NULL */
|
ItclClass **cdefnPtr; /* returns: class definition or NULL */
|
ItclObject **odefnPtr; /* returns: object data or NULL */
|
ItclObject **odefnPtr; /* returns: object data or NULL */
|
{
|
{
|
Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp);
|
Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp);
|
ItclObjectInfo *info;
|
ItclObjectInfo *info;
|
Tcl_CallFrame *framePtr;
|
Tcl_CallFrame *framePtr;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
|
|
/*
|
/*
|
* Return NULL for anything that cannot be found.
|
* Return NULL for anything that cannot be found.
|
*/
|
*/
|
*cdefnPtr = NULL;
|
*cdefnPtr = NULL;
|
*odefnPtr = NULL;
|
*odefnPtr = NULL;
|
|
|
/*
|
/*
|
* If the active namespace is a class namespace, then return
|
* If the active namespace is a class namespace, then return
|
* all known info. See if the current call frame is a known
|
* all known info. See if the current call frame is a known
|
* object context, and if so, return that context.
|
* object context, and if so, return that context.
|
*/
|
*/
|
if (Itcl_IsClassNamespace(activeNs)) {
|
if (Itcl_IsClassNamespace(activeNs)) {
|
*cdefnPtr = (ItclClass*)activeNs->clientData;
|
*cdefnPtr = (ItclClass*)activeNs->clientData;
|
|
|
framePtr = _Tcl_GetCallFrame(interp, 0);
|
framePtr = _Tcl_GetCallFrame(interp, 0);
|
|
|
info = (*cdefnPtr)->info;
|
info = (*cdefnPtr)->info;
|
entry = Tcl_FindHashEntry(&info->contextFrames, (char*)framePtr);
|
entry = Tcl_FindHashEntry(&info->contextFrames, (char*)framePtr);
|
|
|
if (entry != NULL) {
|
if (entry != NULL) {
|
*odefnPtr = (ItclObject*)Tcl_GetHashValue(entry);
|
*odefnPtr = (ItclObject*)Tcl_GetHashValue(entry);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* If there is no class/object context, return an error message.
|
* If there is no class/object context, return an error message.
|
*/
|
*/
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"namespace \"", activeNs->fullName, "\" is not a class namespace",
|
"namespace \"", activeNs->fullName, "\" is not a class namespace",
|
(char*)NULL);
|
(char*)NULL);
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_AssignArgs()
|
* Itcl_AssignArgs()
|
*
|
*
|
* Matches a list of arguments against a Tcl argument specification.
|
* Matches a list of arguments against a Tcl argument specification.
|
* Supports all of the rules regarding arguments for Tcl procs, including
|
* Supports all of the rules regarding arguments for Tcl procs, including
|
* default arguments and variable-length argument lists.
|
* default arguments and variable-length argument lists.
|
*
|
*
|
* Assumes that a local call frame is already installed. As variables
|
* Assumes that a local call frame is already installed. As variables
|
* are successfully matched, they are stored as variables in the call
|
* are successfully matched, they are stored as variables in the call
|
* frame. Returns TCL_OK on success, or TCL_ERROR (along with an error
|
* frame. Returns TCL_OK on success, or TCL_ERROR (along with an error
|
* message in interp->result) on error.
|
* message in interp->result) on error.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_AssignArgs(interp, objc, objv, mfunc)
|
Itcl_AssignArgs(interp, objc, objv, mfunc)
|
Tcl_Interp *interp; /* interpreter */
|
Tcl_Interp *interp; /* interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
ItclMemberFunc *mfunc; /* member function info (for error messages) */
|
ItclMemberFunc *mfunc; /* member function info (for error messages) */
|
{
|
{
|
ItclMemberCode *mcode = mfunc->member->code;
|
ItclMemberCode *mcode = mfunc->member->code;
|
|
|
int result = TCL_OK;
|
int result = TCL_OK;
|
|
|
int defargc;
|
int defargc;
|
char **defargv = NULL;
|
char **defargv = NULL;
|
Tcl_Obj **defobjv = NULL;
|
Tcl_Obj **defobjv = NULL;
|
int configc = 0;
|
int configc = 0;
|
ItclVarDefn **configVars = NULL;
|
ItclVarDefn **configVars = NULL;
|
char **configVals = NULL;
|
char **configVals = NULL;
|
|
|
int vi, argsLeft;
|
int vi, argsLeft;
|
ItclClass *contextClass;
|
ItclClass *contextClass;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
CompiledLocal *argPtr;
|
CompiledLocal *argPtr;
|
CallFrame *framePtr;
|
CallFrame *framePtr;
|
Var *varPtr;
|
Var *varPtr;
|
Tcl_Obj *objPtr, *listPtr;
|
Tcl_Obj *objPtr, *listPtr;
|
char *value;
|
char *value;
|
|
|
framePtr = (CallFrame*) _Tcl_GetCallFrame(interp, 0);
|
framePtr = (CallFrame*) _Tcl_GetCallFrame(interp, 0);
|
framePtr->objc = objc;
|
framePtr->objc = objc;
|
framePtr->objv = objv; /* ref counts for args are incremented below */
|
framePtr->objv = objv; /* ref counts for args are incremented below */
|
|
|
/*
|
/*
|
* See if there is a current object context. We may need
|
* See if there is a current object context. We may need
|
* it later on.
|
* it later on.
|
*/
|
*/
|
(void) Itcl_GetContext(interp, &contextClass, &contextObj);
|
(void) Itcl_GetContext(interp, &contextClass, &contextObj);
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
|
|
/*
|
/*
|
* Match the actual arguments against the procedure's formal
|
* Match the actual arguments against the procedure's formal
|
* parameters to compute local variables.
|
* parameters to compute local variables.
|
*/
|
*/
|
varPtr = framePtr->compiledLocals;
|
varPtr = framePtr->compiledLocals;
|
|
|
for (argsLeft=mcode->argcount, argPtr=mcode->arglist, objv++, objc--;
|
for (argsLeft=mcode->argcount, argPtr=mcode->arglist, objv++, objc--;
|
argsLeft > 0;
|
argsLeft > 0;
|
argPtr=argPtr->nextPtr, argsLeft--, varPtr++, objv++, objc--)
|
argPtr=argPtr->nextPtr, argsLeft--, varPtr++, objv++, objc--)
|
{
|
{
|
if (!TclIsVarArgument(argPtr)) {
|
if (!TclIsVarArgument(argPtr)) {
|
panic("local variable %s is not argument but should be",
|
panic("local variable %s is not argument but should be",
|
argPtr->name);
|
argPtr->name);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (TclIsVarTemporary(argPtr)) {
|
if (TclIsVarTemporary(argPtr)) {
|
panic("local variable is temporary but should be an argument");
|
panic("local variable is temporary but should be an argument");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Handle the special case of the last formal being "args".
|
* Handle the special case of the last formal being "args".
|
* When it occurs, assign it a list consisting of all the
|
* When it occurs, assign it a list consisting of all the
|
* remaining actual arguments.
|
* remaining actual arguments.
|
*/
|
*/
|
if ((argsLeft == 1) && (strcmp(argPtr->name, "args") == 0)) {
|
if ((argsLeft == 1) && (strcmp(argPtr->name, "args") == 0)) {
|
if (objc < 0) objc = 0;
|
if (objc < 0) objc = 0;
|
|
|
listPtr = Tcl_NewListObj(objc, objv);
|
listPtr = Tcl_NewListObj(objc, objv);
|
varPtr->value.objPtr = listPtr;
|
varPtr->value.objPtr = listPtr;
|
Tcl_IncrRefCount(listPtr); /* local var is a reference */
|
Tcl_IncrRefCount(listPtr); /* local var is a reference */
|
varPtr->flags &= ~VAR_UNDEFINED;
|
varPtr->flags &= ~VAR_UNDEFINED;
|
objc = 0;
|
objc = 0;
|
|
|
break;
|
break;
|
}
|
}
|
|
|
/*
|
/*
|
* Handle the special case of the last formal being "config".
|
* Handle the special case of the last formal being "config".
|
* When it occurs, treat all remaining arguments as public
|
* When it occurs, treat all remaining arguments as public
|
* variable assignments. Set the local "config" variable
|
* variable assignments. Set the local "config" variable
|
* to the list of public variables assigned.
|
* to the list of public variables assigned.
|
*/
|
*/
|
else if ( (argsLeft == 1) &&
|
else if ( (argsLeft == 1) &&
|
(strcmp(argPtr->name, "config") == 0) &&
|
(strcmp(argPtr->name, "config") == 0) &&
|
contextObj )
|
contextObj )
|
{
|
{
|
/*
|
/*
|
* If this is not an old-style method, discourage against
|
* If this is not an old-style method, discourage against
|
* the use of the "config" argument.
|
* the use of the "config" argument.
|
*/
|
*/
|
if ((mfunc->member->flags & ITCL_OLD_STYLE) == 0) {
|
if ((mfunc->member->flags & ITCL_OLD_STYLE) == 0) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\"config\" argument is an anachronism\n",
|
"\"config\" argument is an anachronism\n",
|
"[incr Tcl] no longer supports the \"config\" argument.\n",
|
"[incr Tcl] no longer supports the \"config\" argument.\n",
|
"Instead, use the \"args\" argument and then use the\n",
|
"Instead, use the \"args\" argument and then use the\n",
|
"built-in configure method to handle args like this:\n",
|
"built-in configure method to handle args like this:\n",
|
" eval configure $args",
|
" eval configure $args",
|
(char*)NULL);
|
(char*)NULL);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
goto argErrors;
|
goto argErrors;
|
}
|
}
|
|
|
/*
|
/*
|
* Otherwise, handle the "config" argument in the usual way...
|
* Otherwise, handle the "config" argument in the usual way...
|
* - parse all "-name value" assignments
|
* - parse all "-name value" assignments
|
* - set "config" argument to the list of variable names
|
* - set "config" argument to the list of variable names
|
*/
|
*/
|
if (objc > 0) { /* still have some arguments left? */
|
if (objc > 0) { /* still have some arguments left? */
|
|
|
result = ItclParseConfig(interp, objc, objv, contextObj,
|
result = ItclParseConfig(interp, objc, objv, contextObj,
|
&configc, &configVars, &configVals);
|
&configc, &configVars, &configVals);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
goto argErrors;
|
goto argErrors;
|
}
|
}
|
|
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
for (vi=0; vi < configc; vi++) {
|
for (vi=0; vi < configc; vi++) {
|
objPtr = Tcl_NewStringObj(
|
objPtr = Tcl_NewStringObj(
|
configVars[vi]->member->classDefn->name, -1);
|
configVars[vi]->member->classDefn->name, -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, configVars[vi]->member->name, -1);
|
Tcl_AppendToObj(objPtr, configVars[vi]->member->name, -1);
|
|
|
Tcl_ListObjAppendElement(interp, listPtr, objPtr);
|
Tcl_ListObjAppendElement(interp, listPtr, objPtr);
|
}
|
}
|
|
|
varPtr->value.objPtr = listPtr;
|
varPtr->value.objPtr = listPtr;
|
Tcl_IncrRefCount(listPtr); /* local var is a reference */
|
Tcl_IncrRefCount(listPtr); /* local var is a reference */
|
varPtr->flags &= ~VAR_UNDEFINED;
|
varPtr->flags &= ~VAR_UNDEFINED;
|
|
|
objc = 0; /* all remaining args handled */
|
objc = 0; /* all remaining args handled */
|
}
|
}
|
|
|
else if (argPtr->defValuePtr) {
|
else if (argPtr->defValuePtr) {
|
value = Tcl_GetStringFromObj(argPtr->defValuePtr, (int*)NULL);
|
value = Tcl_GetStringFromObj(argPtr->defValuePtr, (int*)NULL);
|
|
|
result = Tcl_SplitList(interp, value, &defargc, &defargv);
|
result = Tcl_SplitList(interp, value, &defargc, &defargv);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
goto argErrors;
|
goto argErrors;
|
}
|
}
|
defobjv = (Tcl_Obj**)ckalloc(
|
defobjv = (Tcl_Obj**)ckalloc(
|
(unsigned)(defargc*sizeof(Tcl_Obj*))
|
(unsigned)(defargc*sizeof(Tcl_Obj*))
|
);
|
);
|
for (vi=0; vi < defargc; vi++) {
|
for (vi=0; vi < defargc; vi++) {
|
objPtr = Tcl_NewStringObj(defargv[vi], -1);
|
objPtr = Tcl_NewStringObj(defargv[vi], -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
defobjv[vi] = objPtr;
|
defobjv[vi] = objPtr;
|
}
|
}
|
|
|
result = ItclParseConfig(interp, defargc, defobjv, contextObj,
|
result = ItclParseConfig(interp, defargc, defobjv, contextObj,
|
&configc, &configVars, &configVals);
|
&configc, &configVars, &configVals);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
goto argErrors;
|
goto argErrors;
|
}
|
}
|
|
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
for (vi=0; vi < configc; vi++) {
|
for (vi=0; vi < configc; vi++) {
|
objPtr = Tcl_NewStringObj(
|
objPtr = Tcl_NewStringObj(
|
configVars[vi]->member->classDefn->name, -1);
|
configVars[vi]->member->classDefn->name, -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, configVars[vi]->member->name, -1);
|
Tcl_AppendToObj(objPtr, configVars[vi]->member->name, -1);
|
|
|
Tcl_ListObjAppendElement(interp, listPtr, objPtr);
|
Tcl_ListObjAppendElement(interp, listPtr, objPtr);
|
}
|
}
|
|
|
varPtr->value.objPtr = listPtr;
|
varPtr->value.objPtr = listPtr;
|
Tcl_IncrRefCount(listPtr); /* local var is a reference */
|
Tcl_IncrRefCount(listPtr); /* local var is a reference */
|
varPtr->flags &= ~VAR_UNDEFINED;
|
varPtr->flags &= ~VAR_UNDEFINED;
|
}
|
}
|
else {
|
else {
|
objPtr = Tcl_NewStringObj("", 0);
|
objPtr = Tcl_NewStringObj("", 0);
|
varPtr->value.objPtr = objPtr;
|
varPtr->value.objPtr = objPtr;
|
Tcl_IncrRefCount(objPtr); /* local var is a reference */
|
Tcl_IncrRefCount(objPtr); /* local var is a reference */
|
varPtr->flags &= ~VAR_UNDEFINED;
|
varPtr->flags &= ~VAR_UNDEFINED;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Resume the usual processing of arguments...
|
* Resume the usual processing of arguments...
|
*/
|
*/
|
else if (objc > 0) { /* take next arg as value */
|
else if (objc > 0) { /* take next arg as value */
|
objPtr = *objv;
|
objPtr = *objv;
|
varPtr->value.objPtr = objPtr;
|
varPtr->value.objPtr = objPtr;
|
varPtr->flags &= ~VAR_UNDEFINED;
|
varPtr->flags &= ~VAR_UNDEFINED;
|
Tcl_IncrRefCount(objPtr); /* local var is a reference */
|
Tcl_IncrRefCount(objPtr); /* local var is a reference */
|
}
|
}
|
else if (argPtr->defValuePtr) { /* ...or use default value */
|
else if (argPtr->defValuePtr) { /* ...or use default value */
|
objPtr = argPtr->defValuePtr;
|
objPtr = argPtr->defValuePtr;
|
varPtr->value.objPtr = objPtr;
|
varPtr->value.objPtr = objPtr;
|
varPtr->flags &= ~VAR_UNDEFINED;
|
varPtr->flags &= ~VAR_UNDEFINED;
|
Tcl_IncrRefCount(objPtr); /* local var is a reference */
|
Tcl_IncrRefCount(objPtr); /* local var is a reference */
|
}
|
}
|
else {
|
else {
|
if (mfunc) {
|
if (mfunc) {
|
objPtr = Tcl_GetObjResult(interp);
|
objPtr = Tcl_GetObjResult(interp);
|
Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
|
Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
|
Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr);
|
Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr);
|
Tcl_AppendToObj(objPtr, "\"", -1);
|
Tcl_AppendToObj(objPtr, "\"", -1);
|
} else {
|
} else {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"no value given for parameter \"", argPtr->name, "\"",
|
"no value given for parameter \"", argPtr->name, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
}
|
}
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
goto argErrors;
|
goto argErrors;
|
}
|
}
|
}
|
}
|
|
|
if (objc > 0) {
|
if (objc > 0) {
|
if (mfunc) {
|
if (mfunc) {
|
objPtr = Tcl_GetObjResult(interp);
|
objPtr = Tcl_GetObjResult(interp);
|
Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
|
Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
|
Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr);
|
Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr);
|
Tcl_AppendToObj(objPtr, "\"", -1);
|
Tcl_AppendToObj(objPtr, "\"", -1);
|
} else {
|
} else {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"too many arguments",
|
"too many arguments",
|
(char*)NULL);
|
(char*)NULL);
|
}
|
}
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
goto argErrors;
|
goto argErrors;
|
}
|
}
|
|
|
/*
|
/*
|
* Handle any "config" assignments.
|
* Handle any "config" assignments.
|
*/
|
*/
|
if (configc > 0) {
|
if (configc > 0) {
|
if (ItclHandleConfig(interp, configc, configVars, configVals,
|
if (ItclHandleConfig(interp, configc, configVars, configVals,
|
contextObj) != TCL_OK) {
|
contextObj) != TCL_OK) {
|
|
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
goto argErrors;
|
goto argErrors;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* All arguments were successfully matched.
|
* All arguments were successfully matched.
|
*/
|
*/
|
result = TCL_OK;
|
result = TCL_OK;
|
|
|
/*
|
/*
|
* If any errors were found, clean up and return error status.
|
* If any errors were found, clean up and return error status.
|
*/
|
*/
|
argErrors:
|
argErrors:
|
if (defobjv) {
|
if (defobjv) {
|
for (vi=0; vi < defargc; vi++) {
|
for (vi=0; vi < defargc; vi++) {
|
Tcl_DecrRefCount(defobjv[vi]);
|
Tcl_DecrRefCount(defobjv[vi]);
|
}
|
}
|
ckfree((char*)defobjv);
|
ckfree((char*)defobjv);
|
}
|
}
|
if (defargv) {
|
if (defargv) {
|
ckfree((char*)defargv);
|
ckfree((char*)defargv);
|
}
|
}
|
if (configVars) {
|
if (configVars) {
|
ckfree((char*)configVars);
|
ckfree((char*)configVars);
|
}
|
}
|
if (configVals) {
|
if (configVals) {
|
ckfree((char*)configVals);
|
ckfree((char*)configVals);
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclParseConfig()
|
* ItclParseConfig()
|
*
|
*
|
* Parses a set of arguments as "-variable value" assignments.
|
* Parses a set of arguments as "-variable value" assignments.
|
* Interprets all variable names in the most-specific class scope,
|
* Interprets all variable names in the most-specific class scope,
|
* so that an inherited method with a "config" parameter will work
|
* so that an inherited method with a "config" parameter will work
|
* correctly. Returns a list of public variable names and their
|
* correctly. Returns a list of public variable names and their
|
* corresponding values; both lists should passed to ItclHandleConfig()
|
* corresponding values; both lists should passed to ItclHandleConfig()
|
* to perform assignments, and freed when no longer in use. Returns a
|
* to perform assignments, and freed when no longer in use. Returns a
|
* status TCL_OK/TCL_ERROR and returns error messages in the interpreter.
|
* status TCL_OK/TCL_ERROR and returns error messages in the interpreter.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
static int
|
static int
|
ItclParseConfig(interp, objc, objv, contextObj, rargc, rvars, rvals)
|
ItclParseConfig(interp, objc, objv, contextObj, rargc, rvars, rvals)
|
Tcl_Interp *interp; /* interpreter */
|
Tcl_Interp *interp; /* interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
ItclObject *contextObj; /* object whose public vars are being config'd */
|
ItclObject *contextObj; /* object whose public vars are being config'd */
|
int *rargc; /* return: number of variables accessed */
|
int *rargc; /* return: number of variables accessed */
|
ItclVarDefn ***rvars; /* return: list of variables */
|
ItclVarDefn ***rvars; /* return: list of variables */
|
char ***rvals; /* return: list of values */
|
char ***rvals; /* return: list of values */
|
{
|
{
|
int result = TCL_OK;
|
int result = TCL_OK;
|
ItclVarLookup *vlookup;
|
ItclVarLookup *vlookup;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
char *varName, *value;
|
char *varName, *value;
|
|
|
if (objc < 0) objc = 0;
|
if (objc < 0) objc = 0;
|
*rargc = 0;
|
*rargc = 0;
|
*rvars = (ItclVarDefn**)ckalloc((unsigned)(objc*sizeof(ItclVarDefn*)));
|
*rvars = (ItclVarDefn**)ckalloc((unsigned)(objc*sizeof(ItclVarDefn*)));
|
*rvals = (char**)ckalloc((unsigned)(objc*sizeof(char*)));
|
*rvals = (char**)ckalloc((unsigned)(objc*sizeof(char*)));
|
|
|
while (objc-- > 0) {
|
while (objc-- > 0) {
|
/*
|
/*
|
* Next argument should be "-variable"
|
* Next argument should be "-variable"
|
*/
|
*/
|
varName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
varName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
if (*varName != '-') {
|
if (*varName != '-') {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"syntax error in config assignment \"",
|
"syntax error in config assignment \"",
|
varName, "\": should be \"-variable value\"",
|
varName, "\": should be \"-variable value\"",
|
(char*)NULL);
|
(char*)NULL);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
break;
|
break;
|
}
|
}
|
else if (objc-- <= 0) {
|
else if (objc-- <= 0) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"syntax error in config assignment \"",
|
"syntax error in config assignment \"",
|
varName, "\": should be \"-variable value\" (missing value)",
|
varName, "\": should be \"-variable value\" (missing value)",
|
(char*)NULL);
|
(char*)NULL);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
break;
|
break;
|
}
|
}
|
|
|
entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars,
|
entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars,
|
varName+1);
|
varName+1);
|
|
|
if (entry) {
|
if (entry) {
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
value = Tcl_GetStringFromObj(*(objv+1), (int*)NULL);
|
value = Tcl_GetStringFromObj(*(objv+1), (int*)NULL);
|
|
|
(*rvars)[*rargc] = vlookup->vdefn; /* variable definition */
|
(*rvars)[*rargc] = vlookup->vdefn; /* variable definition */
|
(*rvals)[*rargc] = value; /* config value */
|
(*rvals)[*rargc] = value; /* config value */
|
(*rargc)++;
|
(*rargc)++;
|
objv += 2;
|
objv += 2;
|
}
|
}
|
else {
|
else {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"syntax error in config assignment \"",
|
"syntax error in config assignment \"",
|
varName, "\": unrecognized variable",
|
varName, "\": unrecognized variable",
|
(char*)NULL);
|
(char*)NULL);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclHandleConfig()
|
* ItclHandleConfig()
|
*
|
*
|
* Handles the assignment of "config" values to public variables.
|
* Handles the assignment of "config" values to public variables.
|
* The list of assignments is parsed in ItclParseConfig(), but the
|
* The list of assignments is parsed in ItclParseConfig(), but the
|
* actual assignments are performed here. If the variables have any
|
* actual assignments are performed here. If the variables have any
|
* associated "config" code, it is invoked here as well. If errors
|
* associated "config" code, it is invoked here as well. If errors
|
* are detected during assignment or "config" code execution, the
|
* are detected during assignment or "config" code execution, the
|
* variable is set back to its previous value and an error is returned.
|
* variable is set back to its previous value and an error is returned.
|
*
|
*
|
* Returns a status TCL_OK/TCL_ERROR, and returns any error messages
|
* Returns a status TCL_OK/TCL_ERROR, and returns any error messages
|
* in the given interpreter.
|
* in the given interpreter.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
static int
|
static int
|
ItclHandleConfig(interp, argc, vars, vals, contextObj)
|
ItclHandleConfig(interp, argc, vars, vals, contextObj)
|
Tcl_Interp *interp; /* interpreter currently in control */
|
Tcl_Interp *interp; /* interpreter currently in control */
|
int argc; /* number of assignments */
|
int argc; /* number of assignments */
|
ItclVarDefn **vars; /* list of public variable definitions */
|
ItclVarDefn **vars; /* list of public variable definitions */
|
char **vals; /* list of public variable values */
|
char **vals; /* list of public variable values */
|
ItclObject *contextObj; /* object whose public vars are being config'd */
|
ItclObject *contextObj; /* object whose public vars are being config'd */
|
{
|
{
|
int result = TCL_OK;
|
int result = TCL_OK;
|
|
|
int i;
|
int i;
|
char *val;
|
char *val;
|
Tcl_DString lastval;
|
Tcl_DString lastval;
|
ItclContext context;
|
ItclContext context;
|
Tcl_CallFrame *oldFramePtr, *uplevelFramePtr;
|
Tcl_CallFrame *oldFramePtr, *uplevelFramePtr;
|
|
|
Tcl_DStringInit(&lastval);
|
Tcl_DStringInit(&lastval);
|
|
|
/*
|
/*
|
* All "config" assignments are performed in the most-specific
|
* All "config" assignments are performed in the most-specific
|
* class scope, so that inherited methods with "config" arguments
|
* class scope, so that inherited methods with "config" arguments
|
* will work correctly.
|
* will work correctly.
|
*/
|
*/
|
result = Itcl_PushContext(interp, (ItclMember*)NULL,
|
result = Itcl_PushContext(interp, (ItclMember*)NULL,
|
contextObj->classDefn, contextObj, &context);
|
contextObj->classDefn, contextObj, &context);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Perform each assignment and execute the "config" code
|
* Perform each assignment and execute the "config" code
|
* associated with each variable. If any errors are encountered,
|
* associated with each variable. If any errors are encountered,
|
* set the variable back to its previous value, and return an error.
|
* set the variable back to its previous value, and return an error.
|
*/
|
*/
|
for (i=0; i < argc; i++) {
|
for (i=0; i < argc; i++) {
|
val = Tcl_GetVar2(interp, vars[i]->member->fullname, (char*)NULL, 0);
|
val = Tcl_GetVar2(interp, vars[i]->member->fullname, (char*)NULL, 0);
|
if (!val) {
|
if (!val) {
|
val = "";
|
val = "";
|
}
|
}
|
Tcl_DStringSetLength(&lastval, 0);
|
Tcl_DStringSetLength(&lastval, 0);
|
Tcl_DStringAppend(&lastval, val, -1);
|
Tcl_DStringAppend(&lastval, val, -1);
|
|
|
/*
|
/*
|
* Set the variable to the specified value.
|
* Set the variable to the specified value.
|
*/
|
*/
|
if (!Tcl_SetVar2(interp, vars[i]->member->fullname, (char*)NULL,
|
if (!Tcl_SetVar2(interp, vars[i]->member->fullname, (char*)NULL,
|
vals[i], 0)) {
|
vals[i], 0)) {
|
|
|
char msg[256];
|
char msg[256];
|
sprintf(msg, "\n (while configuring public variable \"%.100s\")", vars[i]->member->fullname);
|
sprintf(msg, "\n (while configuring public variable \"%.100s\")", vars[i]->member->fullname);
|
Tcl_AddErrorInfo(interp, msg);
|
Tcl_AddErrorInfo(interp, msg);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
break;
|
break;
|
}
|
}
|
|
|
/*
|
/*
|
* If the variable has a "config" condition, then execute it.
|
* If the variable has a "config" condition, then execute it.
|
* If it fails, put the variable back the way it was and return
|
* If it fails, put the variable back the way it was and return
|
* an error.
|
* an error.
|
*
|
*
|
* TRICKY NOTE: Be careful to evaluate the code one level
|
* TRICKY NOTE: Be careful to evaluate the code one level
|
* up in the call stack, so that it's executed in the
|
* up in the call stack, so that it's executed in the
|
* calling context, and not in the context that we've
|
* calling context, and not in the context that we've
|
* set up for public variable access.
|
* set up for public variable access.
|
*/
|
*/
|
if (vars[i]->member->code) {
|
if (vars[i]->member->code) {
|
|
|
uplevelFramePtr = _Tcl_GetCallFrame(interp, 1);
|
uplevelFramePtr = _Tcl_GetCallFrame(interp, 1);
|
oldFramePtr = _Tcl_ActivateCallFrame(interp, uplevelFramePtr);
|
oldFramePtr = _Tcl_ActivateCallFrame(interp, uplevelFramePtr);
|
|
|
result = Itcl_EvalMemberCode(interp, (ItclMemberFunc*)NULL,
|
result = Itcl_EvalMemberCode(interp, (ItclMemberFunc*)NULL,
|
vars[i]->member, contextObj, 0, (Tcl_Obj* CONST*)NULL);
|
vars[i]->member, contextObj, 0, (Tcl_Obj* CONST*)NULL);
|
|
|
(void) _Tcl_ActivateCallFrame(interp, oldFramePtr);
|
(void) _Tcl_ActivateCallFrame(interp, oldFramePtr);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
char msg[256];
|
char msg[256];
|
sprintf(msg, "\n (while configuring public variable \"%.100s\")", vars[i]->member->fullname);
|
sprintf(msg, "\n (while configuring public variable \"%.100s\")", vars[i]->member->fullname);
|
Tcl_AddErrorInfo(interp, msg);
|
Tcl_AddErrorInfo(interp, msg);
|
Tcl_SetVar2(interp, vars[i]->member->fullname, (char*)NULL,
|
Tcl_SetVar2(interp, vars[i]->member->fullname, (char*)NULL,
|
Tcl_DStringValue(&lastval), 0);
|
Tcl_DStringValue(&lastval), 0);
|
break;
|
break;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Clean up and return.
|
* Clean up and return.
|
*/
|
*/
|
Itcl_PopContext(interp, &context);
|
Itcl_PopContext(interp, &context);
|
Tcl_DStringFree(&lastval);
|
Tcl_DStringFree(&lastval);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ConstructBase()
|
* Itcl_ConstructBase()
|
*
|
*
|
* Usually invoked just before executing the body of a constructor
|
* Usually invoked just before executing the body of a constructor
|
* when an object is first created. This procedure makes sure that
|
* when an object is first created. This procedure makes sure that
|
* all base classes are properly constructed. If an "initCode" fragment
|
* all base classes are properly constructed. If an "initCode" fragment
|
* was defined with the constructor for the class, then it is invoked.
|
* was defined with the constructor for the class, then it is invoked.
|
* After that, the list of base classes is checked for constructors
|
* After that, the list of base classes is checked for constructors
|
* that are defined but have not yet been invoked. Each of these is
|
* that are defined but have not yet been invoked. Each of these is
|
* invoked implicitly with no arguments.
|
* invoked implicitly with no arguments.
|
*
|
*
|
* Assumes that a local call frame is already installed, and that
|
* Assumes that a local call frame is already installed, and that
|
* constructor arguments have already been matched and are sitting in
|
* constructor arguments have already been matched and are sitting in
|
* this frame. Returns TCL_OK on success; otherwise, this procedure
|
* this frame. Returns TCL_OK on success; otherwise, this procedure
|
* returns TCL_ERROR, along with an error message in the interpreter.
|
* returns TCL_ERROR, along with an error message in the interpreter.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ConstructBase(interp, contextObj, contextClass)
|
Itcl_ConstructBase(interp, contextObj, contextClass)
|
Tcl_Interp *interp; /* interpreter */
|
Tcl_Interp *interp; /* interpreter */
|
ItclObject *contextObj; /* object being constructed */
|
ItclObject *contextObj; /* object being constructed */
|
ItclClass *contextClass; /* current class being constructed */
|
ItclClass *contextClass; /* current class being constructed */
|
{
|
{
|
int result;
|
int result;
|
Itcl_ListElem *elem;
|
Itcl_ListElem *elem;
|
ItclClass *cdefn;
|
ItclClass *cdefn;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
|
|
/*
|
/*
|
* If the class has an "initCode", invoke it in the current context.
|
* If the class has an "initCode", invoke it in the current context.
|
*
|
*
|
* TRICKY NOTE:
|
* TRICKY NOTE:
|
* This context is the call frame containing the arguments
|
* This context is the call frame containing the arguments
|
* for the constructor. The "initCode" makes sense right
|
* for the constructor. The "initCode" makes sense right
|
* now--just before the body of the constructor is executed.
|
* now--just before the body of the constructor is executed.
|
*/
|
*/
|
if (contextClass->initCode) {
|
if (contextClass->initCode) {
|
/* 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
|
if (Tcl_EvalObj(interp, contextClass->initCode) != TCL_OK) {
|
if (Tcl_EvalObj(interp, contextClass->initCode) != TCL_OK) {
|
#else
|
#else
|
if (Tcl_EvalObj(interp, contextClass->initCode, 0) != TCL_OK) {
|
if (Tcl_EvalObj(interp, contextClass->initCode, 0) != TCL_OK) {
|
#endif
|
#endif
|
/* END CYGNUS LOCAL */
|
/* END CYGNUS LOCAL */
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Scan through the list of base classes and see if any of these
|
* Scan through the list of base classes and see if any of these
|
* have not been constructed. Invoke base class constructors
|
* have not been constructed. Invoke base class constructors
|
* implicitly, as needed. Go through the list of base classes
|
* implicitly, as needed. Go through the list of base classes
|
* in reverse order, so that least-specific classes are constructed
|
* in reverse order, so that least-specific classes are constructed
|
* first.
|
* first.
|
*/
|
*/
|
elem = Itcl_LastListElem(&contextClass->bases);
|
elem = Itcl_LastListElem(&contextClass->bases);
|
while (elem) {
|
while (elem) {
|
cdefn = (ItclClass*)Itcl_GetListValue(elem);
|
cdefn = (ItclClass*)Itcl_GetListValue(elem);
|
|
|
if (!Tcl_FindHashEntry(contextObj->constructed, cdefn->name)) {
|
if (!Tcl_FindHashEntry(contextObj->constructed, cdefn->name)) {
|
|
|
result = Itcl_InvokeMethodIfExists(interp, "constructor",
|
result = Itcl_InvokeMethodIfExists(interp, "constructor",
|
cdefn, contextObj, 0, (Tcl_Obj* CONST*)NULL);
|
cdefn, contextObj, 0, (Tcl_Obj* CONST*)NULL);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* The base class may not have a constructor, but its
|
* The base class may not have a constructor, but its
|
* own base classes could have one. If the constructor
|
* own base classes could have one. If the constructor
|
* wasn't found in the last step, then other base classes
|
* wasn't found in the last step, then other base classes
|
* weren't constructed either. Make sure that all of its
|
* weren't constructed either. Make sure that all of its
|
* base classes are properly constructed.
|
* base classes are properly constructed.
|
*/
|
*/
|
entry = Tcl_FindHashEntry(&cdefn->functions, "constructor");
|
entry = Tcl_FindHashEntry(&cdefn->functions, "constructor");
|
if (entry == NULL) {
|
if (entry == NULL) {
|
result = Itcl_ConstructBase(interp, contextObj, cdefn);
|
result = Itcl_ConstructBase(interp, contextObj, cdefn);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
}
|
}
|
elem = Itcl_PrevListElem(elem);
|
elem = Itcl_PrevListElem(elem);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_InvokeMethodIfExists()
|
* Itcl_InvokeMethodIfExists()
|
*
|
*
|
* Looks for a particular method in the specified class. If the
|
* Looks for a particular method in the specified class. If the
|
* method is found, it is invoked with the given arguments. Any
|
* method is found, it is invoked with the given arguments. Any
|
* protection level (protected/private) for the method is ignored.
|
* protection level (protected/private) for the method is ignored.
|
* If the method does not exist, this procedure does nothing.
|
* If the method does not exist, this procedure does nothing.
|
*
|
*
|
* This procedure is used primarily to invoke the constructor/destructor
|
* This procedure is used primarily to invoke the constructor/destructor
|
* when an object is created/destroyed.
|
* when an object is created/destroyed.
|
*
|
*
|
* Returns TCL_OK on success; otherwise, this procedure returns
|
* Returns TCL_OK on success; otherwise, this procedure returns
|
* TCL_ERROR along with an error message in the interpreter.
|
* TCL_ERROR along with an error message in the interpreter.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_InvokeMethodIfExists(interp, name, contextClass, contextObj, objc, objv)
|
Itcl_InvokeMethodIfExists(interp, name, contextClass, contextObj, objc, objv)
|
Tcl_Interp *interp; /* interpreter */
|
Tcl_Interp *interp; /* interpreter */
|
char *name; /* name of desired method */
|
char *name; /* name of desired method */
|
ItclClass *contextClass; /* current class being constructed */
|
ItclClass *contextClass; /* current class being constructed */
|
ItclObject *contextObj; /* object being constructed */
|
ItclObject *contextObj; /* object being constructed */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
int result = TCL_OK;
|
int result = TCL_OK;
|
|
|
ItclMemberFunc *mfunc;
|
ItclMemberFunc *mfunc;
|
ItclMember *member;
|
ItclMember *member;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
Tcl_Obj *cmdlinePtr;
|
Tcl_Obj *cmdlinePtr;
|
int cmdlinec;
|
int cmdlinec;
|
Tcl_Obj **cmdlinev;
|
Tcl_Obj **cmdlinev;
|
|
|
/*
|
/*
|
* Scan through the list of base classes and see if any of these
|
* Scan through the list of base classes and see if any of these
|
* have not been constructed. Invoke base class constructors
|
* have not been constructed. Invoke base class constructors
|
* implicitly, as needed. Go through the list of base classes
|
* implicitly, as needed. Go through the list of base classes
|
* in reverse order, so that least-specific classes are constructed
|
* in reverse order, so that least-specific classes are constructed
|
* first.
|
* first.
|
*/
|
*/
|
entry = Tcl_FindHashEntry(&contextClass->functions, name);
|
entry = Tcl_FindHashEntry(&contextClass->functions, name);
|
|
|
if (entry) {
|
if (entry) {
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
member = mfunc->member;
|
member = mfunc->member;
|
|
|
/*
|
/*
|
* Prepend the method name to the list of arguments.
|
* Prepend the method name to the list of arguments.
|
*/
|
*/
|
cmdlinePtr = Itcl_CreateArgs(interp, name, objc, objv);
|
cmdlinePtr = Itcl_CreateArgs(interp, name, objc, objv);
|
|
|
(void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr,
|
(void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr,
|
&cmdlinec, &cmdlinev);
|
&cmdlinec, &cmdlinev);
|
|
|
/*
|
/*
|
* Execute the code for the method. Be careful to protect
|
* Execute the code for the method. Be careful to protect
|
* the method in case it gets deleted during execution.
|
* the method in case it gets deleted during execution.
|
*/
|
*/
|
Itcl_PreserveData((ClientData)mfunc);
|
Itcl_PreserveData((ClientData)mfunc);
|
|
|
result = Itcl_EvalMemberCode(interp, mfunc, member,
|
result = Itcl_EvalMemberCode(interp, mfunc, member,
|
contextObj, cmdlinec, cmdlinev);
|
contextObj, cmdlinec, cmdlinev);
|
|
|
result = Itcl_ReportFuncErrors(interp, mfunc,
|
result = Itcl_ReportFuncErrors(interp, mfunc,
|
contextObj, result);
|
contextObj, result);
|
|
|
Itcl_ReleaseData((ClientData)mfunc);
|
Itcl_ReleaseData((ClientData)mfunc);
|
Tcl_DecrRefCount(cmdlinePtr);
|
Tcl_DecrRefCount(cmdlinePtr);
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ReportFuncErrors()
|
* Itcl_ReportFuncErrors()
|
*
|
*
|
* Used to interpret the status code returned when the body of a
|
* Used to interpret the status code returned when the body of a
|
* Tcl-style proc is executed. Handles the "errorInfo" and "errorCode"
|
* Tcl-style proc is executed. Handles the "errorInfo" and "errorCode"
|
* variables properly, and adds error information into the interpreter
|
* variables properly, and adds error information into the interpreter
|
* if anything went wrong. Returns a new status code that should be
|
* if anything went wrong. Returns a new status code that should be
|
* treated as the return status code for the command.
|
* treated as the return status code for the command.
|
*
|
*
|
* This same operation is usually buried in the Tcl InterpProc()
|
* This same operation is usually buried in the Tcl InterpProc()
|
* procedure. It is defined here so that it can be reused more easily.
|
* procedure. It is defined here so that it can be reused more easily.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ReportFuncErrors(interp, mfunc, contextObj, result)
|
Itcl_ReportFuncErrors(interp, mfunc, contextObj, result)
|
Tcl_Interp* interp; /* interpreter being modified */
|
Tcl_Interp* interp; /* interpreter being modified */
|
ItclMemberFunc *mfunc; /* command member that was invoked */
|
ItclMemberFunc *mfunc; /* command member that was invoked */
|
ItclObject *contextObj; /* object context for this command */
|
ItclObject *contextObj; /* object context for this command */
|
int result; /* integer status code from proc body */
|
int result; /* integer status code from proc body */
|
{
|
{
|
Interp* iPtr = (Interp*)interp;
|
Interp* iPtr = (Interp*)interp;
|
Tcl_Obj *objPtr;
|
Tcl_Obj *objPtr;
|
char num[20];
|
char num[20];
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
if (result == TCL_RETURN) {
|
if (result == TCL_RETURN) {
|
result = TclUpdateReturnInfo(iPtr);
|
result = TclUpdateReturnInfo(iPtr);
|
}
|
}
|
else if (result == TCL_ERROR) {
|
else if (result == TCL_ERROR) {
|
objPtr = Tcl_NewStringObj("\n ", -1);
|
objPtr = Tcl_NewStringObj("\n ", -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
|
|
if (mfunc->member->flags & ITCL_CONSTRUCTOR) {
|
if (mfunc->member->flags & ITCL_CONSTRUCTOR) {
|
Tcl_AppendToObj(objPtr, "while constructing object \"", -1);
|
Tcl_AppendToObj(objPtr, "while constructing object \"", -1);
|
Tcl_GetCommandFullName(contextObj->classDefn->interp,
|
Tcl_GetCommandFullName(contextObj->classDefn->interp,
|
contextObj->accessCmd, objPtr);
|
contextObj->accessCmd, objPtr);
|
Tcl_AppendToObj(objPtr, "\" in ", -1);
|
Tcl_AppendToObj(objPtr, "\" in ", -1);
|
Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1);
|
Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1);
|
if ((mfunc->member->code->flags & ITCL_IMPLEMENT_TCL) != 0) {
|
if ((mfunc->member->code->flags & ITCL_IMPLEMENT_TCL) != 0) {
|
Tcl_AppendToObj(objPtr, " (", -1);
|
Tcl_AppendToObj(objPtr, " (", -1);
|
}
|
}
|
}
|
}
|
|
|
else if (mfunc->member->flags & ITCL_DESTRUCTOR) {
|
else if (mfunc->member->flags & ITCL_DESTRUCTOR) {
|
Tcl_AppendToObj(objPtr, "while deleting object \"", -1);
|
Tcl_AppendToObj(objPtr, "while deleting object \"", -1);
|
Tcl_GetCommandFullName(contextObj->classDefn->interp,
|
Tcl_GetCommandFullName(contextObj->classDefn->interp,
|
contextObj->accessCmd, objPtr);
|
contextObj->accessCmd, objPtr);
|
Tcl_AppendToObj(objPtr, "\" in ", -1);
|
Tcl_AppendToObj(objPtr, "\" in ", -1);
|
Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1);
|
Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1);
|
if ((mfunc->member->code->flags & ITCL_IMPLEMENT_TCL) != 0) {
|
if ((mfunc->member->code->flags & ITCL_IMPLEMENT_TCL) != 0) {
|
Tcl_AppendToObj(objPtr, " (", -1);
|
Tcl_AppendToObj(objPtr, " (", -1);
|
}
|
}
|
}
|
}
|
|
|
else {
|
else {
|
Tcl_AppendToObj(objPtr, "(", -1);
|
Tcl_AppendToObj(objPtr, "(", -1);
|
|
|
if (contextObj && contextObj->accessCmd) {
|
if (contextObj && contextObj->accessCmd) {
|
Tcl_AppendToObj(objPtr, "object \"", -1);
|
Tcl_AppendToObj(objPtr, "object \"", -1);
|
Tcl_GetCommandFullName(contextObj->classDefn->interp,
|
Tcl_GetCommandFullName(contextObj->classDefn->interp,
|
contextObj->accessCmd, objPtr);
|
contextObj->accessCmd, objPtr);
|
Tcl_AppendToObj(objPtr, "\" ", -1);
|
Tcl_AppendToObj(objPtr, "\" ", -1);
|
}
|
}
|
|
|
if ((mfunc->member->flags & ITCL_COMMON) != 0) {
|
if ((mfunc->member->flags & ITCL_COMMON) != 0) {
|
Tcl_AppendToObj(objPtr, "procedure", -1);
|
Tcl_AppendToObj(objPtr, "procedure", -1);
|
} else {
|
} else {
|
Tcl_AppendToObj(objPtr, "method", -1);
|
Tcl_AppendToObj(objPtr, "method", -1);
|
}
|
}
|
Tcl_AppendToObj(objPtr, " \"", -1);
|
Tcl_AppendToObj(objPtr, " \"", -1);
|
Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1);
|
Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1);
|
Tcl_AppendToObj(objPtr, "\" ", -1);
|
Tcl_AppendToObj(objPtr, "\" ", -1);
|
}
|
}
|
|
|
if ((mfunc->member->code->flags & ITCL_IMPLEMENT_TCL) != 0) {
|
if ((mfunc->member->code->flags & ITCL_IMPLEMENT_TCL) != 0) {
|
Tcl_AppendToObj(objPtr, "body line ", -1);
|
Tcl_AppendToObj(objPtr, "body line ", -1);
|
sprintf(num, "%d", iPtr->errorLine);
|
sprintf(num, "%d", iPtr->errorLine);
|
Tcl_AppendToObj(objPtr, num, -1);
|
Tcl_AppendToObj(objPtr, num, -1);
|
Tcl_AppendToObj(objPtr, ")", -1);
|
Tcl_AppendToObj(objPtr, ")", -1);
|
} else {
|
} else {
|
Tcl_AppendToObj(objPtr, ")", -1);
|
Tcl_AppendToObj(objPtr, ")", -1);
|
}
|
}
|
|
|
Tcl_AddErrorInfo(interp, Tcl_GetStringFromObj(objPtr, (int*)NULL));
|
Tcl_AddErrorInfo(interp, Tcl_GetStringFromObj(objPtr, (int*)NULL));
|
Tcl_DecrRefCount(objPtr);
|
Tcl_DecrRefCount(objPtr);
|
}
|
}
|
|
|
else if (result == TCL_BREAK) {
|
else if (result == TCL_BREAK) {
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
"invoked \"break\" outside of a loop", -1);
|
"invoked \"break\" outside of a loop", -1);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
}
|
}
|
|
|
else if (result == TCL_CONTINUE) {
|
else if (result == TCL_CONTINUE) {
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
"invoked \"continue\" outside of a loop", -1);
|
"invoked \"continue\" outside of a loop", -1);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
}
|
}
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|