tclnamesp.c

来自「tcl是工具命令语言」· C语言 代码 · 共 1,958 行 · 第 1/5 页

	Tcl_SetStringObj(Tcl_GetObjResult(interp),
	        "empty import pattern", -1);
        return TCL_ERROR;
    }
    TclGetNamespaceForQualName(interp, pattern, nsPtr,
	    /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr,
	    &dummyPtr, &simplePattern);

    if (importNsPtr == NULL) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"unknown namespace in import pattern \"",
		pattern, "\"", (char *) NULL);
        return TCL_ERROR;
    }
    if (importNsPtr == nsPtr) {
	if (pattern == simplePattern) {
	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		    "no namespace specified in import pattern \"", pattern,
		    "\"", (char *) NULL);
	} else {
	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		    "import pattern \"", pattern,
		    "\" tries to import from namespace \"",
		    importNsPtr->name, "\" into itself", (char *) NULL);
	}
        return TCL_ERROR;
    }

    /*
     * Scan through the command table in the source namespace and look for
     * exported commands that match the string pattern. Create an "imported
     * command" in the current namespace for each imported command; these
     * commands redirect their invocations to the "real" command.
     */

    for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
	    (hPtr != NULL);
	    hPtr = Tcl_NextHashEntry(&search)) {
        cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
        if (Tcl_StringMatch(cmdName, simplePattern)) {
	    /*
	     * The command cmdName in the source namespace matches the
	     * pattern. Check whether it was exported. If it wasn't,
	     * we ignore it.
	     */

	    wasExported = 0;
	    for (i = 0;  i < importNsPtr->numExportPatterns;  i++) {
		if (Tcl_StringMatch(cmdName,
			importNsPtr->exportArrayPtr[i])) {
		    wasExported = 1;
		    break;
		}
	    }
	    if (!wasExported) {
		continue;
            }

	    /*
	     * Unless there is a name clash, create an imported command
	     * in the current namespace that refers to cmdPtr.
	     */
	    
            if ((Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL)
		    || allowOverwrite) {
		/*
		 * Create the imported command and its client data.
		 * To create the new command in the current namespace, 
		 * generate a fully qualified name for it.
		 */

		Tcl_DString ds;

		Tcl_DStringInit(&ds);
		Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
		if (nsPtr != iPtr->globalNsPtr) {
		    Tcl_DStringAppend(&ds, "::", 2);
		}
		Tcl_DStringAppend(&ds, cmdName, -1);

		/*
		 * Check whether creating the new imported command in the
		 * current namespace would create a cycle of imported->real
		 * command references that also would destroy an existing
		 * "real" command already in the current namespace.
		 */

		cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
		if (cmdPtr->deleteProc == DeleteImportedCmd) {
		    realCmdPtr = (Command *) TclGetOriginalCommand(
			    (Tcl_Command) cmdPtr);
		    if ((realCmdPtr != NULL)
			    && (realCmdPtr->nsPtr == currNsPtr)
			    && (Tcl_FindHashEntry(&currNsPtr->cmdTable,
			            cmdName) != NULL)) {
			Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
			        "import pattern \"", pattern,
				"\" would create a loop containing command \"",
				Tcl_DStringValue(&ds), "\"", (char *) NULL);
			Tcl_DStringFree(&ds);
			return TCL_ERROR;
		    }
		}

		dataPtr = (ImportedCmdData *)
		        ckalloc(sizeof(ImportedCmdData));
                importedCmd = Tcl_CreateObjCommand(interp, 
                        Tcl_DStringValue(&ds), InvokeImportedCmd,
                        (ClientData) dataPtr, DeleteImportedCmd);
		dataPtr->realCmdPtr = cmdPtr;
		dataPtr->selfPtr = (Command *) importedCmd;
		dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
		Tcl_DStringFree(&ds);

		/*
		 * Create an ImportRef structure describing this new import
		 * command and add it to the import ref list in the "real"
		 * command.
		 */

                refPtr = (ImportRef *) ckalloc(sizeof(ImportRef));
                refPtr->importedCmdPtr = (Command *) importedCmd;
                refPtr->nextPtr = cmdPtr->importRefPtr;
                cmdPtr->importRefPtr = refPtr;
            } else {
		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		        "can't import command \"", cmdName,
			"\": already exists", (char *) NULL);
                return TCL_ERROR;
            }
        }
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ForgetImport --
 *
 *	Deletes previously imported commands. Given a pattern that may
 *	include the name of an exporting namespace, this procedure first
 *	finds all matching exported commands. It then looks in the namespace
 *	specified by namespacePtr for any corresponding previously imported
 *	commands, which it deletes. If namespacePtr is NULL, commands are
 *	deleted from the current namespace.
 *
 * Results:
 *	Returns TCL_OK if successful. If there is an error, returns
 *	TCL_ERROR and puts an error message in the interpreter's result
 *	object.
 *
 * Side effects:
 *	May delete commands. 
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ForgetImport(interp, namespacePtr, pattern)
    Tcl_Interp *interp;		 /* Current interpreter. */
    Tcl_Namespace *namespacePtr; /* Points to the namespace from which
				  * previously imported commands should be
				  * removed. NULL for current namespace. */
    CONST char *pattern;	 /* String pattern indicating which imported
				  * commands to remove. This pattern should
				  * be qualified by the name of the
				  * namespace from which the command(s) were
				  * imported. */
{
    Namespace *nsPtr, *importNsPtr, *dummyPtr, *actualCtxPtr;
    CONST char *simplePattern;
    char *cmdName;
    register Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Command *cmdPtr;

    /*
     * If the specified namespace is NULL, use the current namespace.
     */

    if (namespacePtr == NULL) {
        nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    } else {
        nsPtr = (Namespace *) namespacePtr;
    }

    /*
     * From the pattern, find the namespace from which we are importing
     * and get the simple pattern (no namespace qualifiers or ::'s) at
     * the end.
     */

    TclGetNamespaceForQualName(interp, pattern, nsPtr,
	    /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr,
	    &actualCtxPtr, &simplePattern);

    if (importNsPtr == NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"unknown namespace in namespace forget pattern \"",
		pattern, "\"", (char *) NULL);
        return TCL_ERROR;
    }

    /*
     * Scan through the command table in the source namespace and look for
     * exported commands that match the string pattern. If the current
     * namespace has an imported command that refers to one of those real
     * commands, delete it.
     */

    for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
            (hPtr != NULL);
            hPtr = Tcl_NextHashEntry(&search)) {
        cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
        if (Tcl_StringMatch(cmdName, simplePattern)) {
            hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName);
            if (hPtr != NULL) {	/* cmd of same name in current namespace */
                cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
                if (cmdPtr->deleteProc == DeleteImportedCmd) { 
                    Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
                }
            }
        }
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetOriginalCommand --
 *
 *	An imported command is created in an namespace when a "real" command
 *	is imported from another namespace. If the specified command is an
 *	imported command, this procedure returns the original command it
 *	refers to. 
 *
 * Results:
 *	If the command was imported into a sequence of namespaces a, b,...,n
 *	where each successive namespace just imports the command from the
 *	previous namespace, this procedure returns the Tcl_Command token in
 *	the first namespace, a. Otherwise, if the specified command is not
 *	an imported command, the procedure returns NULL.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
TclGetOriginalCommand(command)
    Tcl_Command command;	/* The imported command for which the
				 * original command should be returned. */
{
    register Command *cmdPtr = (Command *) command;
    ImportedCmdData *dataPtr;

    if (cmdPtr->deleteProc != DeleteImportedCmd) {
	return (Tcl_Command) NULL;
    }
    
    while (cmdPtr->deleteProc == DeleteImportedCmd) {
	dataPtr = (ImportedCmdData *) cmdPtr->objClientData;
	cmdPtr = dataPtr->realCmdPtr;
    }
    return (Tcl_Command) cmdPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * InvokeImportedCmd --
 *
 *	Invoked by Tcl whenever the user calls an imported command that
 *	was created by Tcl_Import. Finds the "real" command (in another
 *	namespace), and passes control to it.
 *
 * Results:
 *	Returns TCL_OK if successful, and  TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	Returns a result in the interpreter's result object. If anything
 *	goes wrong, the result object is set to an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InvokeImportedCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Points to the imported command's
				 * ImportedCmdData structure. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* The argument objects. */
{
    register ImportedCmdData *dataPtr = (ImportedCmdData *) clientData;
    register Command *realCmdPtr = dataPtr->realCmdPtr;

    return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp,
            objc, objv);
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteImportedCmd --
 *
 *	Invoked by Tcl whenever an imported command is deleted. The "real"
 *	command keeps a list of all the imported commands that refer to it,
 *	so those imported commands can be deleted when the real command is
 *	deleted. This procedure removes the imported command reference from
 *	the real command's list, and frees up the memory associated with
 *	the imported command.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Removes the imported command from the real command's import list.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteImportedCmd(clientData)
    ClientData clientData;	/* Points to the imported command's
				 * ImportedCmdData structure. */
{
    ImportedCmdData *dataPtr = (ImportedCmdData *) clientData;
    Command *realCmdPtr = dataPtr->realCmdPtr;
    Command *selfPtr = dataPtr->selfPtr;
    register ImportRef *refPtr, *prevPtr;

    prevPtr = NULL;
    for (refPtr = realCmdPtr->importRefPtr;  refPtr != NULL;
            refPtr = refPtr->nextPtr) {
	if (refPtr->importedCmdPtr == selfPtr) {
	    /*
	     * Remove *refPtr from real command's list of imported commands
	     * that refer to it.
	     */
	    
	    if (prevPtr == NULL) { /* refPtr is first in list */
		realCmdPtr->importRefPtr = refPtr->nextPtr;
	    } else {
		prevPtr->nextPtr = refPtr->nextPtr;
	    }
	    ckfree((char *) refPtr);
	    ckfree((char *) dataPtr);
	    return;
	}
	prevPtr = refPtr;
    }
	
    panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references");
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetNamespaceForQualName --
 *
 *	Given a qualified name specifying a command, variable, or namespace,
 *	and a namespace in which to resolve the name, this procedure returns
 *	a pointer to the namespace that contains the item. A qualified name
 *	consists of the "simple" name of an item qualified by the names of
 *	an arbitrary number of containing namespace separated by "::"s. If
 *	the qualified name starts with "::", it is interpreted absolutely
 *	from the global namespace. Otherwise, it is interpreted relative to
 *	the namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr
 *	is NULL, the name is interpreted relative to the current namespace.
 *
 *	A relative name like "foo::bar::x" can be found starting in either
 *	the current namespace or in the global namespace. So each search
 *	usually follows two tracks, and two possible namespaces are
 *	returned. If the procedure sets either *nsPtrPtr or *altNsPtrPtr to
 *	NULL, then that path failed.
 *
 *	If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is
 *	sought only in the global :: namespace. The alternate search
 *	(also) starting from the global namespace is ignored and
 *	*altNsPtrPtr is set NULL. 
 *
 *	If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified
 *	name is sought only in the namespace specified by cxtNsPtr. The
 *	alternate search starting from the global namespace is ignored and
 *	*altNsPtrPtr is set NULL. If both TCL_GLOBAL_ONLY and
 *	TCL_NAMESPACE_ONLY are specified, TCL_GLOBAL_ONLY is ignored and
 *	the search starts from the namespace specified by cxtNsPtr.
 *