/* $Id: tixMethod.c,v 1.1.1.1 2000/05/17 11:08:42 idiscovery Exp $ */
/*
* tixMethod.c --
*
* Handle the calling of class methods.
*
* Implements the basic OOP class mechanism for the Tix Intrinsics.
*
* Copyright (c) 1996, Expert Interface Technologies
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
*/
/* ToDo:
*
* 1) Tix_CallMethod() needs to be re-written
*
*/
#include <tclInt.h>
#include <tk.h>
#include <tixPort.h>
#include <tixInt.h>
#include <tixItcl.h>
#define GetMethodTable(interp) (_TixGetHashTable(interp, "tixMethodTab", MethodTableDeleteProc))
static int Tix_CallMethodByContext _ANSI_ARGS_((
Tcl_Interp * interp, char * context,
char * widRec, char * method, int argc,
char ** argv));
static void Tix_RestoreContext _ANSI_ARGS_((
Tcl_Interp * interp, char * widRec,
char * oldContext));
static void Tix_SetContext _ANSI_ARGS_((
Tcl_Interp * interp, char * widRec,
char * newContext));
static char * Tix_SaveContext _ANSI_ARGS_((Tcl_Interp * interp,
char * widRec));
static void MethodTableDeleteProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp));
/*
*
* argv[1] = widget record
* argv[2] = method
* argv[3+] = args
*
*/
TIX_DEFINE_CMD(Tix_CallMethodCmd)
{
char * context;
char * newContext;
char * widRec = argv[1];
char * method = argv[2];
int result;
if (argc<3) {
return Tix_ArgcError(interp, argc, argv, 1, "w method ...");
}
if ((context = GET_RECORD(interp, widRec, "className")) == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "invalid object reference \"", widRec,
"\"", (char*)NULL);
return TCL_ERROR;
}
newContext = Tix_FindMethod(interp, context, method);
if (newContext) {
result = Tix_CallMethodByContext(interp, newContext, widRec, method,
argc-3, argv+3);
} else {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "cannot call method \"", method,
"\" for context \"", context, "\".", (char*)NULL);
Tcl_SetVar(interp, "errorInfo", interp->result, TCL_GLOBAL_ONLY);
result = TCL_ERROR;
}
return result;
}
/*
*
* argv[1] = widget record
* argv[2] = method
* argv[3+] = args
*
*/
TIX_DEFINE_CMD(Tix_ChainMethodCmd)
{
char * context;
char * superClassContext;
char * newContext;
char * widRec = argv[1];
char * method = argv[2];
int result;
if (argc<3) {
return Tix_ArgcError(interp, argc, argv, 1, "w method ...");
}
if ((context = Tix_GetContext(interp, widRec)) == NULL) {
return TCL_ERROR;
}
if (Tix_SuperClass(interp, context, &superClassContext) != TCL_OK) {
return TCL_ERROR;
}
if (superClassContext == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "no superclass exists for context \"",
context, "\".", (char*)NULL);
result = TCL_ERROR;
goto done;
}
newContext = Tix_FindMethod(interp, superClassContext, method);
if (newContext) {
result = Tix_CallMethodByContext(interp, newContext, widRec,
method, argc-3, argv+3);
} else {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "cannot chain method \"", method,
"\" for context \"", context, "\".", (char*)NULL);
Tcl_SetVar(interp, "errorInfo", interp->result, TCL_GLOBAL_ONLY);
result = TCL_ERROR;
goto done;
}
done:
return result;
}
/*
*
* argv[1] = widget record
* argv[2] = class (context)
* argv[3] = method
*
*/
TIX_DEFINE_CMD(Tix_GetMethodCmd)
{
char * newContext;
char * context= argv[2];
char * method = argv[3];
char * cmdName;
if (argc!=4) {
return Tix_ArgcError(interp, argc, argv, 1, "w class method");
}
newContext = Tix_FindMethod(interp, context, method);
if (newContext) {
cmdName = Tix_GetMethodFullName(newContext, method);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, cmdName, NULL);
ckfree(cmdName);
} else {
Tcl_SetResult(interp, "", TCL_STATIC);
}
return TCL_OK;
}
/*----------------------------------------------------------------------
* Tix_FindMethod
*
* Starting with class "context", find the first class that defines
* the method. This class must be the same as the class "context" or
* a superclass of the class "context".
*/
char *
Tix_FindMethod(interp, context, method)
Tcl_Interp * interp;
char * context;
char * method;
{
char * theContext;
int isNew;
char * key;
Tcl_HashEntry *hashPtr;
key = Tix_GetMethodFullName(context, method);
hashPtr = Tcl_CreateHashEntry(GetMethodTable(interp), key, &isNew);
ckfree(key);
if (!isNew) {
theContext = (char *) Tcl_GetHashValue(hashPtr);
} else {
for (theContext = context; theContext;) {
if (Tix_ExistMethod(interp, theContext, method)) {
break;
}
/* Go to its superclass and see if it has the method */
if (Tix_SuperClass(interp, theContext, &theContext) != TCL_OK) {
return NULL;
}
if (theContext == NULL) {
return NULL;
}
}
if (theContext != NULL) {
/*
* theContext may point to the stack. We have to put it
* in some more permanent place.
*/
theContext = tixStrDup(theContext);
}
Tcl_SetHashValue(hashPtr, (char*)theContext);
}
return theContext;
}
/*----------------------------------------------------------------------
* Tix_CallMethod
*
* Starting with class "context", find the first class that defines
* the method. Call this method.
*/
int Tix_CallMethod(interp, context, widRec, method, argc, argv)
Tcl_Interp * interp;
char * context;
char * widRec;
char * method;
int argc;
char ** argv;
{
char * targetContext;
targetContext = Tix_FindMethod(interp, context, method);
if (targetContext != NULL) {
return Tix_CallMethodByContext(interp, targetContext, widRec, method,
argc, argv);
}
else {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "cannot call method \"", method,
"\" for context \"", context, "\".", (char*)NULL);
Tcl_SetVar(interp, "errorInfo", interp->result, TCL_GLOBAL_ONLY);
return TCL_ERROR;
}
}
/*----------------------------------------------------------------------
* Tix_FindConfigSpec
*
* Starting with class "classRec", find the first class that defines
* the option flag. This class must be the same as the class "classRec" or
* a superclass of the class "classRec".
*/
/* save the old context: calling a method of a superclass will
* change the context of a widget.
*/
static char * Tix_SaveContext(interp, widRec)
Tcl_Interp * interp;
char * widRec;
{
char * context;
if ((context = GET_RECORD(interp, widRec, "context")) == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "invalid object reference \"", widRec,
"\"", (char*)NULL);
return NULL;
}
else {
return tixStrDup(context);
}
}
static void Tix_RestoreContext(interp, widRec, oldContext)
Tcl_Interp * interp;
char * widRec;
char * oldContext;
{
SET_RECORD(interp, widRec, "context", oldContext);
ckfree(oldContext);
}
static void Tix_SetContext(interp, widRec, newContext)
Tcl_Interp * interp;
char * widRec;
char * newContext;
{
SET_RECORD(interp, widRec, "context", newContext);
}
char * Tix_GetContext(interp, widRec)
Tcl_Interp * interp;
char * widRec;
{
char * context;
if ((context = GET_RECORD(interp, widRec, "context")) == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "invalid object reference \"", widRec,
"\"", (char*)NULL);
return NULL;
} else {
return context;
}
}
int Tix_SuperClass(interp, class, superClass_ret)
Tcl_Interp * interp;
char * class;
char ** superClass_ret;
{
char * superclass;
if ((superclass = GET_RECORD(interp, class, "superClass")) == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "invalid class \"", class,
"\"; ", (char*)NULL);
return TCL_ERROR;
}
if (strlen(superclass) == 0) {
*superClass_ret = (char*) NULL;
} else {
*superClass_ret = superclass;
}
return TCL_OK;
}
char * Tix_GetMethodFullName(context, method)
char * context;
char * method;
{
char * buff;
int max;
int conLen;
conLen = strlen(context);
max = conLen + strlen(method) + 3;
buff = (char*)ckalloc(max * sizeof(char));
strcpy(buff, context);
strcpy(buff+conLen, ":");
strcpy(buff+conLen+1, method);
return buff;
}
#undef ITCL_2
#if !defined(ITCL_2) && !defined(TK_8_0_OR_LATER)
#define Tix_GetCommandInfo Tcl_GetCommandInfo
#else
/*
*----------------------------------------------------------------------
*
* Tix_GetCommandInfo --
*
* Returns various information about a Tcl command. Modified from
* Tcl_GetCommandInfo to work with ITcl 2.0. Always work in the global
* name space.
*
* Results:
* If cmdName exists in interp, then *infoPtr is modified to
* hold information about cmdName and 1 is returned. If the
* command doesn't exist then 0 is returned and *infoPtr isn't
* modified.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int Tix_GetCommandInfo(interp, cmdName, infoPtr)
Tcl_Interp *interp;
char *cmdName;
Tcl_CmdInfo *infoPtr;
{
register Interp *iPtr = (Interp *) interp;
int result;
DECLARE_ITCL_NAMESP(nameSp, interp);
result = TixItclSetGlobalNameSp(&nameSp, interp);
if (result != 0) {
result = Tcl_GetCommandInfo(interp, cmdName, infoPtr);
}
TixItclRestoreGlobalNameSp(&nameSp, interp);
return result;
}
#endif
int Tix_ExistMethod(interp, context, method)
Tcl_Interp * interp;
char * context;
char * method;
{
char * cmdName;
Tcl_CmdInfo dummy;
int exist;
cmdName = Tix_GetMethodFullName(context, method);
exist = Tix_GetCommandInfo(interp, cmdName, &dummy);
if (!exist) {
if (Tix_GlobalVarEval(interp, "auto_load ", cmdName,
(char*)NULL)!= TCL_OK) {
goto done;
}
if (strcmp(interp->result, "1") == 0) {
exist = 1;
}
}
done:
ckfree(cmdName);
Tcl_SetResult(interp, NULL, TCL_STATIC);
return exist;
}
/* %% There is a dirty version that uses the old argv, without having to
* malloc a new argv.
*/
static int Tix_CallMethodByContext(interp, context, widRec, method, argc, argv)
Tcl_Interp * interp;
char * context;
char * widRec;
char * method;
int argc;
char ** argv;
{
char * cmdName;
int i, result;
char * oldContext;
char ** newArgv;
if ((oldContext = Tix_SaveContext(interp, widRec)) == NULL) {
return TCL_ERROR;
}
Tix_SetContext(interp, widRec, context);
cmdName = Tix_GetMethodFullName(context, method);
/* Create a new argv list */
newArgv = (char**)ckalloc((argc+2)*sizeof(char*));
newArgv[0] = cmdName;
newArgv[1] = widRec;
for (i=0; i< argc; i++) {
newArgv[i+2] = argv[i];
}
result = Tix_EvalArgv(interp, argc+2, newArgv);
Tix_RestoreContext(interp, widRec, oldContext);
ckfree((char*)newArgv);
ckfree(cmdName);
return result;
}
#ifndef ITCL_2
#define Tix_GlobalEvalArgv(interp, cmdInfoPtr, argc, argv) \
(*(cmdInfoPtr)->proc)((cmdInfoPtr)->clientData, interp, argc, argv)
#else
EXTERN int Tix_GlobalEvalArgv _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_CmdInfo * cmdInfoPtr, int argc));
int
Tix_GlobalEvalArgv(interp, cmdInfoPtr, argc, argv)
Tcl_Interp * interp;
Tcl_CmdInfo * cmdInfoPtr;
int argc;
char ** argv;
{
register Interp *iPtr = (Interp *) interp;
int result;
CallFrame *savedVarFramePtr;
Itcl_ActiveNamespace nsToken;
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = NULL;
nsToken = Itcl_ActivateNamesp(interp, (Itcl_Namespace)iPtr->globalNs);
if (nsToken == NULL) {
result = TCL_ERROR;
}
else {
result = (*cmdInfoPtr->proc)(cmdInfoPtr->clientData,interp,argc,argv);
Itcl_DeactivateNamesp(interp, nsToken);
}
iPtr->varFramePtr = savedVarFramePtr;
return result;
}
#endif /* ITCL_2 */
int Tix_EvalArgv(interp, argc, argv)
Tcl_Interp * interp;
int argc;
char ** argv;
{
Tcl_CmdInfo cmdInfo;
if (!Tix_GetCommandInfo(interp, argv[0], &cmdInfo)) {
char * cmdArgv[2];
/*
* This comand is not defined yet -- looks like we have to auto-load it
*/
if (!Tix_GetCommandInfo(interp, "auto_load", &cmdInfo)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "cannot execute command \"auto_load\"",
NULL);
return TCL_ERROR;
}
cmdArgv[0] = "auto_load";
cmdArgv[1] = argv[0];
if ((*cmdInfo.proc)(cmdInfo.clientData, interp, 2, cmdArgv)!= TCL_OK){
return TCL_ERROR;
}
if (!Tix_GetCommandInfo(interp, argv[0], &cmdInfo)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "cannot autoload command \"",
argv[0], "\"",NULL);
return TCL_ERROR;
}
}
return Tix_GlobalEvalArgv(interp, &cmdInfo, argc, argv);
}
char *
Tix_FindPublicMethod(interp, cPtr, method)
Tcl_Interp * interp;
TixClassRecord * cPtr;
char * method;
{
int i;
int len = strlen(method);
for (i=0; i<cPtr->nMethods; i++) {
if (cPtr->methods[i][0] == method[0] &&
strncmp(cPtr->methods[i], method, len)==0) {
return cPtr->methods[i];
}
}
return 0;
}
/*
*----------------------------------------------------------------------
* MethodTableDeleteProc --
*
* This procedure is called when the interp is about to
* be deleted. It cleans up the hash entries and destroys the hash
* table.
*
* Results:
* None.
*
* Side effects:
* All class method contexts are deleted for this interpreter.
*----------------------------------------------------------------------
*/
static void
MethodTableDeleteProc(clientData, interp)
ClientData clientData;
Tcl_Interp *interp;
{
Tcl_HashTable * methodTablePtr = (Tcl_HashTable*)clientData;
Tcl_HashSearch hashSearch;
Tcl_HashEntry *hashPtr;
char * context;
for (hashPtr = Tcl_FirstHashEntry(methodTablePtr, &hashSearch);
hashPtr;
hashPtr = Tcl_NextHashEntry(&hashSearch)) {
context = (char*)Tcl_GetHashValue(hashPtr);
if (context) {
ckfree(context);
}
Tcl_DeleteHashEntry(hashPtr);
}
Tcl_DeleteHashTable(methodTablePtr);
ckfree((char*)methodTablePtr);
}