/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* 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 built-in class methods, including the
|
* These procedures handle built-in class methods, including the
|
* "isa" method (to query hierarchy info) and the "info" method
|
* "isa" method (to query hierarchy info) and the "info" method
|
* (to query class/object data).
|
* (to query class/object 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_bicmds.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $
|
* RCS: $Id: itcl_bicmds.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"
|
|
|
/*
|
/*
|
* Standard list of built-in methods for all objects.
|
* Standard list of built-in methods for all objects.
|
*/
|
*/
|
typedef struct BiMethod {
|
typedef struct BiMethod {
|
char* name; /* method name */
|
char* name; /* method name */
|
char* usage; /* string describing usage */
|
char* usage; /* string describing usage */
|
char* registration; /* registration name for C proc */
|
char* registration; /* registration name for C proc */
|
Tcl_ObjCmdProc *proc; /* implementation C proc */
|
Tcl_ObjCmdProc *proc; /* implementation C proc */
|
} BiMethod;
|
} BiMethod;
|
|
|
static BiMethod BiMethodList[] = {
|
static BiMethod BiMethodList[] = {
|
{ "cget", "-option",
|
{ "cget", "-option",
|
"@itcl-builtin-cget", Itcl_BiCgetCmd },
|
"@itcl-builtin-cget", Itcl_BiCgetCmd },
|
{ "configure", "?-option? ?value -option value...?",
|
{ "configure", "?-option? ?value -option value...?",
|
"@itcl-builtin-configure", Itcl_BiConfigureCmd },
|
"@itcl-builtin-configure", Itcl_BiConfigureCmd },
|
{ "isa", "className",
|
{ "isa", "className",
|
"@itcl-builtin-isa", Itcl_BiIsaCmd },
|
"@itcl-builtin-isa", Itcl_BiIsaCmd },
|
};
|
};
|
static int BiMethodListLen = sizeof(BiMethodList)/sizeof(BiMethod);
|
static int BiMethodListLen = sizeof(BiMethodList)/sizeof(BiMethod);
|
|
|
|
|
/*
|
/*
|
* FORWARD DECLARATIONS
|
* FORWARD DECLARATIONS
|
*/
|
*/
|
static Tcl_Obj* ItclReportPublicOpt _ANSI_ARGS_((Tcl_Interp *interp,
|
static Tcl_Obj* ItclReportPublicOpt _ANSI_ARGS_((Tcl_Interp *interp,
|
ItclVarDefn *vdefn, ItclObject *contextObj));
|
ItclVarDefn *vdefn, ItclObject *contextObj));
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_BiInit()
|
* Itcl_BiInit()
|
*
|
*
|
* Creates a namespace full of built-in methods/procs for [incr Tcl]
|
* Creates a namespace full of built-in methods/procs for [incr Tcl]
|
* classes. This includes things like the "isa" method and "info"
|
* classes. This includes things like the "isa" method and "info"
|
* for querying class info. Usually invoked by Itcl_Init() when
|
* for querying class info. Usually invoked by Itcl_Init() when
|
* [incr Tcl] is first installed into an interpreter.
|
* [incr Tcl] is first installed into an interpreter.
|
*
|
*
|
* Returns TCL_OK/TCL_ERROR to indicate success/failure.
|
* Returns TCL_OK/TCL_ERROR to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_BiInit(interp)
|
Itcl_BiInit(interp)
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
{
|
{
|
int i;
|
int i;
|
Tcl_Namespace *itclBiNs;
|
Tcl_Namespace *itclBiNs;
|
|
|
/*
|
/*
|
* Declare all of the built-in methods as C procedures.
|
* Declare all of the built-in methods as C procedures.
|
*/
|
*/
|
for (i=0; i < BiMethodListLen; i++) {
|
for (i=0; i < BiMethodListLen; i++) {
|
if (Itcl_RegisterObjC(interp,
|
if (Itcl_RegisterObjC(interp,
|
BiMethodList[i].registration+1, BiMethodList[i].proc,
|
BiMethodList[i].registration+1, BiMethodList[i].proc,
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) {
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) {
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Create the "::itcl::builtin" namespace for built-in class
|
* Create the "::itcl::builtin" namespace for built-in class
|
* commands. These commands are imported into each class
|
* commands. These commands are imported into each class
|
* just before the class definition is parsed.
|
* just before the class definition is parsed.
|
*/
|
*/
|
Tcl_CreateObjCommand(interp, "::itcl::builtin::chain", Itcl_BiChainCmd,
|
Tcl_CreateObjCommand(interp, "::itcl::builtin::chain", Itcl_BiChainCmd,
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);
|
|
|
if (Itcl_CreateEnsemble(interp, "::itcl::builtin::info") != TCL_OK) {
|
if (Itcl_CreateEnsemble(interp, "::itcl::builtin::info") != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
|
if (Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
|
"class", "",
|
"class", "",
|
Itcl_BiInfoClassCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
Itcl_BiInfoClassCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK ||
|
!= TCL_OK ||
|
Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
|
Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
|
"inherit", "",
|
"inherit", "",
|
Itcl_BiInfoInheritCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
Itcl_BiInfoInheritCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK ||
|
!= TCL_OK ||
|
Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
|
Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
|
"heritage", "",
|
"heritage", "",
|
Itcl_BiInfoHeritageCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
Itcl_BiInfoHeritageCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK ||
|
!= TCL_OK ||
|
Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
|
Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
|
"function", "?name? ?-protection? ?-type? ?-name? ?-args? ?-body?",
|
"function", "?name? ?-protection? ?-type? ?-name? ?-args? ?-body?",
|
Itcl_BiInfoFunctionCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
Itcl_BiInfoFunctionCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK ||
|
!= TCL_OK ||
|
Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
|
Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
|
"variable", "?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config?",
|
"variable", "?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config?",
|
Itcl_BiInfoVariableCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
Itcl_BiInfoVariableCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK ||
|
!= TCL_OK ||
|
Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
|
Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
|
"args", "procname",
|
"args", "procname",
|
Itcl_BiInfoArgsCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
Itcl_BiInfoArgsCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK ||
|
!= TCL_OK ||
|
Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
|
Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
|
"body", "procname",
|
"body", "procname",
|
Itcl_BiInfoBodyCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
Itcl_BiInfoBodyCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK
|
!= TCL_OK
|
) {
|
) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Add an error handler to support all of the usual inquiries
|
* Add an error handler to support all of the usual inquiries
|
* for the "info" command in the global namespace.
|
* for the "info" command in the global namespace.
|
*/
|
*/
|
if (Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
|
if (Itcl_AddEnsemblePart(interp, "::itcl::builtin::info",
|
"@error", "",
|
"@error", "",
|
Itcl_DefaultInfoCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
Itcl_DefaultInfoCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK
|
!= TCL_OK
|
) {
|
) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Export all commands in the built-in namespace so we can
|
* Export all commands in the built-in namespace so we can
|
* import them later on.
|
* import them later on.
|
*/
|
*/
|
itclBiNs = Tcl_FindNamespace(interp, "::itcl::builtin",
|
itclBiNs = Tcl_FindNamespace(interp, "::itcl::builtin",
|
(Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);
|
(Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);
|
|
|
if (!itclBiNs ||
|
if (!itclBiNs ||
|
Tcl_Export(interp, itclBiNs, "*", /* resetListFirst */ 1) != TCL_OK) {
|
Tcl_Export(interp, itclBiNs, "*", /* resetListFirst */ 1) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_InstallBiMethods()
|
* Itcl_InstallBiMethods()
|
*
|
*
|
* Invoked when a class is first created, just after the class
|
* Invoked when a class is first created, just after the class
|
* definition has been parsed, to add definitions for built-in
|
* definition has been parsed, to add definitions for built-in
|
* methods to the class. If a method already exists in the class
|
* methods to the class. If a method already exists in the class
|
* with the same name as the built-in, then the built-in is skipped.
|
* with the same name as the built-in, then the built-in is skipped.
|
* Otherwise, a method definition for the built-in method is added.
|
* Otherwise, a method definition for the built-in method is added.
|
*
|
*
|
* Returns TCL_OK if successful, or TCL_ERROR (along with an error
|
* Returns TCL_OK if successful, or TCL_ERROR (along with an error
|
* message in the interpreter) if anything goes wrong.
|
* message in the interpreter) if anything goes wrong.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_InstallBiMethods(interp, cdefn)
|
Itcl_InstallBiMethods(interp, cdefn)
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
ItclClass *cdefn; /* class definition to be updated */
|
ItclClass *cdefn; /* class definition to be updated */
|
{
|
{
|
int result = TCL_OK;
|
int result = TCL_OK;
|
Tcl_HashEntry *entry = NULL;
|
Tcl_HashEntry *entry = NULL;
|
|
|
int i;
|
int i;
|
ItclHierIter hier;
|
ItclHierIter hier;
|
ItclClass *cdPtr;
|
ItclClass *cdPtr;
|
|
|
/*
|
/*
|
* Scan through all of the built-in methods and see if
|
* Scan through all of the built-in methods and see if
|
* that method already exists in the class. If not, add
|
* that method already exists in the class. If not, add
|
* it in.
|
* it in.
|
*
|
*
|
* TRICKY NOTE: The virtual tables haven't been built yet,
|
* TRICKY NOTE: The virtual tables haven't been built yet,
|
* so look for existing methods the hard way--by scanning
|
* so look for existing methods the hard way--by scanning
|
* through all classes.
|
* through all classes.
|
*/
|
*/
|
for (i=0; i < BiMethodListLen; i++) {
|
for (i=0; i < BiMethodListLen; i++) {
|
Itcl_InitHierIter(&hier, cdefn);
|
Itcl_InitHierIter(&hier, cdefn);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
while (cdPtr) {
|
while (cdPtr) {
|
entry = Tcl_FindHashEntry(&cdPtr->functions, BiMethodList[i].name);
|
entry = Tcl_FindHashEntry(&cdPtr->functions, BiMethodList[i].name);
|
if (entry) {
|
if (entry) {
|
break;
|
break;
|
}
|
}
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
}
|
}
|
Itcl_DeleteHierIter(&hier);
|
Itcl_DeleteHierIter(&hier);
|
|
|
if (!entry) {
|
if (!entry) {
|
result = Itcl_CreateMethod(interp, cdefn, BiMethodList[i].name,
|
result = Itcl_CreateMethod(interp, cdefn, BiMethodList[i].name,
|
BiMethodList[i].usage, BiMethodList[i].registration);
|
BiMethodList[i].usage, BiMethodList[i].registration);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
break;
|
break;
|
}
|
}
|
}
|
}
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_BiIsaCmd()
|
* Itcl_BiIsaCmd()
|
*
|
*
|
* Invoked whenever the user issues the "isa" method for an object.
|
* Invoked whenever the user issues the "isa" method for an object.
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* <objName> isa <className>
|
* <objName> isa <className>
|
*
|
*
|
* Checks to see if the object has the given <className> anywhere
|
* Checks to see if the object has the given <className> anywhere
|
* in its heritage. Returns 1 if so, and 0 otherwise.
|
* in its heritage. Returns 1 if so, and 0 otherwise.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Itcl_BiIsaCmd(clientData, interp, objc, objv)
|
Itcl_BiIsaCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* class definition */
|
ClientData clientData; /* class 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 */
|
{
|
{
|
ItclClass *contextClass, *cdefn;
|
ItclClass *contextClass, *cdefn;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
char *token;
|
char *token;
|
|
|
/*
|
/*
|
* Make sure that this command is being invoked in the proper
|
* Make sure that this command is being invoked in the proper
|
* context.
|
* context.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (!contextObj) {
|
if (!contextObj) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"improper usage: should be \"object isa className\"",
|
"improper usage: should be \"object isa className\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (objc != 2) {
|
if (objc != 2) {
|
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 \"object ", token, " className\"",
|
"wrong # args: should be \"object ", token, " className\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Look for the requested class. If it is not found, then
|
* Look for the requested class. If it is not found, then
|
* try to autoload it. If it absolutely cannot be found,
|
* try to autoload it. If it absolutely cannot be found,
|
* signal an error.
|
* signal an error.
|
*/
|
*/
|
token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
cdefn = Itcl_FindClass(interp, token, /* autoload */ 1);
|
cdefn = Itcl_FindClass(interp, token, /* autoload */ 1);
|
if (cdefn == NULL) {
|
if (cdefn == NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (Itcl_ObjectIsa(contextObj, cdefn)) {
|
if (Itcl_ObjectIsa(contextObj, cdefn)) {
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
|
} else {
|
} else {
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_BiConfigureCmd()
|
* Itcl_BiConfigureCmd()
|
*
|
*
|
* Invoked whenever the user issues the "configure" method for an object.
|
* Invoked whenever the user issues the "configure" method for an object.
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* <objName> configure ?-<option>? ?<value> -<option> <value>...?
|
* <objName> configure ?-<option>? ?<value> -<option> <value>...?
|
*
|
*
|
* Allows access to public variables as if they were configuration
|
* Allows access to public variables as if they were configuration
|
* options. With no arguments, this command returns the current
|
* options. With no arguments, this command returns the current
|
* list of public variable options. If -<option> is specified,
|
* list of public variable options. If -<option> is specified,
|
* this returns the information for just one option:
|
* this returns the information for just one option:
|
*
|
*
|
* -<optionName> <initVal> <currentVal>
|
* -<optionName> <initVal> <currentVal>
|
*
|
*
|
* Otherwise, the list of arguments is parsed, and values are
|
* Otherwise, the list of arguments is parsed, and values are
|
* assigned to the various public variable options. When each
|
* assigned to the various public variable options. When each
|
* option changes, a big of "config" code associated with the option
|
* option changes, a big of "config" code associated with the option
|
* is executed, to bring the object up to date.
|
* is executed, to bring the object up to date.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Itcl_BiConfigureCmd(clientData, interp, objc, objv)
|
Itcl_BiConfigureCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* class definition */
|
ClientData clientData; /* class 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 */
|
{
|
{
|
ItclClass *contextClass;
|
ItclClass *contextClass;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
|
|
int i, result;
|
int i, result;
|
char *token, *lastval;
|
char *token, *lastval;
|
ItclClass *cdPtr;
|
ItclClass *cdPtr;
|
Tcl_HashSearch place;
|
Tcl_HashSearch place;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclVarDefn *vdefn;
|
ItclVarDefn *vdefn;
|
ItclVarLookup *vlookup;
|
ItclVarLookup *vlookup;
|
ItclMember *member;
|
ItclMember *member;
|
ItclMemberCode *mcode;
|
ItclMemberCode *mcode;
|
ItclHierIter hier;
|
ItclHierIter hier;
|
Tcl_Obj *resultPtr, *objPtr;
|
Tcl_Obj *resultPtr, *objPtr;
|
Tcl_DString buffer;
|
Tcl_DString buffer;
|
ItclContext context;
|
ItclContext context;
|
Tcl_CallFrame *oldFramePtr, *uplevelFramePtr;
|
Tcl_CallFrame *oldFramePtr, *uplevelFramePtr;
|
|
|
/*
|
/*
|
* Make sure that this command is being invoked in the proper
|
* Make sure that this command is being invoked in the proper
|
* context.
|
* context.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (!contextObj) {
|
if (!contextObj) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"improper usage: should be ",
|
"improper usage: should be ",
|
"\"object configure ?-option? ?value -option value...?\"",
|
"\"object configure ?-option? ?value -option value...?\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* BE CAREFUL: work in the virtual scope!
|
* BE CAREFUL: work in the virtual scope!
|
*/
|
*/
|
contextClass = contextObj->classDefn;
|
contextClass = contextObj->classDefn;
|
|
|
/*
|
/*
|
* HANDLE: configure
|
* HANDLE: configure
|
*/
|
*/
|
if (objc == 1) {
|
if (objc == 1) {
|
resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
|
|
Itcl_InitHierIter(&hier, contextClass);
|
Itcl_InitHierIter(&hier, contextClass);
|
while ((cdPtr=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
while ((cdPtr=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
|
entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
|
while (entry) {
|
while (entry) {
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
if (vdefn->member->protection == ITCL_PUBLIC) {
|
if (vdefn->member->protection == ITCL_PUBLIC) {
|
objPtr = ItclReportPublicOpt(interp, vdefn, contextObj);
|
objPtr = ItclReportPublicOpt(interp, vdefn, contextObj);
|
|
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr,
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr,
|
objPtr);
|
objPtr);
|
}
|
}
|
entry = Tcl_NextHashEntry(&place);
|
entry = Tcl_NextHashEntry(&place);
|
}
|
}
|
}
|
}
|
Itcl_DeleteHierIter(&hier);
|
Itcl_DeleteHierIter(&hier);
|
|
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* HANDLE: configure -option
|
* HANDLE: configure -option
|
*/
|
*/
|
else if (objc == 2) {
|
else if (objc == 2) {
|
token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
if (*token != '-') {
|
if (*token != '-') {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"improper usage: should be ",
|
"improper usage: should be ",
|
"\"object configure ?-option? ?value -option value...?\"",
|
"\"object configure ?-option? ?value -option value...?\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
vlookup = NULL;
|
vlookup = NULL;
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, token+1);
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, token+1);
|
if (entry) {
|
if (entry) {
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
|
|
if (vlookup->vdefn->member->protection != ITCL_PUBLIC) {
|
if (vlookup->vdefn->member->protection != ITCL_PUBLIC) {
|
vlookup = NULL;
|
vlookup = NULL;
|
}
|
}
|
}
|
}
|
|
|
if (!vlookup) {
|
if (!vlookup) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"unknown option \"", token, "\"",
|
"unknown option \"", token, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
resultPtr = ItclReportPublicOpt(interp, vlookup->vdefn, contextObj);
|
resultPtr = ItclReportPublicOpt(interp, vlookup->vdefn, contextObj);
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* HANDLE: configure -option value -option value...
|
* HANDLE: configure -option value -option value...
|
*
|
*
|
* Be careful to work in the virtual scope. If this "configure"
|
* Be careful to work in the virtual scope. If this "configure"
|
* method was defined in a base class, the current namespace
|
* method was defined in a base class, the current namespace
|
* (from Itcl_ExecMethod()) will be that base class. Activate
|
* (from Itcl_ExecMethod()) will be that base class. Activate
|
* the derived class namespace here, so that instance variables
|
* the derived class namespace here, so that instance variables
|
* are accessed properly.
|
* are accessed properly.
|
*/
|
*/
|
result = TCL_OK;
|
result = TCL_OK;
|
|
|
if (Itcl_PushContext(interp, (ItclMember*)NULL, contextObj->classDefn,
|
if (Itcl_PushContext(interp, (ItclMember*)NULL, contextObj->classDefn,
|
contextObj, &context) != TCL_OK) {
|
contextObj, &context) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Tcl_DStringInit(&buffer);
|
Tcl_DStringInit(&buffer);
|
|
|
for (i=1; i < objc; i+=2) {
|
for (i=1; i < objc; i+=2) {
|
vlookup = NULL;
|
vlookup = NULL;
|
token = Tcl_GetStringFromObj(objv[i], (int*)NULL);
|
token = Tcl_GetStringFromObj(objv[i], (int*)NULL);
|
if (*token == '-') {
|
if (*token == '-') {
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, token+1);
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, token+1);
|
if (entry) {
|
if (entry) {
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
}
|
}
|
}
|
}
|
|
|
if (!vlookup || vlookup->vdefn->member->protection != ITCL_PUBLIC) {
|
if (!vlookup || vlookup->vdefn->member->protection != ITCL_PUBLIC) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"unknown option \"", token, "\"",
|
"unknown option \"", token, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
goto configureDone;
|
goto configureDone;
|
}
|
}
|
if (i == objc-1) {
|
if (i == objc-1) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"value for \"", token, "\" missing",
|
"value for \"", token, "\" missing",
|
(char*)NULL);
|
(char*)NULL);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
goto configureDone;
|
goto configureDone;
|
}
|
}
|
|
|
member = vlookup->vdefn->member;
|
member = vlookup->vdefn->member;
|
lastval = Tcl_GetVar2(interp, member->fullname, (char*)NULL, 0);
|
lastval = Tcl_GetVar2(interp, member->fullname, (char*)NULL, 0);
|
Tcl_DStringSetLength(&buffer, 0);
|
Tcl_DStringSetLength(&buffer, 0);
|
Tcl_DStringAppend(&buffer, (lastval) ? lastval : "", -1);
|
Tcl_DStringAppend(&buffer, (lastval) ? lastval : "", -1);
|
|
|
token = Tcl_GetStringFromObj(objv[i+1], (int*)NULL);
|
token = Tcl_GetStringFromObj(objv[i+1], (int*)NULL);
|
|
|
if (Tcl_SetVar2(interp, member->fullname, (char*)NULL, token,
|
if (Tcl_SetVar2(interp, member->fullname, (char*)NULL, token,
|
TCL_LEAVE_ERR_MSG) == NULL) {
|
TCL_LEAVE_ERR_MSG) == NULL) {
|
|
|
char msg[256];
|
char msg[256];
|
sprintf(msg, "\n (error in configuration of public variable \"%.100s\")", member->fullname);
|
sprintf(msg, "\n (error in configuration of public variable \"%.100s\")", member->fullname);
|
Tcl_AddErrorInfo(interp, msg);
|
Tcl_AddErrorInfo(interp, msg);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
goto configureDone;
|
goto configureDone;
|
}
|
}
|
|
|
/*
|
/*
|
* If this variable has some "config" code, invoke it now.
|
* If this variable has some "config" code, invoke it now.
|
*
|
*
|
* 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.
|
*/
|
*/
|
mcode = member->code;
|
mcode = member->code;
|
if (mcode && mcode->procPtr->bodyPtr) {
|
if (mcode && mcode->procPtr->bodyPtr) {
|
|
|
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,
|
member, contextObj, 0, (Tcl_Obj**)NULL);
|
member, contextObj, 0, (Tcl_Obj**)NULL);
|
|
|
(void) _Tcl_ActivateCallFrame(interp, oldFramePtr);
|
(void) _Tcl_ActivateCallFrame(interp, oldFramePtr);
|
|
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
} else {
|
} else {
|
char msg[256];
|
char msg[256];
|
sprintf(msg, "\n (error in configuration of public variable \"%.100s\")", member->fullname);
|
sprintf(msg, "\n (error in configuration of public variable \"%.100s\")", member->fullname);
|
Tcl_AddErrorInfo(interp, msg);
|
Tcl_AddErrorInfo(interp, msg);
|
|
|
Tcl_SetVar2(interp, member->fullname,(char*)NULL,
|
Tcl_SetVar2(interp, member->fullname,(char*)NULL,
|
Tcl_DStringValue(&buffer), 0);
|
Tcl_DStringValue(&buffer), 0);
|
|
|
goto configureDone;
|
goto configureDone;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
configureDone:
|
configureDone:
|
Itcl_PopContext(interp, &context);
|
Itcl_PopContext(interp, &context);
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_BiCgetCmd()
|
* Itcl_BiCgetCmd()
|
*
|
*
|
* Invoked whenever the user issues the "cget" method for an object.
|
* Invoked whenever the user issues the "cget" method for an object.
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* <objName> cget -<option>
|
* <objName> cget -<option>
|
*
|
*
|
* Allows access to public variables as if they were configuration
|
* Allows access to public variables as if they were configuration
|
* options. Mimics the behavior of the usual "cget" method for
|
* options. Mimics the behavior of the usual "cget" method for
|
* Tk widgets. Returns the current value of the public variable
|
* Tk widgets. Returns the current value of the public variable
|
* with name <option>.
|
* with name <option>.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Itcl_BiCgetCmd(clientData, interp, objc, objv)
|
Itcl_BiCgetCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* class definition */
|
ClientData clientData; /* class 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 */
|
{
|
{
|
ItclClass *contextClass;
|
ItclClass *contextClass;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
|
|
char *name, *val;
|
char *name, *val;
|
ItclVarLookup *vlookup;
|
ItclVarLookup *vlookup;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
|
|
/*
|
/*
|
* Make sure that this command is being invoked in the proper
|
* Make sure that this command is being invoked in the proper
|
* context.
|
* context.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (!contextObj || objc != 2) {
|
if (!contextObj || objc != 2) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"improper usage: should be \"object cget -option\"",
|
"improper usage: should be \"object cget -option\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* BE CAREFUL: work in the virtual scope!
|
* BE CAREFUL: work in the virtual scope!
|
*/
|
*/
|
contextClass = contextObj->classDefn;
|
contextClass = contextObj->classDefn;
|
|
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
|
|
vlookup = NULL;
|
vlookup = NULL;
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, name+1);
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, name+1);
|
if (entry) {
|
if (entry) {
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
}
|
}
|
|
|
if (!vlookup || vlookup->vdefn->member->protection != ITCL_PUBLIC) {
|
if (!vlookup || vlookup->vdefn->member->protection != ITCL_PUBLIC) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"unknown option \"", name, "\"",
|
"unknown option \"", name, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
val = Itcl_GetInstanceVar(interp, vlookup->vdefn->member->fullname,
|
val = Itcl_GetInstanceVar(interp, vlookup->vdefn->member->fullname,
|
contextObj, contextObj->classDefn);
|
contextObj, contextObj->classDefn);
|
|
|
if (val) {
|
if (val) {
|
Tcl_SetResult(interp, val, TCL_VOLATILE);
|
Tcl_SetResult(interp, val, TCL_VOLATILE);
|
} else {
|
} else {
|
Tcl_SetResult(interp, "<undefined>", TCL_STATIC);
|
Tcl_SetResult(interp, "<undefined>", TCL_STATIC);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclReportPublicOpt()
|
* ItclReportPublicOpt()
|
*
|
*
|
* Returns information about a public variable formatted as a
|
* Returns information about a public variable formatted as a
|
* configuration option:
|
* configuration option:
|
*
|
*
|
* -<varName> <initVal> <currentVal>
|
* -<varName> <initVal> <currentVal>
|
*
|
*
|
* Used by Itcl_BiConfigureCmd() to report configuration options.
|
* Used by Itcl_BiConfigureCmd() to report configuration options.
|
* Returns a Tcl_Obj containing the information.
|
* Returns a Tcl_Obj containing the information.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
static Tcl_Obj*
|
static Tcl_Obj*
|
ItclReportPublicOpt(interp, vdefn, contextObj)
|
ItclReportPublicOpt(interp, vdefn, contextObj)
|
Tcl_Interp *interp; /* interpreter containing the object */
|
Tcl_Interp *interp; /* interpreter containing the object */
|
ItclVarDefn *vdefn; /* public variable to be reported */
|
ItclVarDefn *vdefn; /* public variable to be reported */
|
ItclObject *contextObj; /* object containing this variable */
|
ItclObject *contextObj; /* object containing this variable */
|
{
|
{
|
char *val;
|
char *val;
|
ItclClass *cdefnPtr;
|
ItclClass *cdefnPtr;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclVarLookup *vlookup;
|
ItclVarLookup *vlookup;
|
Tcl_DString optName;
|
Tcl_DString optName;
|
Tcl_Obj *listPtr, *objPtr;
|
Tcl_Obj *listPtr, *objPtr;
|
|
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
|
|
/*
|
/*
|
* Determine how the option name should be reported.
|
* Determine how the option name should be reported.
|
* If the simple name can be used to find it in the virtual
|
* If the simple name can be used to find it in the virtual
|
* data table, then use the simple name. Otherwise, this
|
* data table, then use the simple name. Otherwise, this
|
* is a shadowed variable; use the full name.
|
* is a shadowed variable; use the full name.
|
*/
|
*/
|
Tcl_DStringInit(&optName);
|
Tcl_DStringInit(&optName);
|
Tcl_DStringAppend(&optName, "-", -1);
|
Tcl_DStringAppend(&optName, "-", -1);
|
|
|
cdefnPtr = (ItclClass*)contextObj->classDefn;
|
cdefnPtr = (ItclClass*)contextObj->classDefn;
|
entry = Tcl_FindHashEntry(&cdefnPtr->resolveVars, vdefn->member->fullname);
|
entry = Tcl_FindHashEntry(&cdefnPtr->resolveVars, vdefn->member->fullname);
|
assert(entry != NULL);
|
assert(entry != NULL);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
Tcl_DStringAppend(&optName, vlookup->leastQualName, -1);
|
Tcl_DStringAppend(&optName, vlookup->leastQualName, -1);
|
|
|
objPtr = Tcl_NewStringObj(Tcl_DStringValue(&optName), -1);
|
objPtr = Tcl_NewStringObj(Tcl_DStringValue(&optName), -1);
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr);
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr);
|
Tcl_DStringFree(&optName);
|
Tcl_DStringFree(&optName);
|
|
|
|
|
if (vdefn->init) {
|
if (vdefn->init) {
|
objPtr = Tcl_NewStringObj(vdefn->init, -1);
|
objPtr = Tcl_NewStringObj(vdefn->init, -1);
|
} else {
|
} else {
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
}
|
}
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr);
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr);
|
|
|
val = Itcl_GetInstanceVar(interp, vdefn->member->fullname, contextObj,
|
val = Itcl_GetInstanceVar(interp, vdefn->member->fullname, contextObj,
|
contextObj->classDefn);
|
contextObj->classDefn);
|
|
|
if (val) {
|
if (val) {
|
objPtr = Tcl_NewStringObj(val, -1);
|
objPtr = Tcl_NewStringObj(val, -1);
|
} else {
|
} else {
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
}
|
}
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr);
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr);
|
|
|
return listPtr;
|
return listPtr;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_BiChainCmd()
|
* Itcl_BiChainCmd()
|
*
|
*
|
* Invoked to handle the "chain" command, to access the version of
|
* Invoked to handle the "chain" command, to access the version of
|
* a method or proc that exists in a base class. Handles the
|
* a method or proc that exists in a base class. Handles the
|
* following syntax:
|
* following syntax:
|
*
|
*
|
* chain ?<arg> <arg>...?
|
* chain ?<arg> <arg>...?
|
*
|
*
|
* Looks up the inheritance hierarchy for another implementation
|
* Looks up the inheritance hierarchy for another implementation
|
* of the method/proc that is currently executing. If another
|
* of the method/proc that is currently executing. If another
|
* implementation is found, it is invoked with the specified
|
* implementation is found, it is invoked with the specified
|
* <arg> arguments. If it is not found, this command does nothing.
|
* <arg> arguments. If it is not found, this command does nothing.
|
* This allows a base class method to be called out in a generic way,
|
* This allows a base class method to be called out in a generic way,
|
* so the code will not have to change if the base class changes.
|
* so the code will not have to change if the base class changes.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Itcl_BiChainCmd(dummy, interp, objc, objv)
|
Itcl_BiChainCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
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 result = TCL_OK;
|
int result = TCL_OK;
|
|
|
ItclClass *contextClass;
|
ItclClass *contextClass;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
|
|
char *cmd, *head;
|
char *cmd, *head;
|
ItclClass *cdefn;
|
ItclClass *cdefn;
|
ItclHierIter hier;
|
ItclHierIter hier;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclMemberFunc *mfunc;
|
ItclMemberFunc *mfunc;
|
Tcl_DString buffer;
|
Tcl_DString buffer;
|
CallFrame *framePtr;
|
CallFrame *framePtr;
|
Tcl_Obj *cmdlinePtr, **newobjv;
|
Tcl_Obj *cmdlinePtr, **newobjv;
|
|
|
/*
|
/*
|
* If this command is not invoked within a class namespace,
|
* If this command is not invoked within a class namespace,
|
* signal an error.
|
* signal an error.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"cannot chain functions outside of a class context",
|
"cannot chain functions outside of a class context",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Try to get the command name from the current call frame.
|
* Try to get the command name from the current call frame.
|
* If it cannot be determined, do nothing. Otherwise, trim
|
* If it cannot be determined, do nothing. Otherwise, trim
|
* off any leading path names.
|
* off any leading path names.
|
*/
|
*/
|
framePtr = (CallFrame*) _Tcl_GetCallFrame(interp, 0);
|
framePtr = (CallFrame*) _Tcl_GetCallFrame(interp, 0);
|
if (!framePtr || !framePtr->objv) {
|
if (!framePtr || !framePtr->objv) {
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
cmd = Tcl_GetStringFromObj(framePtr->objv[0], (int*)NULL);
|
cmd = Tcl_GetStringFromObj(framePtr->objv[0], (int*)NULL);
|
Itcl_ParseNamespPath(cmd, &buffer, &head, &cmd);
|
Itcl_ParseNamespPath(cmd, &buffer, &head, &cmd);
|
|
|
/*
|
/*
|
* Look for the specified command in one of the base classes.
|
* Look for the specified command in one of the base classes.
|
* If we have an object context, then start from the most-specific
|
* If we have an object context, then start from the most-specific
|
* class and walk up the hierarchy to the current context. If
|
* class and walk up the hierarchy to the current context. If
|
* there is multiple inheritance, having the entire inheritance
|
* there is multiple inheritance, having the entire inheritance
|
* hierarchy will allow us to jump over to another branch of
|
* hierarchy will allow us to jump over to another branch of
|
* the inheritance tree.
|
* the inheritance tree.
|
*
|
*
|
* If there is no object context, just start with the current
|
* If there is no object context, just start with the current
|
* class context.
|
* class context.
|
*/
|
*/
|
if (contextObj) {
|
if (contextObj) {
|
Itcl_InitHierIter(&hier, contextObj->classDefn);
|
Itcl_InitHierIter(&hier, contextObj->classDefn);
|
while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
if (cdefn == contextClass) {
|
if (cdefn == contextClass) {
|
break;
|
break;
|
}
|
}
|
}
|
}
|
}
|
}
|
else {
|
else {
|
Itcl_InitHierIter(&hier, contextClass);
|
Itcl_InitHierIter(&hier, contextClass);
|
Itcl_AdvanceHierIter(&hier); /* skip the current class */
|
Itcl_AdvanceHierIter(&hier); /* skip the current class */
|
}
|
}
|
|
|
/*
|
/*
|
* Now search up the class hierarchy for the next implementation.
|
* Now search up the class hierarchy for the next implementation.
|
* If found, execute it. Otherwise, do nothing.
|
* If found, execute it. Otherwise, do nothing.
|
*/
|
*/
|
while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
entry = Tcl_FindHashEntry(&cdefn->functions, cmd);
|
entry = Tcl_FindHashEntry(&cdefn->functions, cmd);
|
if (entry) {
|
if (entry) {
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
|
|
/*
|
/*
|
* NOTE: Avoid the usual "virtual" behavior of
|
* NOTE: Avoid the usual "virtual" behavior of
|
* methods by passing the full name as
|
* methods by passing the full name as
|
* the command argument.
|
* the command argument.
|
*/
|
*/
|
cmdlinePtr = Itcl_CreateArgs(interp, mfunc->member->fullname,
|
cmdlinePtr = Itcl_CreateArgs(interp, mfunc->member->fullname,
|
objc-1, objv+1);
|
objc-1, objv+1);
|
|
|
(void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr,
|
(void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr,
|
&objc, &newobjv);
|
&objc, &newobjv);
|
|
|
result = Itcl_EvalArgs(interp, objc, newobjv);
|
result = Itcl_EvalArgs(interp, objc, newobjv);
|
|
|
Tcl_DecrRefCount(cmdlinePtr);
|
Tcl_DecrRefCount(cmdlinePtr);
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
Itcl_DeleteHierIter(&hier);
|
Itcl_DeleteHierIter(&hier);
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_BiInfoClassCmd()
|
* Itcl_BiInfoClassCmd()
|
*
|
*
|
* Returns information regarding the class for an object. This command
|
* Returns information regarding the class for an object. This command
|
* can be invoked with or without an object context:
|
* can be invoked with or without an object context:
|
*
|
*
|
* <objName> info class <= returns most-specific class name
|
* <objName> info class <= returns most-specific class name
|
* info class <= returns active namespace name
|
* info class <= returns active namespace name
|
*
|
*
|
* Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
|
* Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Itcl_BiInfoClassCmd(dummy, interp, objc, objv)
|
Itcl_BiInfoClassCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
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 */
|
{
|
{
|
Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp);
|
Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp);
|
Tcl_Namespace *contextNs = NULL;
|
Tcl_Namespace *contextNs = NULL;
|
|
|
ItclClass *contextClass;
|
ItclClass *contextClass;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
|
|
char *name;
|
char *name;
|
|
|
if (objc != 1) {
|
if (objc != 1) {
|
Tcl_WrongNumArgs(interp, 1, objv, NULL);
|
Tcl_WrongNumArgs(interp, 1, objv, NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If this command is not invoked within a class namespace,
|
* If this command is not invoked within a class namespace,
|
* signal an error.
|
* signal an error.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\nget info like this instead: ",
|
"\nget info like this instead: ",
|
"\n namespace eval className { info ", name, "... }",
|
"\n namespace eval className { info ", name, "... }",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If there is an object context, then return the most-specific
|
* If there is an object context, then return the most-specific
|
* class for the object. Otherwise, return the class namespace
|
* class for the object. Otherwise, return the class namespace
|
* name. Use normal class names when possible.
|
* name. Use normal class names when possible.
|
*/
|
*/
|
if (contextObj) {
|
if (contextObj) {
|
contextNs = contextObj->classDefn->namesp;
|
contextNs = contextObj->classDefn->namesp;
|
}
|
}
|
|
|
if (contextNs->parentPtr == activeNs) {
|
if (contextNs->parentPtr == activeNs) {
|
name = contextNs->name;
|
name = contextNs->name;
|
} else {
|
} else {
|
name = contextNs->fullName;
|
name = contextNs->fullName;
|
}
|
}
|
|
|
Tcl_SetResult(interp, name, TCL_VOLATILE);
|
Tcl_SetResult(interp, name, TCL_VOLATILE);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_BiInfoInheritCmd()
|
* Itcl_BiInfoInheritCmd()
|
*
|
*
|
* Returns the list of base classes for the current class context.
|
* Returns the list of base classes for the current class context.
|
* Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
|
* Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Itcl_BiInfoInheritCmd(dummy, interp, objc, objv)
|
Itcl_BiInfoInheritCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
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 */
|
{
|
{
|
Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp);
|
Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp);
|
|
|
ItclClass *contextClass;
|
ItclClass *contextClass;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
|
|
ItclClass *cdefn;
|
ItclClass *cdefn;
|
Itcl_ListElem *elem;
|
Itcl_ListElem *elem;
|
Tcl_Obj *listPtr, *objPtr;
|
Tcl_Obj *listPtr, *objPtr;
|
|
|
if (objc != 1) {
|
if (objc != 1) {
|
Tcl_WrongNumArgs(interp, 1, objv, NULL);
|
Tcl_WrongNumArgs(interp, 1, objv, NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If this command is not invoked within a class namespace,
|
* If this command is not invoked within a class namespace,
|
* signal an error.
|
* signal an error.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
char *name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
char *name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\nget info like this instead: ",
|
"\nget info like this instead: ",
|
"\n namespace eval className { info ", name, "... }",
|
"\n namespace eval className { info ", name, "... }",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Return the list of base classes.
|
* Return the list of base classes.
|
*/
|
*/
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
|
|
elem = Itcl_FirstListElem(&contextClass->bases);
|
elem = Itcl_FirstListElem(&contextClass->bases);
|
while (elem) {
|
while (elem) {
|
cdefn = (ItclClass*)Itcl_GetListValue(elem);
|
cdefn = (ItclClass*)Itcl_GetListValue(elem);
|
if (cdefn->namesp->parentPtr == activeNs) {
|
if (cdefn->namesp->parentPtr == activeNs) {
|
objPtr = Tcl_NewStringObj(cdefn->namesp->name, -1);
|
objPtr = Tcl_NewStringObj(cdefn->namesp->name, -1);
|
} else {
|
} else {
|
objPtr = Tcl_NewStringObj(cdefn->namesp->fullName, -1);
|
objPtr = Tcl_NewStringObj(cdefn->namesp->fullName, -1);
|
}
|
}
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr);
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr);
|
elem = Itcl_NextListElem(elem);
|
elem = Itcl_NextListElem(elem);
|
}
|
}
|
|
|
Tcl_SetObjResult(interp, listPtr);
|
Tcl_SetObjResult(interp, listPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_BiInfoHeritageCmd()
|
* Itcl_BiInfoHeritageCmd()
|
*
|
*
|
* Returns the entire derivation hierarchy for this class, presented
|
* Returns the entire derivation hierarchy for this class, presented
|
* in the order that classes are traversed for finding data members
|
* in the order that classes are traversed for finding data members
|
* and member functions.
|
* and member functions.
|
*
|
*
|
* Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
|
* Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Itcl_BiInfoHeritageCmd(dummy, interp, objc, objv)
|
Itcl_BiInfoHeritageCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
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 */
|
{
|
{
|
Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp);
|
Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp);
|
|
|
ItclClass *contextClass;
|
ItclClass *contextClass;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
|
|
char *name;
|
char *name;
|
ItclHierIter hier;
|
ItclHierIter hier;
|
Tcl_Obj *listPtr, *objPtr;
|
Tcl_Obj *listPtr, *objPtr;
|
ItclClass *cdefn;
|
ItclClass *cdefn;
|
|
|
if (objc != 1) {
|
if (objc != 1) {
|
Tcl_WrongNumArgs(interp, 1, objv, NULL);
|
Tcl_WrongNumArgs(interp, 1, objv, NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If this command is not invoked within a class namespace,
|
* If this command is not invoked within a class namespace,
|
* signal an error.
|
* signal an error.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\nget info like this instead: ",
|
"\nget info like this instead: ",
|
"\n namespace eval className { info ", name, "... }",
|
"\n namespace eval className { info ", name, "... }",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Traverse through the derivation hierarchy and return
|
* Traverse through the derivation hierarchy and return
|
* base class names.
|
* base class names.
|
*/
|
*/
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
|
|
Itcl_InitHierIter(&hier, contextClass);
|
Itcl_InitHierIter(&hier, contextClass);
|
while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
if (cdefn->namesp->parentPtr == activeNs) {
|
if (cdefn->namesp->parentPtr == activeNs) {
|
objPtr = Tcl_NewStringObj(cdefn->namesp->name, -1);
|
objPtr = Tcl_NewStringObj(cdefn->namesp->name, -1);
|
} else {
|
} else {
|
objPtr = Tcl_NewStringObj(cdefn->namesp->fullName, -1);
|
objPtr = Tcl_NewStringObj(cdefn->namesp->fullName, -1);
|
}
|
}
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr);
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr);
|
}
|
}
|
Itcl_DeleteHierIter(&hier);
|
Itcl_DeleteHierIter(&hier);
|
|
|
Tcl_SetObjResult(interp, listPtr);
|
Tcl_SetObjResult(interp, listPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_BiInfoFunctionCmd()
|
* Itcl_BiInfoFunctionCmd()
|
*
|
*
|
* Returns information regarding class member functions (methods/procs).
|
* Returns information regarding class member functions (methods/procs).
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* info function ?cmdName? ?-protection? ?-type? ?-name? ?-args? ?-body?
|
* info function ?cmdName? ?-protection? ?-type? ?-name? ?-args? ?-body?
|
*
|
*
|
* If the ?cmdName? is not specified, then a list of all known
|
* If the ?cmdName? is not specified, then a list of all known
|
* command members is returned. Otherwise, the information for
|
* command members is returned. Otherwise, the information for
|
* a specific command is returned. Returns a status TCL_OK/TCL_ERROR
|
* a specific command is returned. Returns a status TCL_OK/TCL_ERROR
|
* to indicate success/failure.
|
* to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Itcl_BiInfoFunctionCmd(dummy, interp, objc, objv)
|
Itcl_BiInfoFunctionCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
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 */
|
{
|
{
|
char *cmdName = NULL;
|
char *cmdName = NULL;
|
Tcl_Obj *resultPtr = NULL;
|
Tcl_Obj *resultPtr = NULL;
|
Tcl_Obj *objPtr = NULL;
|
Tcl_Obj *objPtr = NULL;
|
|
|
static char *options[] = {
|
static char *options[] = {
|
"-args", "-body", "-name", "-protection", "-type",
|
"-args", "-body", "-name", "-protection", "-type",
|
(char*)NULL
|
(char*)NULL
|
};
|
};
|
enum BIfIdx {
|
enum BIfIdx {
|
BIfArgsIdx, BIfBodyIdx, BIfNameIdx, BIfProtectIdx, BIfTypeIdx
|
BIfArgsIdx, BIfBodyIdx, BIfNameIdx, BIfProtectIdx, BIfTypeIdx
|
} *iflist, iflistStorage[5];
|
} *iflist, iflistStorage[5];
|
|
|
static enum BIfIdx DefInfoFunction[5] = {
|
static enum BIfIdx DefInfoFunction[5] = {
|
BIfProtectIdx,
|
BIfProtectIdx,
|
BIfTypeIdx,
|
BIfTypeIdx,
|
BIfNameIdx,
|
BIfNameIdx,
|
BIfArgsIdx,
|
BIfArgsIdx,
|
BIfBodyIdx
|
BIfBodyIdx
|
};
|
};
|
|
|
ItclClass *contextClass, *cdefn;
|
ItclClass *contextClass, *cdefn;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
|
|
int i, result;
|
int i, result;
|
char *name, *val;
|
char *name, *val;
|
Tcl_HashSearch place;
|
Tcl_HashSearch place;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclMemberFunc *mfunc;
|
ItclMemberFunc *mfunc;
|
ItclMemberCode *mcode;
|
ItclMemberCode *mcode;
|
ItclHierIter hier;
|
ItclHierIter hier;
|
|
|
/*
|
/*
|
* If this command is not invoked within a class namespace,
|
* If this command is not invoked within a class namespace,
|
* signal an error.
|
* signal an error.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\nget info like this instead: ",
|
"\nget info like this instead: ",
|
"\n namespace eval className { info ", name, "... }",
|
"\n namespace eval className { info ", name, "... }",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Process args:
|
* Process args:
|
* ?cmdName? ?-protection? ?-type? ?-name? ?-args? ?-body?
|
* ?cmdName? ?-protection? ?-type? ?-name? ?-args? ?-body?
|
*/
|
*/
|
objv++; /* skip over command name */
|
objv++; /* skip over command name */
|
objc--;
|
objc--;
|
|
|
if (objc > 0) {
|
if (objc > 0) {
|
cmdName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
cmdName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
objc--; objv++;
|
objc--; objv++;
|
}
|
}
|
|
|
/*
|
/*
|
* Return info for a specific command.
|
* Return info for a specific command.
|
*/
|
*/
|
if (cmdName) {
|
if (cmdName) {
|
entry = Tcl_FindHashEntry(&contextClass->resolveCmds, cmdName);
|
entry = Tcl_FindHashEntry(&contextClass->resolveCmds, cmdName);
|
if (entry == NULL) {
|
if (entry == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\"", cmdName, "\" isn't a member function in class \"",
|
"\"", cmdName, "\" isn't a member function in class \"",
|
contextClass->namesp->fullName, "\"",
|
contextClass->namesp->fullName, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mcode = mfunc->member->code;
|
mcode = mfunc->member->code;
|
|
|
/*
|
/*
|
* By default, return everything.
|
* By default, return everything.
|
*/
|
*/
|
if (objc == 0) {
|
if (objc == 0) {
|
objc = 5;
|
objc = 5;
|
iflist = DefInfoFunction;
|
iflist = DefInfoFunction;
|
}
|
}
|
|
|
/*
|
/*
|
* Otherwise, scan through all remaining flags and
|
* Otherwise, scan through all remaining flags and
|
* figure out what to return.
|
* figure out what to return.
|
*/
|
*/
|
else {
|
else {
|
iflist = &iflistStorage[0];
|
iflist = &iflistStorage[0];
|
for (i=0 ; i < objc; i++) {
|
for (i=0 ; i < objc; i++) {
|
result = Tcl_GetIndexFromObj(interp, objv[i],
|
result = Tcl_GetIndexFromObj(interp, objv[i],
|
options, "option", 0, (int*)(&iflist[i]));
|
options, "option", 0, (int*)(&iflist[i]));
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
if (objc > 1) {
|
if (objc > 1) {
|
resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
}
|
}
|
|
|
for (i=0 ; i < objc; i++) {
|
for (i=0 ; i < objc; i++) {
|
switch (iflist[i]) {
|
switch (iflist[i]) {
|
case BIfArgsIdx:
|
case BIfArgsIdx:
|
if (mcode && mcode->arglist) {
|
if (mcode && mcode->arglist) {
|
objPtr = Itcl_ArgList(mcode->argcount, mcode->arglist);
|
objPtr = Itcl_ArgList(mcode->argcount, mcode->arglist);
|
}
|
}
|
else if ((mfunc->member->flags & ITCL_ARG_SPEC) != 0) {
|
else if ((mfunc->member->flags & ITCL_ARG_SPEC) != 0) {
|
objPtr = Itcl_ArgList(mfunc->argcount, mfunc->arglist);
|
objPtr = Itcl_ArgList(mfunc->argcount, mfunc->arglist);
|
}
|
}
|
else {
|
else {
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
}
|
}
|
break;
|
break;
|
|
|
case BIfBodyIdx:
|
case BIfBodyIdx:
|
if (mcode && mcode->procPtr->bodyPtr) {
|
if (mcode && mcode->procPtr->bodyPtr) {
|
objPtr = mcode->procPtr->bodyPtr;
|
objPtr = mcode->procPtr->bodyPtr;
|
} else {
|
} else {
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
}
|
}
|
break;
|
break;
|
|
|
case BIfNameIdx:
|
case BIfNameIdx:
|
objPtr = Tcl_NewStringObj(mfunc->member->fullname, -1);
|
objPtr = Tcl_NewStringObj(mfunc->member->fullname, -1);
|
break;
|
break;
|
|
|
case BIfProtectIdx:
|
case BIfProtectIdx:
|
val = Itcl_ProtectionStr(mfunc->member->protection);
|
val = Itcl_ProtectionStr(mfunc->member->protection);
|
objPtr = Tcl_NewStringObj(val, -1);
|
objPtr = Tcl_NewStringObj(val, -1);
|
break;
|
break;
|
|
|
case BIfTypeIdx:
|
case BIfTypeIdx:
|
val = ((mfunc->member->flags & ITCL_COMMON) != 0)
|
val = ((mfunc->member->flags & ITCL_COMMON) != 0)
|
? "proc" : "method";
|
? "proc" : "method";
|
objPtr = Tcl_NewStringObj(val, -1);
|
objPtr = Tcl_NewStringObj(val, -1);
|
break;
|
break;
|
}
|
}
|
|
|
if (objc == 1) {
|
if (objc == 1) {
|
resultPtr = objPtr;
|
resultPtr = objPtr;
|
} else {
|
} else {
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr);
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr);
|
}
|
}
|
}
|
}
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
}
|
}
|
|
|
/*
|
/*
|
* Return the list of available commands.
|
* Return the list of available commands.
|
*/
|
*/
|
else {
|
else {
|
resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
|
|
Itcl_InitHierIter(&hier, contextClass);
|
Itcl_InitHierIter(&hier, contextClass);
|
while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
entry = Tcl_FirstHashEntry(&cdefn->functions, &place);
|
entry = Tcl_FirstHashEntry(&cdefn->functions, &place);
|
while (entry) {
|
while (entry) {
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
objPtr = Tcl_NewStringObj(mfunc->member->fullname, -1);
|
objPtr = Tcl_NewStringObj(mfunc->member->fullname, -1);
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr);
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr, objPtr);
|
|
|
entry = Tcl_NextHashEntry(&place);
|
entry = Tcl_NextHashEntry(&place);
|
}
|
}
|
}
|
}
|
Itcl_DeleteHierIter(&hier);
|
Itcl_DeleteHierIter(&hier);
|
|
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_BiInfoVariableCmd()
|
* Itcl_BiInfoVariableCmd()
|
*
|
*
|
* Returns information regarding class data members (variables and
|
* Returns information regarding class data members (variables and
|
* commons). Handles the following syntax:
|
* commons). Handles the following syntax:
|
*
|
*
|
* info variable ?varName? ?-protection? ?-type? ?-name?
|
* info variable ?varName? ?-protection? ?-type? ?-name?
|
* ?-init? ?-config? ?-value?
|
* ?-init? ?-config? ?-value?
|
*
|
*
|
* If the ?varName? is not specified, then a list of all known
|
* If the ?varName? is not specified, then a list of all known
|
* data members is returned. Otherwise, the information for a
|
* data members is returned. Otherwise, the information for a
|
* specific member is returned. Returns a status TCL_OK/TCL_ERROR
|
* specific member is returned. Returns a status TCL_OK/TCL_ERROR
|
* to indicate success/failure.
|
* to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Itcl_BiInfoVariableCmd(dummy, interp, objc, objv)
|
Itcl_BiInfoVariableCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
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 */
|
{
|
{
|
char *varName = NULL;
|
char *varName = NULL;
|
Tcl_Obj *resultPtr = NULL;
|
Tcl_Obj *resultPtr = NULL;
|
Tcl_Obj *objPtr = NULL;
|
Tcl_Obj *objPtr = NULL;
|
|
|
static char *options[] = {
|
static char *options[] = {
|
"-config", "-init", "-name", "-protection", "-type",
|
"-config", "-init", "-name", "-protection", "-type",
|
"-value", (char*)NULL
|
"-value", (char*)NULL
|
};
|
};
|
enum BIvIdx {
|
enum BIvIdx {
|
BIvConfigIdx, BIvInitIdx, BIvNameIdx, BIvProtectIdx,
|
BIvConfigIdx, BIvInitIdx, BIvNameIdx, BIvProtectIdx,
|
BIvTypeIdx, BIvValueIdx
|
BIvTypeIdx, BIvValueIdx
|
} *ivlist, ivlistStorage[6];
|
} *ivlist, ivlistStorage[6];
|
|
|
static enum BIvIdx DefInfoVariable[5] = {
|
static enum BIvIdx DefInfoVariable[5] = {
|
BIvProtectIdx,
|
BIvProtectIdx,
|
BIvTypeIdx,
|
BIvTypeIdx,
|
BIvNameIdx,
|
BIvNameIdx,
|
BIvInitIdx,
|
BIvInitIdx,
|
BIvValueIdx
|
BIvValueIdx
|
};
|
};
|
|
|
static enum BIvIdx DefInfoPubVariable[6] = {
|
static enum BIvIdx DefInfoPubVariable[6] = {
|
BIvProtectIdx,
|
BIvProtectIdx,
|
BIvTypeIdx,
|
BIvTypeIdx,
|
BIvNameIdx,
|
BIvNameIdx,
|
BIvInitIdx,
|
BIvInitIdx,
|
BIvConfigIdx,
|
BIvConfigIdx,
|
BIvValueIdx
|
BIvValueIdx
|
};
|
};
|
|
|
ItclClass *contextClass;
|
ItclClass *contextClass;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
|
|
int i, result;
|
int i, result;
|
char *val, *name;
|
char *val, *name;
|
ItclClass *cdefn;
|
ItclClass *cdefn;
|
Tcl_HashSearch place;
|
Tcl_HashSearch place;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclVarDefn *vdefn;
|
ItclVarDefn *vdefn;
|
ItclVarLookup *vlookup;
|
ItclVarLookup *vlookup;
|
ItclMember *member;
|
ItclMember *member;
|
ItclHierIter hier;
|
ItclHierIter hier;
|
|
|
/*
|
/*
|
* If this command is not invoked within a class namespace,
|
* If this command is not invoked within a class namespace,
|
* signal an error.
|
* signal an error.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\nget info like this instead: ",
|
"\nget info like this instead: ",
|
"\n namespace eval className { info ", name, "... }",
|
"\n namespace eval className { info ", name, "... }",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Process args:
|
* Process args:
|
* ?varName? ?-protection? ?-type? ?-name? ?-init? ?-config? ?-value?
|
* ?varName? ?-protection? ?-type? ?-name? ?-init? ?-config? ?-value?
|
*/
|
*/
|
objv++; /* skip over command name */
|
objv++; /* skip over command name */
|
objc--;
|
objc--;
|
|
|
if (objc > 0) {
|
if (objc > 0) {
|
varName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
varName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
objc--; objv++;
|
objc--; objv++;
|
}
|
}
|
|
|
/*
|
/*
|
* Return info for a specific variable.
|
* Return info for a specific variable.
|
*/
|
*/
|
if (varName) {
|
if (varName) {
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, varName);
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, varName);
|
if (entry == NULL) {
|
if (entry == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\"", varName, "\" isn't a variable in class \"",
|
"\"", varName, "\" isn't a variable in class \"",
|
contextClass->namesp->fullName, "\"",
|
contextClass->namesp->fullName, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
member = vlookup->vdefn->member;
|
member = vlookup->vdefn->member;
|
|
|
/*
|
/*
|
* By default, return everything.
|
* By default, return everything.
|
*/
|
*/
|
if (objc == 0) {
|
if (objc == 0) {
|
if (member->protection == ITCL_PUBLIC &&
|
if (member->protection == ITCL_PUBLIC &&
|
((member->flags & ITCL_COMMON) == 0)) {
|
((member->flags & ITCL_COMMON) == 0)) {
|
ivlist = DefInfoPubVariable;
|
ivlist = DefInfoPubVariable;
|
objc = 6;
|
objc = 6;
|
} else {
|
} else {
|
ivlist = DefInfoVariable;
|
ivlist = DefInfoVariable;
|
objc = 5;
|
objc = 5;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Otherwise, scan through all remaining flags and
|
* Otherwise, scan through all remaining flags and
|
* figure out what to return.
|
* figure out what to return.
|
*/
|
*/
|
else {
|
else {
|
ivlist = &ivlistStorage[0];
|
ivlist = &ivlistStorage[0];
|
for (i=0 ; i < objc; i++) {
|
for (i=0 ; i < objc; i++) {
|
result = Tcl_GetIndexFromObj(interp, objv[i],
|
result = Tcl_GetIndexFromObj(interp, objv[i],
|
options, "option", 0, (int*)(&ivlist[i]));
|
options, "option", 0, (int*)(&ivlist[i]));
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
if (objc > 1) {
|
if (objc > 1) {
|
resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
}
|
}
|
|
|
for (i=0 ; i < objc; i++) {
|
for (i=0 ; i < objc; i++) {
|
switch (ivlist[i]) {
|
switch (ivlist[i]) {
|
case BIvConfigIdx:
|
case BIvConfigIdx:
|
if (member->code && member->code->procPtr->bodyPtr) {
|
if (member->code && member->code->procPtr->bodyPtr) {
|
objPtr = member->code->procPtr->bodyPtr;
|
objPtr = member->code->procPtr->bodyPtr;
|
} else {
|
} else {
|
objPtr = Tcl_NewStringObj("", -1);
|
objPtr = Tcl_NewStringObj("", -1);
|
}
|
}
|
break;
|
break;
|
|
|
case BIvInitIdx:
|
case BIvInitIdx:
|
/*
|
/*
|
* If this is the built-in "this" variable, then
|
* If this is the built-in "this" variable, then
|
* report the object name as its initialization string.
|
* report the object name as its initialization string.
|
*/
|
*/
|
if ((member->flags & ITCL_THIS_VAR) != 0) {
|
if ((member->flags & ITCL_THIS_VAR) != 0) {
|
if (contextObj && contextObj->accessCmd) {
|
if (contextObj && contextObj->accessCmd) {
|
objPtr = Tcl_NewStringObj((char*)NULL, 0);
|
objPtr = Tcl_NewStringObj((char*)NULL, 0);
|
Tcl_GetCommandFullName(
|
Tcl_GetCommandFullName(
|
contextObj->classDefn->interp,
|
contextObj->classDefn->interp,
|
contextObj->accessCmd, objPtr);
|
contextObj->accessCmd, objPtr);
|
} else {
|
} else {
|
objPtr = Tcl_NewStringObj("<objectName>", -1);
|
objPtr = Tcl_NewStringObj("<objectName>", -1);
|
}
|
}
|
}
|
}
|
else if (vlookup->vdefn->init) {
|
else if (vlookup->vdefn->init) {
|
objPtr = Tcl_NewStringObj(vlookup->vdefn->init, -1);
|
objPtr = Tcl_NewStringObj(vlookup->vdefn->init, -1);
|
}
|
}
|
else {
|
else {
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
}
|
}
|
break;
|
break;
|
|
|
case BIvNameIdx:
|
case BIvNameIdx:
|
objPtr = Tcl_NewStringObj(member->fullname, -1);
|
objPtr = Tcl_NewStringObj(member->fullname, -1);
|
break;
|
break;
|
|
|
case BIvProtectIdx:
|
case BIvProtectIdx:
|
val = Itcl_ProtectionStr(member->protection);
|
val = Itcl_ProtectionStr(member->protection);
|
objPtr = Tcl_NewStringObj(val, -1);
|
objPtr = Tcl_NewStringObj(val, -1);
|
break;
|
break;
|
|
|
case BIvTypeIdx:
|
case BIvTypeIdx:
|
val = ((member->flags & ITCL_COMMON) != 0)
|
val = ((member->flags & ITCL_COMMON) != 0)
|
? "common" : "variable";
|
? "common" : "variable";
|
objPtr = Tcl_NewStringObj(val, -1);
|
objPtr = Tcl_NewStringObj(val, -1);
|
break;
|
break;
|
|
|
case BIvValueIdx:
|
case BIvValueIdx:
|
if ((member->flags & ITCL_COMMON) != 0) {
|
if ((member->flags & ITCL_COMMON) != 0) {
|
val = Itcl_GetCommonVar(interp, member->fullname,
|
val = Itcl_GetCommonVar(interp, member->fullname,
|
member->classDefn);
|
member->classDefn);
|
}
|
}
|
else if (contextObj == NULL) {
|
else if (contextObj == NULL) {
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendResult(interp,
|
Tcl_AppendResult(interp,
|
"cannot access object-specific info ",
|
"cannot access object-specific info ",
|
"without an object context",
|
"without an object context",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
else {
|
else {
|
val = Itcl_GetInstanceVar(interp, member->fullname,
|
val = Itcl_GetInstanceVar(interp, member->fullname,
|
contextObj, member->classDefn);
|
contextObj, member->classDefn);
|
}
|
}
|
|
|
if (val == NULL) {
|
if (val == NULL) {
|
val = "<undefined>";
|
val = "<undefined>";
|
}
|
}
|
objPtr = Tcl_NewStringObj(val, -1);
|
objPtr = Tcl_NewStringObj(val, -1);
|
break;
|
break;
|
}
|
}
|
|
|
if (objc == 1) {
|
if (objc == 1) {
|
resultPtr = objPtr;
|
resultPtr = objPtr;
|
} else {
|
} else {
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr,
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr,
|
objPtr);
|
objPtr);
|
}
|
}
|
}
|
}
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
}
|
}
|
|
|
/*
|
/*
|
* Return the list of available variables. Report the built-in
|
* Return the list of available variables. Report the built-in
|
* "this" variable only once, for the most-specific class.
|
* "this" variable only once, for the most-specific class.
|
*/
|
*/
|
else {
|
else {
|
resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
|
|
Itcl_InitHierIter(&hier, contextClass);
|
Itcl_InitHierIter(&hier, contextClass);
|
while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
entry = Tcl_FirstHashEntry(&cdefn->variables, &place);
|
entry = Tcl_FirstHashEntry(&cdefn->variables, &place);
|
while (entry) {
|
while (entry) {
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
if ((vdefn->member->flags & ITCL_THIS_VAR) != 0) {
|
if ((vdefn->member->flags & ITCL_THIS_VAR) != 0) {
|
if (cdefn == contextClass) {
|
if (cdefn == contextClass) {
|
objPtr = Tcl_NewStringObj(vdefn->member->fullname, -1);
|
objPtr = Tcl_NewStringObj(vdefn->member->fullname, -1);
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL,
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL,
|
resultPtr, objPtr);
|
resultPtr, objPtr);
|
}
|
}
|
}
|
}
|
else {
|
else {
|
objPtr = Tcl_NewStringObj(vdefn->member->fullname, -1);
|
objPtr = Tcl_NewStringObj(vdefn->member->fullname, -1);
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL,
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL,
|
resultPtr, objPtr);
|
resultPtr, objPtr);
|
}
|
}
|
entry = Tcl_NextHashEntry(&place);
|
entry = Tcl_NextHashEntry(&place);
|
}
|
}
|
}
|
}
|
Itcl_DeleteHierIter(&hier);
|
Itcl_DeleteHierIter(&hier);
|
|
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_BiInfoBodyCmd()
|
* Itcl_BiInfoBodyCmd()
|
*
|
*
|
* Handles the usual "info body" request, returning the body for a
|
* Handles the usual "info body" request, returning the body for a
|
* specific proc. Included here for backward compatibility, since
|
* specific proc. Included here for backward compatibility, since
|
* otherwise Tcl would complain that class procs are not real "procs".
|
* otherwise Tcl would complain that class procs are not real "procs".
|
* Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
|
* Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Itcl_BiInfoBodyCmd(dummy, interp, objc, objv)
|
Itcl_BiInfoBodyCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
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 */
|
{
|
{
|
char *name;
|
char *name;
|
ItclClass *contextClass;
|
ItclClass *contextClass;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
ItclMemberFunc *mfunc;
|
ItclMemberFunc *mfunc;
|
ItclMemberCode *mcode;
|
ItclMemberCode *mcode;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
Tcl_Obj *objPtr;
|
Tcl_Obj *objPtr;
|
|
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 1, objv, "function");
|
Tcl_WrongNumArgs(interp, 1, objv, "function");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If this command is not invoked within a class namespace,
|
* If this command is not invoked within a class namespace,
|
* then treat the procedure name as a normal Tcl procedure.
|
* then treat the procedure name as a normal Tcl procedure.
|
*/
|
*/
|
if (!Itcl_IsClassNamespace(Tcl_GetCurrentNamespace(interp))) {
|
if (!Itcl_IsClassNamespace(Tcl_GetCurrentNamespace(interp))) {
|
Proc *procPtr;
|
Proc *procPtr;
|
|
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
procPtr = TclFindProc((Interp*)interp, name);
|
procPtr = TclFindProc((Interp*)interp, name);
|
if (procPtr == NULL) {
|
if (procPtr == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\"", name, "\" isn't a procedure",
|
"\"", name, "\" isn't a procedure",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Tcl_SetObjResult(interp, procPtr->bodyPtr);
|
Tcl_SetObjResult(interp, procPtr->bodyPtr);
|
}
|
}
|
|
|
/*
|
/*
|
* Otherwise, treat the name as a class method/proc.
|
* Otherwise, treat the name as a class method/proc.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\nget info like this instead: ",
|
"\nget info like this instead: ",
|
"\n namespace eval className { info ", name, "... }",
|
"\n namespace eval className { info ", name, "... }",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
entry = Tcl_FindHashEntry(&contextClass->resolveCmds, name);
|
entry = Tcl_FindHashEntry(&contextClass->resolveCmds, name);
|
if (entry == NULL) {
|
if (entry == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\"", name, "\" isn't a procedure",
|
"\"", name, "\" isn't a procedure",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mcode = mfunc->member->code;
|
mcode = mfunc->member->code;
|
|
|
/*
|
/*
|
* Return a string describing the implementation.
|
* Return a string describing the implementation.
|
*/
|
*/
|
if (mcode && mcode->procPtr->bodyPtr) {
|
if (mcode && mcode->procPtr->bodyPtr) {
|
objPtr = mcode->procPtr->bodyPtr;
|
objPtr = mcode->procPtr->bodyPtr;
|
} else {
|
} else {
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
}
|
}
|
Tcl_SetObjResult(interp, objPtr);
|
Tcl_SetObjResult(interp, objPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_BiInfoArgsCmd()
|
* Itcl_BiInfoArgsCmd()
|
*
|
*
|
* Handles the usual "info args" request, returning the argument list
|
* Handles the usual "info args" request, returning the argument list
|
* for a specific proc. Included here for backward compatibility, since
|
* for a specific proc. Included here for backward compatibility, since
|
* otherwise Tcl would complain that class procs are not real "procs".
|
* otherwise Tcl would complain that class procs are not real "procs".
|
* Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
|
* Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Itcl_BiInfoArgsCmd(dummy, interp, objc, objv)
|
Itcl_BiInfoArgsCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
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 */
|
{
|
{
|
char *name;
|
char *name;
|
ItclClass *contextClass;
|
ItclClass *contextClass;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
ItclMemberFunc *mfunc;
|
ItclMemberFunc *mfunc;
|
ItclMemberCode *mcode;
|
ItclMemberCode *mcode;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
Tcl_Obj *objPtr;
|
Tcl_Obj *objPtr;
|
|
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 1, objv, "function");
|
Tcl_WrongNumArgs(interp, 1, objv, "function");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
|
|
/*
|
/*
|
* If this command is not invoked within a class namespace,
|
* If this command is not invoked within a class namespace,
|
* then treat the procedure name as a normal Tcl procedure.
|
* then treat the procedure name as a normal Tcl procedure.
|
*/
|
*/
|
if (!Itcl_IsClassNamespace(Tcl_GetCurrentNamespace(interp))) {
|
if (!Itcl_IsClassNamespace(Tcl_GetCurrentNamespace(interp))) {
|
Proc *procPtr;
|
Proc *procPtr;
|
CompiledLocal *localPtr;
|
CompiledLocal *localPtr;
|
|
|
procPtr = TclFindProc((Interp*)interp, name);
|
procPtr = TclFindProc((Interp*)interp, name);
|
if (procPtr == NULL) {
|
if (procPtr == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\"", name, "\" isn't a procedure",
|
"\"", name, "\" isn't a procedure",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
objPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
objPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
|
for (localPtr = procPtr->firstLocalPtr;
|
for (localPtr = procPtr->firstLocalPtr;
|
localPtr != NULL;
|
localPtr != NULL;
|
localPtr = localPtr->nextPtr) {
|
localPtr = localPtr->nextPtr) {
|
if (TclIsVarArgument(localPtr)) {
|
if (TclIsVarArgument(localPtr)) {
|
Tcl_ListObjAppendElement(interp, objPtr,
|
Tcl_ListObjAppendElement(interp, objPtr,
|
Tcl_NewStringObj(localPtr->name, -1));
|
Tcl_NewStringObj(localPtr->name, -1));
|
}
|
}
|
}
|
}
|
|
|
Tcl_SetObjResult(interp, objPtr);
|
Tcl_SetObjResult(interp, objPtr);
|
}
|
}
|
|
|
/*
|
/*
|
* Otherwise, treat the name as a class method/proc.
|
* Otherwise, treat the name as a class method/proc.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\nget info like this instead: ",
|
"\nget info like this instead: ",
|
"\n namespace eval className { info ", name, "... }",
|
"\n namespace eval className { info ", name, "... }",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
entry = Tcl_FindHashEntry(&contextClass->resolveCmds, name);
|
entry = Tcl_FindHashEntry(&contextClass->resolveCmds, name);
|
if (entry == NULL) {
|
if (entry == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\"", name, "\" isn't a procedure",
|
"\"", name, "\" isn't a procedure",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mcode = mfunc->member->code;
|
mcode = mfunc->member->code;
|
|
|
/*
|
/*
|
* Return a string describing the argument list.
|
* Return a string describing the argument list.
|
*/
|
*/
|
if (mcode && mcode->arglist != NULL) {
|
if (mcode && mcode->arglist != NULL) {
|
objPtr = Itcl_ArgList(mcode->argcount, mcode->arglist);
|
objPtr = Itcl_ArgList(mcode->argcount, mcode->arglist);
|
}
|
}
|
else if ((mfunc->member->flags & ITCL_ARG_SPEC) != 0) {
|
else if ((mfunc->member->flags & ITCL_ARG_SPEC) != 0) {
|
objPtr = Itcl_ArgList(mfunc->argcount, mfunc->arglist);
|
objPtr = Itcl_ArgList(mfunc->argcount, mfunc->arglist);
|
}
|
}
|
else {
|
else {
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
objPtr = Tcl_NewStringObj("<undefined>", -1);
|
}
|
}
|
Tcl_SetObjResult(interp, objPtr);
|
Tcl_SetObjResult(interp, objPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_DefaultInfoCmd()
|
* Itcl_DefaultInfoCmd()
|
*
|
*
|
* Handles any unknown options for the "itcl::builtin::info" command
|
* Handles any unknown options for the "itcl::builtin::info" command
|
* by passing requests on to the usual "::info" command. If the
|
* by passing requests on to the usual "::info" command. If the
|
* option is recognized, then it is handled. Otherwise, if it is
|
* option is recognized, then it is handled. Otherwise, if it is
|
* still unknown, then an error message is returned with the list
|
* still unknown, then an error message is returned with the list
|
* of possible options.
|
* of possible options.
|
*
|
*
|
* Returns TCL_OK/TCL_ERROR to indicate success/failure.
|
* Returns TCL_OK/TCL_ERROR to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Itcl_DefaultInfoCmd(dummy, interp, objc, objv)
|
Itcl_DefaultInfoCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
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 result;
|
int result;
|
char *name;
|
char *name;
|
Tcl_Command cmd;
|
Tcl_Command cmd;
|
Command *cmdPtr;
|
Command *cmdPtr;
|
Tcl_Obj *resultPtr;
|
Tcl_Obj *resultPtr;
|
|
|
/*
|
/*
|
* Look for the usual "::info" command, and use it to
|
* Look for the usual "::info" command, and use it to
|
* evaluate the unknown option.
|
* evaluate the unknown option.
|
*/
|
*/
|
cmd = Tcl_FindCommand(interp, "::info", (Tcl_Namespace*)NULL, 0);
|
cmd = Tcl_FindCommand(interp, "::info", (Tcl_Namespace*)NULL, 0);
|
if (cmd == NULL) {
|
if (cmd == NULL) {
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
|
|
resultPtr = Tcl_GetObjResult(interp);
|
resultPtr = Tcl_GetObjResult(interp);
|
Tcl_AppendStringsToObj(resultPtr,
|
Tcl_AppendStringsToObj(resultPtr,
|
"bad option \"", name, "\" should be one of...\n",
|
"bad option \"", name, "\" should be one of...\n",
|
(char*)NULL);
|
(char*)NULL);
|
Itcl_GetEnsembleUsageForObj(interp, objv[0], resultPtr);
|
Itcl_GetEnsembleUsageForObj(interp, objv[0], resultPtr);
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
cmdPtr = (Command*)cmd;
|
cmdPtr = (Command*)cmd;
|
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
|
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
|
|
|
/*
|
/*
|
* If the option was not recognized by the usual "info" command,
|
* If the option was not recognized by the usual "info" command,
|
* then we got a "bad option" error message. Add the options
|
* then we got a "bad option" error message. Add the options
|
* for the current ensemble to the error message.
|
* for the current ensemble to the error message.
|
*/
|
*/
|
if (result != TCL_OK && strncmp(interp->result,"bad option",10) == 0) {
|
if (result != TCL_OK && strncmp(interp->result,"bad option",10) == 0) {
|
resultPtr = Tcl_GetObjResult(interp);
|
resultPtr = Tcl_GetObjResult(interp);
|
Tcl_AppendToObj(resultPtr, "\nor", -1);
|
Tcl_AppendToObj(resultPtr, "\nor", -1);
|
Itcl_GetEnsembleUsageForObj(interp, objv[0], resultPtr);
|
Itcl_GetEnsembleUsageForObj(interp, objv[0], resultPtr);
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|