Subversion Repositories or1k

/*
 * 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);
}