diff options
Diffstat (limited to 'tix/generic/tixMethod.c')
| -rw-r--r-- | tix/generic/tixMethod.c | 604 |
1 files changed, 604 insertions, 0 deletions
diff --git a/tix/generic/tixMethod.c b/tix/generic/tixMethod.c new file mode 100644 index 00000000000..e09d5f371c8 --- /dev/null +++ b/tix/generic/tixMethod.c @@ -0,0 +1,604 @@ +/* + * 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 = (char*)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 (char*)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); +} |