sl@0: /*
sl@0:  * tclResolve.c --
sl@0:  *
sl@0:  *      Contains hooks for customized command/variable name resolution
sl@0:  *      schemes.  These hooks allow extensions like [incr Tcl] to add
sl@0:  *      their own name resolution rules to the Tcl language.  Rules can
sl@0:  *      be applied to a particular namespace, to the interpreter as a
sl@0:  *      whole, or both.
sl@0:  *
sl@0:  * Copyright (c) 1998 Lucent Technologies, Inc.
sl@0:  *
sl@0:  * See the file "license.terms" for information on usage and redistribution
sl@0:  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0:  *
sl@0:  * RCS: @(#) $Id: tclResolve.c,v 1.4 2002/01/25 22:01:32 dgp Exp $
sl@0:  */
sl@0: 
sl@0: #include "tclInt.h"
sl@0: 
sl@0: /*
sl@0:  * Declarations for procedures local to this file:
sl@0:  */
sl@0: 
sl@0: static void		BumpCmdRefEpochs _ANSI_ARGS_((Namespace *nsPtr));
sl@0: 
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * Tcl_AddInterpResolvers --
sl@0:  *
sl@0:  *	Adds a set of command/variable resolution procedures to an
sl@0:  *	interpreter.  These procedures are consulted when commands
sl@0:  *	are resolved in Tcl_FindCommand, and when variables are
sl@0:  *	resolved in TclLookupVar and LookupCompiledLocal.  Each
sl@0:  *	namespace may also have its own set of resolution procedures
sl@0:  *	which take precedence over those for the interpreter.
sl@0:  *
sl@0:  *	When a name is resolved, it is handled as follows.  First,
sl@0:  *	the name is passed to the resolution procedures for the
sl@0:  *	namespace.  If not resolved, the name is passed to each of
sl@0:  *	the resolution procedures added to the interpreter.  Finally,
sl@0:  *	if still not resolved, the name is handled using the default
sl@0:  *	Tcl rules for name resolution.
sl@0:  *
sl@0:  * Results:
sl@0:  *	Returns pointers to the current name resolution procedures
sl@0:  *	in the cmdProcPtr, varProcPtr and compiledVarProcPtr
sl@0:  *	arguments.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	If a compiledVarProc is specified, this procedure bumps the
sl@0:  *	compileEpoch for the interpreter, forcing all code to be
sl@0:  *	recompiled.  If a cmdProc is specified, this procedure bumps
sl@0:  *	the cmdRefEpoch in all namespaces, forcing commands to be
sl@0:  *	resolved again using the new rules.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: void
sl@0: Tcl_AddInterpResolvers(interp, name, cmdProc, varProc, compiledVarProc)
sl@0: 
sl@0:     Tcl_Interp *interp;			/* Interpreter whose name resolution
sl@0: 					 * rules are being modified. */
sl@0:     CONST char *name;			/* Name of this resolution scheme. */
sl@0:     Tcl_ResolveCmdProc *cmdProc;	/* New procedure for command
sl@0: 					 * resolution */
sl@0:     Tcl_ResolveVarProc *varProc;	/* Procedure for variable resolution
sl@0: 					 * at runtime */
sl@0:     Tcl_ResolveCompiledVarProc *compiledVarProc;
sl@0: 					/* Procedure for variable resolution
sl@0: 					 * at compile time. */
sl@0: {
sl@0:     Interp *iPtr = (Interp*)interp;
sl@0:     ResolverScheme *resPtr;
sl@0: 
sl@0:     /*
sl@0:      *  Since we're adding a new name resolution scheme, we must force
sl@0:      *  all code to be recompiled to use the new scheme.  If there
sl@0:      *  are new compiled variable resolution rules, bump the compiler
sl@0:      *  epoch to invalidate compiled code.  If there are new command
sl@0:      *  resolution rules, bump the cmdRefEpoch in all namespaces.
sl@0:      */
sl@0:     if (compiledVarProc) {
sl@0:         iPtr->compileEpoch++;
sl@0:     }
sl@0:     if (cmdProc) {
sl@0:         BumpCmdRefEpochs(iPtr->globalNsPtr);
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      *  Look for an existing scheme with the given name.  If found,
sl@0:      *  then replace its rules.
sl@0:      */
sl@0:     for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) {
sl@0:         if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
sl@0:             resPtr->cmdResProc = cmdProc;
sl@0:             resPtr->varResProc = varProc;
sl@0:             resPtr->compiledVarResProc = compiledVarProc;
sl@0:             return;
sl@0:         }
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      *  Otherwise, this is a new scheme.  Add it to the FRONT
sl@0:      *  of the linked list, so that it overrides existing schemes.
sl@0:      */
sl@0:     resPtr = (ResolverScheme *) ckalloc(sizeof(ResolverScheme));
sl@0:     resPtr->name = (char*)ckalloc((unsigned)(strlen(name)+1));
sl@0:     strcpy(resPtr->name, name);
sl@0:     resPtr->cmdResProc = cmdProc;
sl@0:     resPtr->varResProc = varProc;
sl@0:     resPtr->compiledVarResProc = compiledVarProc;
sl@0:     resPtr->nextPtr = iPtr->resolverPtr;
sl@0:     iPtr->resolverPtr = resPtr;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * Tcl_GetInterpResolvers --
sl@0:  *
sl@0:  *	Looks for a set of command/variable resolution procedures with
sl@0:  *	the given name in an interpreter.  These procedures are
sl@0:  *	registered by calling Tcl_AddInterpResolvers.
sl@0:  *
sl@0:  * Results:
sl@0:  *	If the name is recognized, this procedure returns non-zero,
sl@0:  *	along with pointers to the name resolution procedures in
sl@0:  *	the Tcl_ResolverInfo structure.  If the name is not recognized,
sl@0:  *	this procedure returns zero.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int
sl@0: Tcl_GetInterpResolvers(interp, name, resInfoPtr)
sl@0: 
sl@0:     Tcl_Interp *interp;			/* Interpreter whose name resolution
sl@0: 					 * rules are being queried. */
sl@0:     CONST char *name;                   /* Look for a scheme with this name. */
sl@0:     Tcl_ResolverInfo *resInfoPtr;	/* Returns pointers to the procedures,
sl@0: 					 * if found */
sl@0: {
sl@0:     Interp *iPtr = (Interp*)interp;
sl@0:     ResolverScheme *resPtr;
sl@0: 
sl@0:     /*
sl@0:      *  Look for an existing scheme with the given name.  If found,
sl@0:      *  then return pointers to its procedures.
sl@0:      */
sl@0:     for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) {
sl@0:         if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
sl@0: 	    resInfoPtr->cmdResProc = resPtr->cmdResProc;
sl@0: 	    resInfoPtr->varResProc = resPtr->varResProc;
sl@0: 	    resInfoPtr->compiledVarResProc = resPtr->compiledVarResProc;
sl@0:             return 1;
sl@0:         }
sl@0:     }
sl@0: 
sl@0:     return 0;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * Tcl_RemoveInterpResolvers --
sl@0:  *
sl@0:  *	Removes a set of command/variable resolution procedures
sl@0:  *	previously added by Tcl_AddInterpResolvers.  The next time
sl@0:  *	a command/variable name is resolved, these procedures
sl@0:  *	won't be consulted.
sl@0:  *
sl@0:  * Results:
sl@0:  *	Returns non-zero if the name was recognized and the
sl@0:  *	resolution scheme was deleted.  Returns zero otherwise.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	If a scheme with a compiledVarProc was deleted, this procedure
sl@0:  *	bumps the compileEpoch for the interpreter, forcing all code
sl@0:  *	to be recompiled.  If a scheme with a cmdProc was deleted,
sl@0:  *	this procedure bumps the cmdRefEpoch in all namespaces,
sl@0:  *	forcing commands to be resolved again using the new rules.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int
sl@0: Tcl_RemoveInterpResolvers(interp, name)
sl@0: 
sl@0:     Tcl_Interp *interp;			/* Interpreter whose name resolution
sl@0: 					 * rules are being modified. */
sl@0:     CONST char *name;                   /* Name of the scheme to be removed. */
sl@0: {
sl@0:     Interp *iPtr = (Interp*)interp;
sl@0:     ResolverScheme **prevPtrPtr, *resPtr;
sl@0: 
sl@0:     /*
sl@0:      *  Look for an existing scheme with the given name.
sl@0:      */
sl@0:     prevPtrPtr = &iPtr->resolverPtr;
sl@0:     for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) {
sl@0:         if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
sl@0:             break;
sl@0:         }
sl@0:         prevPtrPtr = &resPtr->nextPtr;
sl@0:     }
sl@0: 
sl@0:     /*
sl@0:      *  If we found the scheme, delete it.
sl@0:      */
sl@0:     if (resPtr) {
sl@0:         /*
sl@0:          *  If we're deleting a scheme with compiled variable resolution
sl@0:          *  rules, bump the compiler epoch to invalidate compiled code.
sl@0:          *  If we're deleting a scheme with command resolution rules,
sl@0:          *  bump the cmdRefEpoch in all namespaces.
sl@0:          */
sl@0:         if (resPtr->compiledVarResProc) {
sl@0:             iPtr->compileEpoch++;
sl@0:         }
sl@0:         if (resPtr->cmdResProc) {
sl@0:             BumpCmdRefEpochs(iPtr->globalNsPtr);
sl@0:         }
sl@0: 
sl@0:         *prevPtrPtr = resPtr->nextPtr;
sl@0:         ckfree(resPtr->name);
sl@0:         ckfree((char *) resPtr);
sl@0: 
sl@0:         return 1;
sl@0:     }
sl@0:     return 0;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * BumpCmdRefEpochs --
sl@0:  *
sl@0:  *	This procedure is used to bump the cmdRefEpoch counters in
sl@0:  *	the specified namespace and all of its child namespaces.
sl@0:  *	It is used whenever name resolution schemes are added/removed
sl@0:  *	from an interpreter, to invalidate all command references.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Bumps the cmdRefEpoch in the specified namespace and its
sl@0:  *	children, recursively.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static void
sl@0: BumpCmdRefEpochs(nsPtr)
sl@0:     Namespace *nsPtr;			/* Namespace being modified. */
sl@0: {
sl@0:     Tcl_HashEntry *entry;
sl@0:     Tcl_HashSearch search;
sl@0:     Namespace *childNsPtr;
sl@0: 
sl@0:     nsPtr->cmdRefEpoch++;
sl@0: 
sl@0:     for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
sl@0: 	    entry != NULL;
sl@0: 	    entry = Tcl_NextHashEntry(&search)) {
sl@0: 
sl@0:         childNsPtr = (Namespace *) Tcl_GetHashValue(entry);
sl@0:         BumpCmdRefEpochs(childNsPtr);
sl@0:     }
sl@0: }
sl@0: 
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * Tcl_SetNamespaceResolvers --
sl@0:  *
sl@0:  *	Sets the command/variable resolution procedures for a namespace,
sl@0:  *	thereby changing the way that command/variable names are
sl@0:  *	interpreted.  This allows extension writers to support different
sl@0:  *	name resolution schemes, such as those for object-oriented
sl@0:  *	packages.
sl@0:  *
sl@0:  *	Command resolution is handled by a procedure of the following
sl@0:  *	type:
sl@0:  *
sl@0:  *	  typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((
sl@0:  *		Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context,
sl@0:  *              int flags, Tcl_Command *rPtr));
sl@0:  *          
sl@0:  *	Whenever a command is executed or Tcl_FindCommand is invoked
sl@0:  *	within the namespace, this procedure is called to resolve the
sl@0:  *	command name.  If this procedure is able to resolve the name,
sl@0:  *	it should return the status code TCL_OK, along with the
sl@0:  *	corresponding Tcl_Command in the rPtr argument.  Otherwise,
sl@0:  *	the procedure can return TCL_CONTINUE, and the command will
sl@0:  *	be treated under the usual name resolution rules.  Or, it can
sl@0:  *	return TCL_ERROR, and the command will be considered invalid.
sl@0:  *
sl@0:  *	Variable resolution is handled by two procedures.  The first
sl@0:  *	is called whenever a variable needs to be resolved at compile
sl@0:  *	time:
sl@0:  *
sl@0:  *        typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_((
sl@0:  *	        Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context,
sl@0:  *	        Tcl_ResolvedVarInfo *rPtr));
sl@0:  *
sl@0:  *      If this procedure is able to resolve the name, it should return
sl@0:  *      the status code TCL_OK, along with variable resolution info in
sl@0:  *      the rPtr argument; this info will be used to set up compiled
sl@0:  *	locals in the call frame at runtime.  The procedure may also
sl@0:  *	return TCL_CONTINUE, and the variable will be treated under
sl@0:  *	the usual name resolution rules.  Or, it can return TCL_ERROR,
sl@0:  *	and the variable will be considered invalid.
sl@0:  *
sl@0:  *	Another procedure is used whenever a variable needs to be
sl@0:  *	resolved at runtime but it is not recognized as a compiled local.
sl@0:  *	(For example, the variable may be requested via
sl@0:  *	Tcl_FindNamespaceVar.) This procedure has the following type:
sl@0:  *
sl@0:  *	  typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_((
sl@0:  *	        Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context,
sl@0:  *	        int flags, Tcl_Var *rPtr));
sl@0:  *
sl@0:  *	This procedure is quite similar to the compile-time version.
sl@0:  *	It returns the same status codes, but if variable resolution
sl@0:  *	succeeds, this procedure returns a Tcl_Var directly via the
sl@0:  *	rPtr argument.
sl@0:  *
sl@0:  * Results:
sl@0:  *	Nothing.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Bumps the command epoch counter for the namespace, invalidating
sl@0:  *	all command references in that namespace.  Also bumps the
sl@0:  *	resolver epoch counter for the namespace, forcing all code
sl@0:  *	in the namespace to be recompiled.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: void
sl@0: Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc)
sl@0:     Tcl_Namespace *namespacePtr;	/* Namespace whose resolution rules
sl@0: 					 * are being modified. */
sl@0:     Tcl_ResolveCmdProc *cmdProc;	/* Procedure for command resolution */
sl@0:     Tcl_ResolveVarProc *varProc;	/* Procedure for variable resolution
sl@0: 					 * at runtime */
sl@0:     Tcl_ResolveCompiledVarProc *compiledVarProc;
sl@0: 					/* Procedure for variable resolution
sl@0: 					 * at compile time. */
sl@0: {
sl@0:     Namespace *nsPtr = (Namespace*)namespacePtr;
sl@0: 
sl@0:     /*
sl@0:      *  Plug in the new command resolver, and bump the epoch counters
sl@0:      *  so that all code will have to be recompiled and all commands
sl@0:      *  will have to be resolved again using the new policy.
sl@0:      */
sl@0:     nsPtr->cmdResProc = cmdProc;
sl@0:     nsPtr->varResProc = varProc;
sl@0:     nsPtr->compiledVarResProc = compiledVarProc;
sl@0: 
sl@0:     nsPtr->cmdRefEpoch++;
sl@0:     nsPtr->resolverEpoch++;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * Tcl_GetNamespaceResolvers --
sl@0:  *
sl@0:  *	Returns the current command/variable resolution procedures
sl@0:  *	for a namespace.  By default, these procedures are NULL.
sl@0:  *	New procedures can be installed by calling
sl@0:  *	Tcl_SetNamespaceResolvers, to provide new name resolution
sl@0:  *	rules.
sl@0:  *
sl@0:  * Results:
sl@0:  *	Returns non-zero if any name resolution procedures have been
sl@0:  *	assigned to this namespace; also returns pointers to the
sl@0:  *	procedures in the Tcl_ResolverInfo structure.  Returns zero
sl@0:  *	otherwise.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int
sl@0: Tcl_GetNamespaceResolvers(namespacePtr, resInfoPtr)
sl@0: 
sl@0:     Tcl_Namespace *namespacePtr;	/* Namespace whose resolution rules
sl@0: 					 * are being modified. */
sl@0:     Tcl_ResolverInfo *resInfoPtr;	/* Returns: pointers for all
sl@0: 					 * name resolution procedures
sl@0: 					 * assigned to this namespace. */
sl@0: {
sl@0:     Namespace *nsPtr = (Namespace*)namespacePtr;
sl@0: 
sl@0:     resInfoPtr->cmdResProc = nsPtr->cmdResProc;
sl@0:     resInfoPtr->varResProc = nsPtr->varResProc;
sl@0:     resInfoPtr->compiledVarResProc = nsPtr->compiledVarResProc;
sl@0: 
sl@0:     if (nsPtr->cmdResProc != NULL ||
sl@0:         nsPtr->varResProc != NULL ||
sl@0:         nsPtr->compiledVarResProc != NULL) {
sl@0: 	return 1;
sl@0:     }
sl@0:     return 0;
sl@0: }