diff options
Diffstat (limited to 'generic/tclBasic.c')
| -rw-r--r-- | generic/tclBasic.c | 3992 |
1 files changed, 3992 insertions, 0 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c new file mode 100644 index 0000000..952292f --- /dev/null +++ b/generic/tclBasic.c @@ -0,0 +1,3992 @@ +/* + * tclBasic.c -- + * + * Contains the basic facilities for TCL command interpretation, + * including interpreter creation and deletion, command creation + * and deletion, and command parsing and execution. + * + * Copyright (c) 1987-1994 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclBasic.c 1.305 97/08/13 10:34:43 + */ + +#include "tclInt.h" +#include "tclCompile.h" +#ifndef TCL_GENERIC_ONLY +# include "tclPort.h" +#endif + +/* + * Static procedures in this file: + */ + +static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); +static void HiddenCmdsDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); + +/* + * The following structure defines the commands in the Tcl core. + */ + +typedef struct { + char *name; /* Name of object-based command. */ + Tcl_CmdProc *proc; /* String-based procedure for command. */ + Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */ + CompileProc *compileProc; /* Procedure called to compile command. */ + int isSafe; /* If non-zero, command will be present + * in safe interpreter. Otherwise it will + * be hidden. */ +} CmdInfo; + +/* + * The built-in commands, and the procedures that implement them: + */ + +static CmdInfo builtInCmds[] = { + /* + * Commands in the generic core. Note that at least one of the proc or + * objProc members should be non-NULL. This avoids infinitely recursive + * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a + * command name is computed at runtime and results in the name of a + * compiled command. + */ + + {"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd, + (CompileProc *) NULL, 1}, + {"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd, + (CompileProc *) NULL, 1}, + {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd, + (CompileProc *) NULL, 1}, + {"break", Tcl_BreakCmd, (Tcl_ObjCmdProc *) NULL, + TclCompileBreakCmd, 1}, + {"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd, + (CompileProc *) NULL, 1}, + {"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd, + TclCompileCatchCmd, 1}, + {"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd, + (CompileProc *) NULL, 1}, + {"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd, + (CompileProc *) NULL, 1}, + {"continue", Tcl_ContinueCmd, (Tcl_ObjCmdProc *) NULL, + TclCompileContinueCmd, 1}, + {"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd, + (CompileProc *) NULL, 1}, + {"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd, + (CompileProc *) NULL, 1}, + {"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd, + (CompileProc *) NULL, 0}, + {"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd, + TclCompileExprCmd, 1}, + {"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd, + (CompileProc *) NULL, 1}, + {"fileevent", Tcl_FileEventCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"for", Tcl_ForCmd, (Tcl_ObjCmdProc *) NULL, + TclCompileForCmd, 1}, + {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd, + TclCompileForeachCmd, 1}, + {"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd, + (CompileProc *) NULL, 1}, + {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd, + (CompileProc *) NULL, 1}, + {"if", Tcl_IfCmd, (Tcl_ObjCmdProc *) NULL, + TclCompileIfCmd, 1}, + {"incr", Tcl_IncrCmd, (Tcl_ObjCmdProc *) NULL, + TclCompileIncrCmd, 1}, + {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd, + (CompileProc *) NULL, 1}, + {"interp", (Tcl_CmdProc *) NULL, Tcl_InterpObjCmd, + (CompileProc *) NULL, 1}, + {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd, + (CompileProc *) NULL, 1}, + {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd, + (CompileProc *) NULL, 1}, + {"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd, + (CompileProc *) NULL, 1}, + {"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd, + (CompileProc *) NULL, 1}, + {"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd, + (CompileProc *) NULL, 1}, + {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd, + (CompileProc *) NULL, 1}, + {"load", Tcl_LoadCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd, + (CompileProc *) NULL, 1}, + {"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd, + (CompileProc *) NULL, 1}, + {"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd, + (CompileProc *) NULL, 1}, + {"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd, + (CompileProc *) NULL, 1}, + {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd, + (CompileProc *) NULL, 1}, + {"package", Tcl_PackageCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd, + (CompileProc *) NULL, 1}, + {"regexp", Tcl_RegexpCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"regsub", Tcl_RegsubCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd, + (CompileProc *) NULL, 1}, + {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd, + (CompileProc *) NULL, 1}, + {"scan", Tcl_ScanCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"set", Tcl_SetCmd, (Tcl_ObjCmdProc *) NULL, + TclCompileSetCmd, 1}, + {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd, + (CompileProc *) NULL, 1}, + {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd, + (CompileProc *) NULL, 1}, + {"subst", Tcl_SubstCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd, + (CompileProc *) NULL, 1}, + {"trace", Tcl_TraceCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd, + (CompileProc *) NULL, 1}, + {"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd, + (CompileProc *) NULL, 1}, + {"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd, + (CompileProc *) NULL, 1}, + {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd, + (CompileProc *) NULL, 1}, + {"while", Tcl_WhileCmd, (Tcl_ObjCmdProc *) NULL, + TclCompileWhileCmd, 1}, + + /* + * Commands in the UNIX core: + */ + +#ifndef TCL_GENERIC_ONLY + {"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd, + (CompileProc *) NULL, 1}, + {"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd, + (CompileProc *) NULL, 0}, + {"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd, + (CompileProc *) NULL, 1}, + {"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd, + (CompileProc *) NULL, 1}, + {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd, + (CompileProc *) NULL, 1}, + {"fconfigure", Tcl_FconfigureCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd, + (CompileProc *) NULL, 0}, + {"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd, + (CompileProc *) NULL, 1}, + {"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd, + (CompileProc *) NULL, 1}, + {"glob", Tcl_GlobCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"open", Tcl_OpenCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd, + (CompileProc *) NULL, 1}, + {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd, + (CompileProc *) NULL, 1}, + {"pwd", Tcl_PwdCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd, + (CompileProc *) NULL, 1}, + {"seek", Tcl_SeekCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"socket", Tcl_SocketCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"tell", Tcl_TellCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd, + (CompileProc *) NULL, 1}, + {"update", Tcl_UpdateCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + {"vwait", Tcl_VwaitCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 1}, + +#ifdef MAC_TCL + {"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd, + (CompileProc *) NULL, 0}, + {"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"ls", Tcl_LsCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd, + (CompileProc *) NULL, 1}, + {"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd, + (CompileProc *) NULL, 0}, +#else + {"exec", Tcl_ExecCmd, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0}, + {"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd, + (CompileProc *) NULL, 0}, +#endif /* MAC_TCL */ + +#endif /* TCL_GENERIC_ONLY */ + {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL, + (CompileProc *) NULL, 0} +}; + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateInterp -- + * + * Create a new TCL command interpreter. + * + * Results: + * The return value is a token for the interpreter, which may be + * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or + * Tcl_DeleteInterp. + * + * Side effects: + * The command interpreter is initialized with an empty variable + * table and the built-in commands. + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_CreateInterp() +{ + register Interp *iPtr; + register Command *cmdPtr; + register CmdInfo *cmdInfoPtr; + union { + char c[sizeof(short)]; + short s; + } order; + int i; + + /* + * Panic if someone updated the CallFrame structure without + * also updating the Tcl_CallFrame structure (or vice versa). + */ + + if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) { + /*NOTREACHED*/ + panic("Tcl_CallFrame and CallFrame are not the same size"); + } + + /* + * Initialize support for namespaces and create the global namespace + * (whose name is ""; an alias is "::"). This also initializes the + * Tcl object type table and other object management code. + */ + + TclInitNamespaces(); + + iPtr = (Interp *) ckalloc(sizeof(Interp)); + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + iPtr->objResultPtr = Tcl_NewObj(); /* an empty object */ + Tcl_IncrRefCount(iPtr->objResultPtr); + iPtr->errorLine = 0; + Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); + iPtr->numLevels = 0; + iPtr->maxNestingDepth = 1000; + iPtr->framePtr = NULL; + iPtr->varFramePtr = NULL; + iPtr->activeTracePtr = NULL; + iPtr->returnCode = TCL_OK; + iPtr->errorInfo = NULL; + iPtr->errorCode = NULL; + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + iPtr->appendUsed = 0; + for (i = 0; i < NUM_REGEXPS; i++) { + iPtr->patterns[i] = NULL; + iPtr->patLengths[i] = -1; + iPtr->regexps[i] = NULL; + } + Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); + iPtr->packageUnknown = NULL; + iPtr->cmdCount = 0; + iPtr->termOffset = 0; + iPtr->compileEpoch = 0; + iPtr->compiledProcPtr = NULL; + iPtr->evalFlags = 0; + iPtr->scriptFile = NULL; + iPtr->flags = 0; + iPtr->tracePtr = NULL; + iPtr->assocData = (Tcl_HashTable *) NULL; + iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ + iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ + Tcl_IncrRefCount(iPtr->emptyObjPtr); + iPtr->resultSpace[0] = 0; + + iPtr->globalNsPtr = NULL; /* force creation of global ns below */ + iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace( + (Tcl_Interp *) iPtr, "", (ClientData) NULL, + (Tcl_NamespaceDeleteProc *) NULL); + if (iPtr->globalNsPtr == NULL) { + panic("Tcl_CreateInterp: can't create global namespace"); + } + + /* + * Initialize support for code compilation. Do this after initializing + * namespaces since TclCreateExecEnv will try to reference a Tcl + * variable (it links to the Tcl "tcl_traceExec" variable). + */ + + iPtr->execEnvPtr = TclCreateExecEnv((Tcl_Interp *) iPtr); + + /* + * Create the core commands. Do it here, rather than calling + * Tcl_CreateCommand, because it's faster (there's no need to check for + * a pre-existing command by the same name). If a command has a + * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to + * TclInvokeStringCommand. This is an object-based wrapper procedure + * that extracts strings, calls the string procedure, and creates an + * object for the result. Similarly, if a command has a Tcl_ObjCmdProc + * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. + */ + + for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; + cmdInfoPtr++) { + int new; + Tcl_HashEntry *hPtr; + + if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) + && (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) + && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) { + panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n"); + } + + hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, + cmdInfoPtr->name, &new); + if (new) { + cmdPtr = (Command *) ckalloc(sizeof(Command)); + cmdPtr->hPtr = hPtr; + cmdPtr->nsPtr = iPtr->globalNsPtr; + cmdPtr->refCount = 1; + cmdPtr->cmdEpoch = 0; + cmdPtr->compileProc = cmdInfoPtr->compileProc; + if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) { + cmdPtr->proc = TclInvokeObjectCommand; + cmdPtr->clientData = (ClientData) cmdPtr; + } else { + cmdPtr->proc = cmdInfoPtr->proc; + cmdPtr->clientData = (ClientData) NULL; + } + if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { + cmdPtr->objProc = TclInvokeStringCommand; + cmdPtr->objClientData = (ClientData) cmdPtr; + } else { + cmdPtr->objProc = cmdInfoPtr->objProc; + cmdPtr->objClientData = (ClientData) NULL; + } + cmdPtr->deleteProc = NULL; + cmdPtr->deleteData = (ClientData) NULL; + cmdPtr->deleted = 0; + cmdPtr->importRefPtr = NULL; + Tcl_SetHashValue(hPtr, cmdPtr); + } + } + + /* + * Initialize/Create "errorInfo" and "errorCode" global vars + * (because some part of the C code assume they exists + * and we can get a seg fault otherwise (in multiple + * interps loading of extensions for instance) --dl) + */ + /* + * We can't assume that because we initialize + * the variables here, they won't be unset later. + * so we had 2 choices: + * + Check every place where a GetVar of those is used + * and the NULL result is not checked (like in tclLoad.c) + * + Make SetVar,... NULL friendly + * We choosed the second option because : + * + It is easy and low cost to check for NULL pointer before + * calling strlen() + * + It can be helpfull to other people using those API + * + Passing a NULL value to those closest 'meaning' is empty string + * (specially with the new objects where 0 bytes strings are ok) + * So the following init is commented out: -- dl + */ + /* + (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, "", + TCL_GLOBAL_ONLY); + (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, "NONE", + TCL_GLOBAL_ONLY); + */ + +#ifndef TCL_GENERIC_ONLY + TclSetupEnv((Tcl_Interp *) iPtr); +#endif + + /* + * Do Multiple/Safe Interps Tcl init stuff + */ + (void) TclInterpInit((Tcl_Interp *)iPtr); + + /* + * Set up variables such as tcl_version. + */ + + TclPlatformInit((Tcl_Interp *)iPtr); + Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL, + TCL_GLOBAL_ONLY); + Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION, + TCL_GLOBAL_ONLY); + Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + TclPrecTraceProc, (ClientData) NULL); + + /* + * Compute the byte order of this machine. + */ + + order.s = 1; + Tcl_SetVar2((Tcl_Interp *) iPtr, "tcl_platform", "byteOrder", + (order.c[0] == 1) ? "littleEndian" : "bigEndian", + TCL_GLOBAL_ONLY); + + /* + * Register Tcl's version number. + */ + + Tcl_PkgProvide((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION); + + return (Tcl_Interp *) iPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclHideUnsafeCommands -- + * + * Hides base commands that are not marked as safe from this + * interpreter. + * + * Results: + * TCL_OK if it succeeds, TCL_ERROR else. + * + * Side effects: + * Hides functionality in an interpreter. + * + *---------------------------------------------------------------------- + */ + +int +TclHideUnsafeCommands(interp) + Tcl_Interp *interp; /* Hide commands in this interpreter. */ +{ + register CmdInfo *cmdInfoPtr; + + if (interp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { + if (!cmdInfoPtr->isSafe) { + Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); + } + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_CallWhenDeleted -- + * + * Arrange for a procedure to be called before a given + * interpreter is deleted. The procedure is called as soon + * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is + * called on an interpreter that has already been deleted, + * the procedure will be called when the last Tcl_Release is + * done on the interpreter. + * + * Results: + * None. + * + * Side effects: + * When Tcl_DeleteInterp is invoked to delete interp, + * proc will be invoked. See the manual entry for + * details. + * + *-------------------------------------------------------------- + */ + +void +Tcl_CallWhenDeleted(interp, proc, clientData) + Tcl_Interp *interp; /* Interpreter to watch. */ + Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter + * is about to be deleted. */ + ClientData clientData; /* One-word value to pass to proc. */ +{ + Interp *iPtr = (Interp *) interp; + static int assocDataCounter = 0; + int new; + char buffer[128]; + AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); + Tcl_HashEntry *hPtr; + + sprintf(buffer, "Assoc Data Key #%d", assocDataCounter); + assocDataCounter++; + + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); + } + hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new); + dPtr->proc = proc; + dPtr->clientData = clientData; + Tcl_SetHashValue(hPtr, dPtr); +} + +/* + *-------------------------------------------------------------- + * + * Tcl_DontCallWhenDeleted -- + * + * Cancel the arrangement for a procedure to be called when + * a given interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * If proc and clientData were previously registered as a + * callback via Tcl_CallWhenDeleted, they are unregistered. + * If they weren't previously registered then nothing + * happens. + * + *-------------------------------------------------------------- + */ + +void +Tcl_DontCallWhenDeleted(interp, proc, clientData) + Tcl_Interp *interp; /* Interpreter to watch. */ + Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter + * is about to be deleted. */ + ClientData clientData; /* One-word value to pass to proc. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTablePtr; + Tcl_HashSearch hSearch; + Tcl_HashEntry *hPtr; + AssocData *dPtr; + + hTablePtr = iPtr->assocData; + if (hTablePtr == (Tcl_HashTable *) NULL) { + return; + } + for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { + ckfree((char *) dPtr); + Tcl_DeleteHashEntry(hPtr); + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetAssocData -- + * + * Creates a named association between user-specified data, a delete + * function and this interpreter. If the association already exists + * the data is overwritten with the new data. The delete function will + * be invoked when the interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * Sets the associated data, creates the association if needed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetAssocData(interp, name, proc, clientData) + Tcl_Interp *interp; /* Interpreter to associate with. */ + char *name; /* Name for association. */ + Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is + * about to be deleted. */ + ClientData clientData; /* One-word value to pass to proc. */ +{ + Interp *iPtr = (Interp *) interp; + AssocData *dPtr; + Tcl_HashEntry *hPtr; + int new; + + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); + } + hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new); + if (new == 0) { + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + } else { + dPtr = (AssocData *) ckalloc(sizeof(AssocData)); + } + dPtr->proc = proc; + dPtr->clientData = clientData; + + Tcl_SetHashValue(hPtr, dPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteAssocData -- + * + * Deletes a named association of user-specified data with + * the specified interpreter. + * + * Results: + * None. + * + * Side effects: + * Deletes the association. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteAssocData(interp, name) + Tcl_Interp *interp; /* Interpreter to associate with. */ + char *name; /* Name of association. */ +{ + Interp *iPtr = (Interp *) interp; + AssocData *dPtr; + Tcl_HashEntry *hPtr; + + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + return; + } + hPtr = Tcl_FindHashEntry(iPtr->assocData, name); + if (hPtr == (Tcl_HashEntry *) NULL) { + return; + } + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + if (dPtr->proc != NULL) { + (dPtr->proc) (dPtr->clientData, interp); + } + ckfree((char *) dPtr); + Tcl_DeleteHashEntry(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetAssocData -- + * + * Returns the client data associated with this name in the + * specified interpreter. + * + * Results: + * The client data in the AssocData record denoted by the named + * association, or NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_GetAssocData(interp, name, procPtr) + Tcl_Interp *interp; /* Interpreter associated with. */ + char *name; /* Name of association. */ + Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address + * of current deletion callback. */ +{ + Interp *iPtr = (Interp *) interp; + AssocData *dPtr; + Tcl_HashEntry *hPtr; + + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + return (ClientData) NULL; + } + hPtr = Tcl_FindHashEntry(iPtr->assocData, name); + if (hPtr == (Tcl_HashEntry *) NULL) { + return (ClientData) NULL; + } + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + if (procPtr != (Tcl_InterpDeleteProc **) NULL) { + *procPtr = dPtr->proc; + } + return dPtr->clientData; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteInterpProc -- + * + * Helper procedure to delete an interpreter. This procedure is + * called when the last call to Tcl_Preserve on this interpreter + * is matched by a call to Tcl_Release. The procedure cleans up + * all resources used in the interpreter and calls all currently + * registered interpreter deletion callbacks. + * + * Results: + * None. + * + * Side effects: + * Whatever the interpreter deletion callbacks do. Frees resources + * used by the interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteInterpProc(interp) + Tcl_Interp *interp; /* Interpreter to delete. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_HashTable *hTablePtr; + AssocData *dPtr; + int i; + + /* + * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. + */ + + if (iPtr->numLevels > 0) { + panic("DeleteInterpProc called with active evals"); + } + + /* + * The interpreter should already be marked deleted; otherwise how + * did we get here? + */ + + if (!(iPtr->flags & DELETED)) { + panic("DeleteInterpProc called on interpreter not marked deleted"); + } + + /* + * Dismantle everything in the global namespace except for the + * "errorInfo" and "errorCode" variables. These remain until the + * namespace is actually destroyed, in case any errors occur. + * + * Dismantle the namespace here, before we clear the assocData. If any + * background errors occur here, they will be deleted below. + */ + + TclTeardownNamespace(iPtr->globalNsPtr); + + /* + * Tear down the math function table. + */ + + for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + ckfree((char *) Tcl_GetHashValue(hPtr)); + } + Tcl_DeleteHashTable(&iPtr->mathFuncTable); + + /* + * Invoke deletion callbacks; note that a callback can create new + * callbacks, so we iterate. + */ + + while (iPtr->assocData != (Tcl_HashTable *) NULL) { + hTablePtr = iPtr->assocData; + iPtr->assocData = (Tcl_HashTable *) NULL; + for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (dPtr->proc != NULL) { + (*dPtr->proc)(dPtr->clientData, interp); + } + ckfree((char *) dPtr); + } + Tcl_DeleteHashTable(hTablePtr); + ckfree((char *) hTablePtr); + } + + /* + * Finish deleting the global namespace. + */ + + Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); + + /* + * Free up the result *after* deleting variables, since variable + * deletion could have transferred ownership of the result string + * to Tcl. + */ + + Tcl_FreeResult(interp); + interp->result = NULL; + Tcl_DecrRefCount(iPtr->objResultPtr); + iPtr->objResultPtr = NULL; + if (iPtr->errorInfo != NULL) { + ckfree(iPtr->errorInfo); + iPtr->errorInfo = NULL; + } + if (iPtr->errorCode != NULL) { + ckfree(iPtr->errorCode); + iPtr->errorCode = NULL; + } + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + iPtr->appendResult = NULL; + } + for (i = 0; i < NUM_REGEXPS; i++) { + if (iPtr->patterns[i] == NULL) { + break; + } + ckfree(iPtr->patterns[i]); + ckfree((char *) iPtr->regexps[i]); + iPtr->regexps[i] = NULL; + } + TclFreePackageInfo(iPtr); + while (iPtr->tracePtr != NULL) { + Trace *nextPtr = iPtr->tracePtr->nextPtr; + + ckfree((char *) iPtr->tracePtr); + iPtr->tracePtr = nextPtr; + } + if (iPtr->execEnvPtr != NULL) { + TclDeleteExecEnv(iPtr->execEnvPtr); + } + Tcl_DecrRefCount(iPtr->emptyObjPtr); + iPtr->emptyObjPtr = NULL; + + ckfree((char *) iPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InterpDeleted -- + * + * Returns nonzero if the interpreter has been deleted with a call + * to Tcl_DeleteInterp. + * + * Results: + * Nonzero if the interpreter is deleted, zero otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InterpDeleted(interp) + Tcl_Interp *interp; +{ + return (((Interp *) interp)->flags & DELETED) ? 1 : 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteInterp -- + * + * Ensures that the interpreter will be deleted eventually. If there + * are no Tcl_Preserve calls in effect for this interpreter, it is + * deleted immediately, otherwise the interpreter is deleted when + * the last Tcl_Preserve is matched by a call to Tcl_Release. In either + * case, the procedure runs the currently registered deletion callbacks. + * + * Results: + * None. + * + * Side effects: + * The interpreter is marked as deleted. The caller may still use it + * safely if there are calls to Tcl_Preserve in effect for the + * interpreter, but further calls to Tcl_Eval etc in this interpreter + * will fail. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteInterp(interp) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by a previous call to Tcl_CreateInterp). */ +{ + Interp *iPtr = (Interp *) interp; + + /* + * If the interpreter has already been marked deleted, just punt. + */ + + if (iPtr->flags & DELETED) { + return; + } + + /* + * Mark the interpreter as deleted. No further evals will be allowed. + */ + + iPtr->flags |= DELETED; + + /* + * Ensure that the interpreter is eventually deleted. + */ + + Tcl_EventuallyFree((ClientData) interp, + (Tcl_FreeProc *) DeleteInterpProc); +} + +/* + *---------------------------------------------------------------------- + * + * HiddenCmdsDeleteProc -- + * + * Called on interpreter deletion to delete all the hidden + * commands in an interpreter. + * + * Results: + * None. + * + * Side effects: + * Frees up memory. + * + *---------------------------------------------------------------------- + */ + +static void +HiddenCmdsDeleteProc(clientData, interp) + ClientData clientData; /* The hidden commands hash table. */ + Tcl_Interp *interp; /* The interpreter being deleted. */ +{ + Tcl_HashTable *hiddenCmdTblPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + Command *cmdPtr; + + hiddenCmdTblPtr = (Tcl_HashTable *) clientData; + for (hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch)) { + + /* + * Cannot use Tcl_DeleteCommand because (a) the command is not + * in the command hash table, and (b) that table has already been + * deleted above. Hence we emulate what it does, below. + */ + + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + + /* + * The code here is tricky. We can't delete the hash table entry + * before invoking the deletion callback because there are cases + * where the deletion callback needs to invoke the command (e.g. + * object systems such as OTcl). However, this means that the + * callback could try to delete or rename the command. The deleted + * flag allows us to detect these cases and skip nested deletes. + */ + + if (cmdPtr->deleted) { + + /* + * Another deletion is already in progress. Remove the hash + * table entry now, but don't invoke a callback or free the + * command structure. + */ + + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; + continue; + } + cmdPtr->deleted = 1; + if (cmdPtr->deleteProc != NULL) { + (*cmdPtr->deleteProc)(cmdPtr->deleteData); + } + + /* + * Bump the command epoch counter. This will invalidate all cached + * references that refer to this command. + */ + + cmdPtr->cmdEpoch++; + + /* + * Don't use hPtr to delete the hash entry here, because it's + * possible that the deletion callback renamed the command. + * Instead, use cmdPtr->hptr, and make sure that no-one else + * has already deleted the hash entry. + */ + + if (cmdPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + } + + /* + * Now free the Command structure, unless there is another reference + * to it from a CmdName Tcl object in some ByteCode code + * sequence. In that case, delay the cleanup until all references + * are either discarded (when a ByteCode is freed) or replaced by a + * new reference (when a cached CmdName Command reference is found + * to be invalid and TclExecuteByteCode looks up the command in the + * command hashtable). + */ + + TclCleanupCommand(cmdPtr); + } + Tcl_DeleteHashTable(hiddenCmdTblPtr); + ckfree((char *) hiddenCmdTblPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_HideCommand -- + * + * Makes a command hidden so that it cannot be invoked from within + * an interpreter, only from within an ancestor. + * + * Results: + * A standard Tcl result; also leaves a message in interp->result + * if an error occurs. + * + * Side effects: + * Removes a command from the command table and create an entry + * into the hidden command table under the specified token name. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_HideCommand(interp, cmdName, hiddenCmdToken) + Tcl_Interp *interp; /* Interpreter in which to hide command. */ + char *cmdName; /* Name of command to hide. */ + char *hiddenCmdToken; /* Token name of the to-be-hidden command. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Command cmd; + Command *cmdPtr; + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + int new; + + if (iPtr->flags & DELETED) { + + /* + * The interpreter is being deleted. Do not create any new + * structures, because it is not safe to modify the interpreter. + */ + + return TCL_ERROR; + } + + /* + * Disallow hiding of commands that are currently in a namespace or + * renaming (as part of hiding) into a namespace. + * + * (because the current implementation with a single global table + * and the needed uniqueness of names cause problems with namespaces) + * + * we don't need to check for "::" in cmdName because the real check is + * on the nsPtr below. + * + * hiddenCmdToken is just a string which is not interpreted in any way. + * It may contain :: but the string is not interpreted as a namespace + * qualifier command name. Thus, hiding foo::bar to foo::bar and then + * trying to expose or invoke ::foo::bar will NOT work; but if the + * application always uses the same strings it will get consistent + * behaviour. + * + * But as we currently limit ourselves to the global namespace only + * for the source, in order to avoid potential confusion, + * lets prevent "::" in the token too. --dl + */ + + if (strstr(hiddenCmdToken, "::") != NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot use namespace qualifiers as hidden command", + "token (rename)", (char *) NULL); + return TCL_ERROR; + } + + /* + * Find the command to hide. An error is returned if cmdName can't + * be found. Look up the command only from the global namespace. + * Full path of the command must be given if using namespaces. + */ + + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, + /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); + if (cmd == (Tcl_Command) NULL) { + return TCL_ERROR; + } + cmdPtr = (Command *) cmd; + + /* + * Check that the command is really in global namespace + */ + + if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can only hide global namespace commands", + " (use rename then hide)", (char *) NULL); + return TCL_ERROR; + } + + /* + * Initialize the hidden command table if necessary. + */ + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds", + NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + hTblPtr = (Tcl_HashTable *) + ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); + Tcl_SetAssocData(interp, "tclHiddenCmds", HiddenCmdsDeleteProc, + (ClientData) hTblPtr); + } + + /* + * It is an error to move an exposed command to a hidden command with + * hiddenCmdToken if a hidden command with the name hiddenCmdToken already + * exists. + */ + + hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdToken, &new); + if (!new) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "hidden command named \"", hiddenCmdToken, "\" already exists", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Nb : This code is currently 'like' a rename to a specialy set apart + * name table. Changes here and in TclRenameCommand must + * be kept in synch untill the common parts are actually + * factorized out. + */ + + /* + * Remove the hash entry for the command from the interpreter command + * table. This is like deleting the command, so bump its command epoch; + * this invalidates any cached references that point to the command. + */ + + if (cmdPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = (Tcl_HashEntry *) NULL; + cmdPtr->cmdEpoch++; + } + + /* + * Now link the hash table entry with the command structure. + * We ensured above that the nsPtr was right. + */ + + cmdPtr->hPtr = hPtr; + Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); + + /* + * If the command being hidden has a compile procedure, increment the + * interpreter's compileEpoch to invalidate its compiled code. This + * makes sure that we don't later try to execute old code compiled with + * command-specific (i.e., inline) bytecodes for the now-hidden + * command. This field is checked in Tcl_EvalObj and ObjInterpProc, + * and code whose compilation epoch doesn't match is recompiled. + */ + + if (cmdPtr->compileProc != NULL) { + iPtr->compileEpoch++; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ExposeCommand -- + * + * Makes a previously hidden command callable from inside the + * interpreter instead of only by its ancestors. + * + * Results: + * A standard Tcl result. If an error occurs, a message is left + * in interp->result. + * + * Side effects: + * Moves commands from one hash table to another. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) + Tcl_Interp *interp; /* Interpreter in which to make command + * callable. */ + char *hiddenCmdToken; /* Name of hidden command. */ + char *cmdName; /* Name of to-be-exposed command. */ +{ + Interp *iPtr = (Interp *) interp; + Command *cmdPtr; + Namespace *nsPtr; + Tcl_HashEntry *hPtr; + Tcl_HashTable *hTblPtr; + int new; + + if (iPtr->flags & DELETED) { + /* + * The interpreter is being deleted. Do not create any new + * structures, because it is not safe to modify the interpreter. + */ + + return TCL_ERROR; + } + + /* + * Check that we have a regular name for the command + * (that the user is not trying to do an expose and a rename + * (to another namespace) at the same time) + */ + + if (strstr(cmdName, "::") != NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can not expose to a namespace ", + "(use expose to toplevel, then rename)", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Find the hash table for the hidden commands; error out if there + * is none. + */ + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds", + NULL); + if (hTblPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown hidden command \"", hiddenCmdToken, + "\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Get the command from the hidden command table: + */ + + hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdToken); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown hidden command \"", hiddenCmdToken, + "\"", (char *) NULL); + return TCL_ERROR; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + + + /* + * Check that we have a true global namespace + * command (enforced by Tcl_HideCommand() but let's double + * check. (If it was not, we would not really know how to + * handle it). + */ + if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { + /* + * This case is theoritically impossible, + * we might rather panic() than 'nicely' erroring out ? + */ + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "trying to expose a non global command name space command", + (char *) NULL); + return TCL_ERROR; + } + + /* This is the global table */ + nsPtr = cmdPtr->nsPtr; + + /* + * It is an error to overwrite an existing exposed command as a result + * of exposing a previously hidden command. + */ + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new); + if (!new) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "exposed command \"", cmdName, + "\" already exists", (char *) NULL); + return TCL_ERROR; + } + + /* + * Remove the hash entry for the command from the interpreter hidden + * command table. + */ + + if (cmdPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; + } + + /* + * Now link the hash table entry with the command structure. + * This is like creating a new command, so deal with any shadowing + * of commands in the global namespace. + */ + + cmdPtr->hPtr = hPtr; + + Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); + + /* + * Not needed as we are only in the global namespace + * (but would be needed again if we supported namespace command hiding) + * + * TclResetShadowedCmdRefs(interp, cmdPtr); + */ + + + /* + * If the command being exposed has a compile procedure, increment + * interpreter's compileEpoch to invalidate its compiled code. This + * makes sure that we don't later try to execute old code compiled + * assuming the command is hidden. This field is checked in Tcl_EvalObj + * and ObjInterpProc, and code whose compilation epoch doesn't match is + * recompiled. + */ + + if (cmdPtr->compileProc != NULL) { + iPtr->compileEpoch++; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateCommand -- + * + * Define a new command in a command table. + * + * Results: + * The return value is a token for the command, which can + * be used in future calls to Tcl_GetCommandName. + * + * Side effects: + * If a command named cmdName already exists for interp, it is deleted. + * In the future, when cmdName is seen as the name of a command by + * Tcl_Eval, proc will be called. To support the bytecode interpreter, + * the command is created with a wrapper Tcl_ObjCmdProc + * (TclInvokeStringCommand) that eventially calls proc. When the + * command is deleted from the table, deleteProc will be called. + * See the manual entry for details on the calling sequence. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) + Tcl_Interp *interp; /* Token for command interpreter returned by + * a previous call to Tcl_CreateInterp. */ + char *cmdName; /* Name of command. If it contains namespace + * qualifiers, the new command is put in the + * specified namespace; otherwise it is put + * in the global namespace. */ + Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */ + ClientData clientData; /* Arbitrary value passed to string proc. */ + Tcl_CmdDeleteProc *deleteProc; + /* If not NULL, gives a procedure to call + * when this command is deleted. */ +{ + Interp *iPtr = (Interp *) interp; + Namespace *nsPtr, *dummy1, *dummy2; + Command *cmdPtr; + Tcl_HashEntry *hPtr; + char *tail; + int new, result; + + if (iPtr->flags & DELETED) { + /* + * The interpreter is being deleted. Don't create any new + * commands; it's not safe to muck with the interpreter anymore. + */ + + return (Tcl_Command) NULL; + } + + /* + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; + * otherwise, we always put it in the global namespace. + */ + + if (strstr(cmdName, "::") != NULL) { + result = TclGetNamespaceForQualName(interp, cmdName, + (Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr, + &dummy1, &dummy2, &tail); + if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) { + return (Tcl_Command) NULL; + } + } else { + nsPtr = iPtr->globalNsPtr; + tail = cmdName; + } + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); + if (!new) { + /* + * Command already exists. Delete the old one. + */ + + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); + if (!new) { + /* + * If the deletion callback recreated the command, just throw + * away the new command (if we try to delete it again, we + * could get stuck in an infinite loop). + */ + + ckfree((char*) cmdPtr); + } + } + cmdPtr = (Command *) ckalloc(sizeof(Command)); + Tcl_SetHashValue(hPtr, cmdPtr); + cmdPtr->hPtr = hPtr; + cmdPtr->nsPtr = nsPtr; + cmdPtr->refCount = 1; + cmdPtr->cmdEpoch = 0; + cmdPtr->compileProc = (CompileProc *) NULL; + cmdPtr->objProc = TclInvokeStringCommand; + cmdPtr->objClientData = (ClientData) cmdPtr; + cmdPtr->proc = proc; + cmdPtr->clientData = clientData; + cmdPtr->deleteProc = deleteProc; + cmdPtr->deleteData = clientData; + cmdPtr->deleted = 0; + cmdPtr->importRefPtr = NULL; + + /* + * We just created a command, so in its namespace and all of its parent + * namespaces, it may shadow global commands with the same name. If any + * shadowed commands are found, invalidate all cached command references + * in the affected namespaces. + */ + + TclResetShadowedCmdRefs(interp, cmdPtr); + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateObjCommand -- + * + * Define a new object-based command in a command table. + * + * Results: + * The return value is a token for the command, which can + * be used in future calls to Tcl_NameOfCommand. + * + * Side effects: + * If no command named "cmdName" already exists for interp, one is + * created. Otherwise, if a command does exist, then if the + * object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume + * Tcl_CreateCommand was called previously for the same command and + * just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we + * delete the old command. + * + * In the future, during bytecode evaluation when "cmdName" is seen as + * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based + * Tcl_ObjCmdProc proc will be called. When the command is deleted from + * the table, deleteProc will be called. See the manual entry for + * details on the calling sequence. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by previous call to Tcl_CreateInterp). */ + char *cmdName; /* Name of command. If it contains namespace + * qualifiers, the new command is put in the + * specified namespace; otherwise it is put + * in the global namespace. */ + Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with + * name. */ + ClientData clientData; /* Arbitrary value to pass to object + * procedure. */ + Tcl_CmdDeleteProc *deleteProc; + /* If not NULL, gives a procedure to call + * when this command is deleted. */ +{ + Interp *iPtr = (Interp *) interp; + Namespace *nsPtr, *dummy1, *dummy2; + Command *cmdPtr; + Tcl_HashEntry *hPtr; + char *tail; + int new, result; + + if (iPtr->flags & DELETED) { + /* + * The interpreter is being deleted. Don't create any new + * commands; it's not safe to muck with the interpreter anymore. + */ + + return (Tcl_Command) NULL; + } + + /* + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; + * otherwise, we always put it in the global namespace. + */ + + if (strstr(cmdName, "::") != NULL) { + result = TclGetNamespaceForQualName(interp, cmdName, + (Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr, + &dummy1, &dummy2, &tail); + if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) { + return (Tcl_Command) NULL; + } + } else { + nsPtr = iPtr->globalNsPtr; + tail = cmdName; + } + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); + if (!new) { + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + + /* + * Command already exists. If its object-based Tcl_ObjCmdProc is + * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the + * argument "proc". Otherwise, we delete the old command. + */ + + if (cmdPtr->objProc == TclInvokeStringCommand) { + cmdPtr->objProc = proc; + cmdPtr->objClientData = clientData; + cmdPtr->deleteProc = deleteProc; + cmdPtr->deleteData = clientData; + return (Tcl_Command) cmdPtr; + } + + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); + if (!new) { + /* + * If the deletion callback recreated the command, just throw + * away the new command (if we try to delete it again, we + * could get stuck in an infinite loop). + */ + + ckfree((char *) Tcl_GetHashValue(hPtr)); + } + } + cmdPtr = (Command *) ckalloc(sizeof(Command)); + Tcl_SetHashValue(hPtr, cmdPtr); + cmdPtr->hPtr = hPtr; + cmdPtr->nsPtr = nsPtr; + cmdPtr->refCount = 1; + cmdPtr->cmdEpoch = 0; + cmdPtr->compileProc = (CompileProc *) NULL; + cmdPtr->objProc = proc; + cmdPtr->objClientData = clientData; + cmdPtr->proc = TclInvokeObjectCommand; + cmdPtr->clientData = (ClientData) cmdPtr; + cmdPtr->deleteProc = deleteProc; + cmdPtr->deleteData = clientData; + cmdPtr->deleted = 0; + cmdPtr->importRefPtr = NULL; + + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclInvokeStringCommand -- + * + * "Wrapper" Tcl_ObjCmdProc used to call an existing string-based + * Tcl_CmdProc if no object-based procedure exists for a command. A + * pointer to this procedure is stored as the Tcl_ObjCmdProc in a + * Command structure. It simply turns around and calls the string + * Tcl_CmdProc in the Command structure. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * Besides those side effects of the called Tcl_CmdProc, + * TclInvokeStringCommand allocates and frees storage. + * + *---------------------------------------------------------------------- + */ + +int +TclInvokeStringCommand(clientData, interp, objc, objv) + ClientData clientData; /* Points to command's Command structure. */ + Tcl_Interp *interp; /* Current interpreter. */ + register int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register Command *cmdPtr = (Command *) clientData; + register int i; + int result; + + /* + * This procedure generates an argv array for the string arguments. It + * starts out with stack-allocated space but uses dynamically-allocated + * storage if needed. + */ + +#define NUM_ARGS 20 + char *(argStorage[NUM_ARGS]); + char **argv = argStorage; + + /* + * Create the string argument array "argv". Make sure argv is large + * enough to hold the objc arguments plus 1 extra for the zero + * end-of-argv word. + * THIS FAILS IF ANY ARGUMENT OBJECT CONTAINS AN EMBEDDED NULL. + */ + + if ((objc + 1) > NUM_ARGS) { + argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); + } + + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetStringFromObj(objv[i], (int *) NULL); + } + argv[objc] = 0; + + /* + * Invoke the command's string-based Tcl_CmdProc. + */ + + result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv); + + /* + * Free the argv array if malloc'ed storage was used. + */ + + if (argv != argStorage) { + ckfree((char *) argv); + } + return result; +#undef NUM_ARGS +} + +/* + *---------------------------------------------------------------------- + * + * TclInvokeObjectCommand -- + * + * "Wrapper" Tcl_CmdProc used to call an existing object-based + * Tcl_ObjCmdProc if no string-based procedure exists for a command. + * A pointer to this procedure is stored as the Tcl_CmdProc in a + * Command structure. It simply turns around and calls the object + * Tcl_ObjCmdProc in the Command structure. + * + * Results: + * A standard Tcl string result value. + * + * Side effects: + * Besides those side effects of the called Tcl_CmdProc, + * TclInvokeStringCommand allocates and frees storage. + * + *---------------------------------------------------------------------- + */ + +int +TclInvokeObjectCommand(clientData, interp, argc, argv) + ClientData clientData; /* Points to command's Command structure. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + register char **argv; /* Argument strings. */ +{ + Command *cmdPtr = (Command *) clientData; + register Tcl_Obj *objPtr; + register int i; + int length, result; + + /* + * This procedure generates an objv array for object arguments that hold + * the argv strings. It starts out with stack-allocated space but uses + * dynamically-allocated storage if needed. + */ + +#define NUM_ARGS 20 + Tcl_Obj *(argStorage[NUM_ARGS]); + register Tcl_Obj **objv = argStorage; + + /* + * Create the object argument array "objv". Make sure objv is large + * enough to hold the objc arguments plus 1 extra for the zero + * end-of-objv word. + */ + + if ((argc + 1) > NUM_ARGS) { + objv = (Tcl_Obj **) + ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); + } + + for (i = 0; i < argc; i++) { + length = strlen(argv[i]); + TclNewObj(objPtr); + TclInitStringRep(objPtr, argv[i], length); + Tcl_IncrRefCount(objPtr); + objv[i] = objPtr; + } + objv[argc] = 0; + + /* + * Invoke the command's object-based Tcl_ObjCmdProc. + */ + + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv); + + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULL BYTES. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + TCL_VOLATILE); + + /* + * Decrement the ref counts for the argument objects created above, + * then free the objv array if malloc'ed storage was used. + */ + + for (i = 0; i < argc; i++) { + objPtr = objv[i]; + Tcl_DecrRefCount(objPtr); + } + if (objv != argStorage) { + ckfree((char *) objv); + } + return result; +#undef NUM_ARGS +} + +/* + *---------------------------------------------------------------------- + * + * TclRenameCommand -- + * + * Called to give an existing Tcl command a different name. Both the + * old command name and the new command name can have "::" namespace + * qualifiers. If the new command has a different namespace context, + * the command will be moved to that namespace and will execute in + * the context of that new namespace. + * + * If the new command name is NULL or the null string, the command is + * deleted. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * If anything goes wrong, an error message is returned in the + * interpreter's result object. + * + *---------------------------------------------------------------------- + */ + +int +TclRenameCommand(interp, oldName, newName) + Tcl_Interp *interp; /* Current interpreter. */ + char *oldName; /* Existing command name. */ + char *newName; /* New command name. */ +{ + Interp *iPtr = (Interp *) interp; + char *newTail; + Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2; + Tcl_Command cmd; + Command *cmdPtr; + Tcl_HashEntry *hPtr, *oldHPtr; + int new, result; + + /* + * Find the existing command. An error is returned if cmdName can't + * be found. + */ + + cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL, + /*flags*/ 0); + cmdPtr = (Command *) cmd; + if (cmdPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ", + ((newName == NULL)||(*newName == '\0'))? "delete":"rename", + " \"", oldName, "\": command doesn't exist", (char *) NULL); + return TCL_ERROR; + } + cmdNsPtr = cmdPtr->nsPtr; + + /* + * If the new command name is NULL or empty, delete the command. Do this + * with Tcl_DeleteCommandFromToken, since we already have the command. + */ + + if ((newName == NULL) || (*newName == '\0')) { + Tcl_DeleteCommandFromToken(interp, cmd); + return TCL_OK; + } + + /* + * Make sure that the destination command does not already exist. + * The rename operation is like creating a command, so we should + * automatically create the containing namespaces just like + * Tcl_CreateCommand would. + */ + + result = TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL, + (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), + &newNsPtr, &dummy1, &dummy2, &newTail); + if (result != TCL_OK) { + return result; + } + if ((newNsPtr == NULL) || (newTail == NULL)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't rename to \"", newName, "\": bad command name", + (char *) NULL); + return TCL_ERROR; + } + if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't rename to \"", newName, + "\": command already exists", (char *) NULL); + return TCL_ERROR; + } + + + /* + * Warning: any changes done in the code here are likely + * to be needed in Tcl_HideCommand() code too. + * (until the common parts are extracted out) --dl + */ + + /* + * Put the command in the new namespace so we can check for an alias + * loop. Since we are adding a new command to a namespace, we must + * handle any shadowing of the global commands that this might create. + */ + + oldHPtr = cmdPtr->hPtr; + hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new); + Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); + cmdPtr->hPtr = hPtr; + cmdPtr->nsPtr = newNsPtr; + TclResetShadowedCmdRefs(interp, cmdPtr); + + /* + * Now check for an alias loop. If we detect one, put everything back + * the way it was and report the error. + */ + + result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr); + if (result != TCL_OK) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = oldHPtr; + cmdPtr->nsPtr = cmdNsPtr; + return result; + } + + /* + * The new command name is okay, so remove the command from its + * current namespace. This is like deleting the command, so bump + * the cmdEpoch to invalidate any cached references to the command. + */ + + Tcl_DeleteHashEntry(oldHPtr); + cmdPtr->cmdEpoch++; + + /* + * If the command being renamed has a compile procedure, increment the + * interpreter's compileEpoch to invalidate its compiled code. This + * makes sure that we don't later try to execute old code compiled for + * the now-renamed command. + */ + + if (cmdPtr->compileProc != NULL) { + iPtr->compileEpoch++; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetCommandInfo -- + * + * Modifies various information about a Tcl command. Note that + * this procedure will not change a command's namespace; use + * Tcl_RenameCommand to do that. Also, the isNativeObjectProc + * member of *infoPtr is ignored. + * + * Results: + * If cmdName exists in interp, then the information at *infoPtr + * is stored with the command in place of the current information + * and 1 is returned. If the command doesn't exist then 0 is + * returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetCommandInfo(interp, cmdName, infoPtr) + Tcl_Interp *interp; /* Interpreter in which to look + * for command. */ + char *cmdName; /* Name of desired command. */ + Tcl_CmdInfo *infoPtr; /* Where to store information about + * command. */ +{ + Tcl_Command cmd; + Command *cmdPtr; + + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, + /*flags*/ 0); + if (cmd == (Tcl_Command) NULL) { + return 0; + } + + /* + * The isNativeObjectProc and nsPtr members of *infoPtr are ignored. + */ + + cmdPtr = (Command *) cmd; + cmdPtr->proc = infoPtr->proc; + cmdPtr->clientData = infoPtr->clientData; + if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { + cmdPtr->objProc = TclInvokeStringCommand; + cmdPtr->objClientData = (ClientData) cmdPtr; + } else { + cmdPtr->objProc = infoPtr->objProc; + cmdPtr->objClientData = infoPtr->objClientData; + } + cmdPtr->deleteProc = infoPtr->deleteProc; + cmdPtr->deleteData = infoPtr->deleteData; + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandInfo -- + * + * Returns various information about a Tcl command. + * + * 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 +Tcl_GetCommandInfo(interp, cmdName, infoPtr) + Tcl_Interp *interp; /* Interpreter in which to look + * for command. */ + char *cmdName; /* Name of desired command. */ + Tcl_CmdInfo *infoPtr; /* Where to store information about + * command. */ +{ + Tcl_Command cmd; + Command *cmdPtr; + + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, + /*flags*/ 0); + if (cmd == (Tcl_Command) NULL) { + return 0; + } + + /* + * Set isNativeObjectProc 1 if objProc was registered by a call to + * Tcl_CreateObjCommand. Otherwise set it to 0. + */ + + cmdPtr = (Command *) cmd; + infoPtr->isNativeObjectProc = + (cmdPtr->objProc != TclInvokeStringCommand); + infoPtr->objProc = cmdPtr->objProc; + infoPtr->objClientData = cmdPtr->objClientData; + infoPtr->proc = cmdPtr->proc; + infoPtr->clientData = cmdPtr->clientData; + infoPtr->deleteProc = cmdPtr->deleteProc; + infoPtr->deleteData = cmdPtr->deleteData; + infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandName -- + * + * Given a token returned by Tcl_CreateCommand, this procedure + * returns the current name of the command (which may have changed + * due to renaming). + * + * Results: + * The return value is the name of the given command. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetCommandName(interp, command) + Tcl_Interp *interp; /* Interpreter containing the command. */ + Tcl_Command command; /* Token for command returned by a previous + * call to Tcl_CreateCommand. The command + * must not have been deleted. */ +{ + Command *cmdPtr = (Command *) command; + + if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) { + + /* + * This should only happen if command was "created" after the + * interpreter began to be deleted, so there isn't really any + * command. Just return an empty string. + */ + + return ""; + } + return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandFullName -- + * + * Given a token returned by, e.g., Tcl_CreateCommand or + * Tcl_FindCommand, this procedure appends to an object the command's + * full name, qualified by a sequence of parent namespace names. The + * command's fully-qualified name may have changed due to renaming. + * + * Results: + * None. + * + * Side effects: + * The command's fully-qualified name is appended to the string + * representation of objPtr. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_GetCommandFullName(interp, command, objPtr) + Tcl_Interp *interp; /* Interpreter containing the command. */ + Tcl_Command command; /* Token for command returned by a previous + * call to Tcl_CreateCommand. The command + * must not have been deleted. */ + Tcl_Obj *objPtr; /* Points to the object onto which the + * command's full name is appended. */ + +{ + Interp *iPtr = (Interp *) interp; + register Command *cmdPtr = (Command *) command; + char *name; + + /* + * Add the full name of the containing namespace, followed by the "::" + * separator, and the command name. + */ + + if (cmdPtr != NULL) { + if (cmdPtr->nsPtr != NULL) { + Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1); + if (cmdPtr->nsPtr != iPtr->globalNsPtr) { + Tcl_AppendToObj(objPtr, "::", 2); + } + } + if (cmdPtr->hPtr != NULL) { + name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); + Tcl_AppendToObj(objPtr, name, -1); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteCommand -- + * + * Remove the given command from the given interpreter. + * + * Results: + * 0 is returned if the command was deleted successfully. + * -1 is returned if there didn't exist a command by that name. + * + * Side effects: + * cmdName will no longer be recognized as a valid command for + * interp. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DeleteCommand(interp, cmdName) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by a previous Tcl_CreateInterp call). */ + char *cmdName; /* Name of command to remove. */ +{ + Tcl_Command cmd; + + /* + * Find the desired command and delete it. + */ + + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, + /*flags*/ 0); + if (cmd == (Tcl_Command) NULL) { + return -1; + } + return Tcl_DeleteCommandFromToken(interp, cmd); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteCommandFromToken -- + * + * Removes the given command from the given interpreter. This procedure + * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead + * of a command name for efficiency. + * + * Results: + * 0 is returned if the command was deleted successfully. + * -1 is returned if there didn't exist a command by that name. + * + * Side effects: + * The command specified by "cmd" will no longer be recognized as a + * valid command for "interp". + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DeleteCommandFromToken(interp, cmd) + Tcl_Interp *interp; /* Token for command interpreter returned by + * a previous call to Tcl_CreateInterp. */ + Tcl_Command cmd; /* Token for command to delete. */ +{ + Interp *iPtr = (Interp *) interp; + Command *cmdPtr = (Command *) cmd; + ImportRef *refPtr, *nextRefPtr; + Tcl_Command importCmd; + + /* + * The code here is tricky. We can't delete the hash table entry + * before invoking the deletion callback because there are cases + * where the deletion callback needs to invoke the command (e.g. + * object systems such as OTcl). However, this means that the + * callback could try to delete or rename the command. The deleted + * flag allows us to detect these cases and skip nested deletes. + */ + + if (cmdPtr->deleted) { + /* + * Another deletion is already in progress. Remove the hash + * table entry now, but don't invoke a callback or free the + * command structure. + */ + + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; + return 0; + } + + /* + * If the command being deleted has a compile procedure, increment the + * interpreter's compileEpoch to invalidate its compiled code. This + * makes sure that we don't later try to execute old code compiled with + * command-specific (i.e., inline) bytecodes for the now-deleted + * command. This field is checked in Tcl_EvalObj and ObjInterpProc, and + * code whose compilation epoch doesn't match is recompiled. + */ + + if (cmdPtr->compileProc != NULL) { + iPtr->compileEpoch++; + } + + cmdPtr->deleted = 1; + if (cmdPtr->deleteProc != NULL) { + /* + * Delete the command's client data. If this was an imported command + * created when a command was imported into a namespace, this client + * data will be a pointer to a ImportedCmdData structure describing + * the "real" command that this imported command refers to. + */ + + (*cmdPtr->deleteProc)(cmdPtr->deleteData); + } + + /* + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; + + /* + * If this command was imported into other namespaces, then imported + * commands were created that refer back to this command. Delete these + * imported commands now. + */ + + for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; + refPtr = nextRefPtr) { + nextRefPtr = refPtr->nextPtr; + importCmd = (Tcl_Command) refPtr->importedCmdPtr; + Tcl_DeleteCommandFromToken(interp, importCmd); + } + + /* + * Don't use hPtr to delete the hash entry here, because it's + * possible that the deletion callback renamed the command. + * Instead, use cmdPtr->hptr, and make sure that no-one else + * has already deleted the hash entry. + */ + + if (cmdPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + } + + /* + * Mark the Command structure as no longer valid. This allows + * TclExecuteByteCode to recognize when a Command has logically been + * deleted and a pointer to this Command structure cached in a CmdName + * object is invalid. TclExecuteByteCode will look up the command again + * in the interpreter's command hashtable. + */ + + cmdPtr->objProc = NULL; + + /* + * Now free the Command structure, unless there is another reference to + * it from a CmdName Tcl object in some ByteCode code sequence. In that + * case, delay the cleanup until all references are either discarded + * (when a ByteCode is freed) or replaced by a new reference (when a + * cached CmdName Command reference is found to be invalid and + * TclExecuteByteCode looks up the command in the command hashtable). + */ + + TclCleanupCommand(cmdPtr); + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclCleanupCommand -- + * + * This procedure frees up a Command structure unless it is still + * referenced from an interpreter's command hashtable or from a CmdName + * Tcl object representing the name of a command in a ByteCode + * instruction sequence. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed unless a reference to the Command structure still + * exists. In that case the cleanup is delayed until the command is + * deleted or when the last ByteCode referring to it is freed. + * + *---------------------------------------------------------------------- + */ + +void +TclCleanupCommand(cmdPtr) + register Command *cmdPtr; /* Points to the Command structure to + * be freed. */ +{ + cmdPtr->refCount--; + if (cmdPtr->refCount <= 0) { + ckfree((char *) cmdPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Eval -- + * + * Execute a Tcl command in a string. + * + * Results: + * The return value is one of the return codes defined in tcl.h + * (such as TCL_OK), and interp->result contains a string value + * to supplement the return code. The value of interp->result + * will persist only until the next call to Tcl_Eval or Tcl_EvalObj: + * you must copy it or lose it! + * + * Side effects: + * The string is compiled to produce a ByteCode object that holds the + * command's bytecode instructions. However, this ByteCode object is + * lost after executing the command. The command's execution will + * almost certainly have side effects. interp->termOffset is set to the + * offset of the character in "string" just after the last one + * successfully compiled or executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Eval(interp, string) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by previous call to Tcl_CreateInterp). */ + char *string; /* Pointer to TCL command to execute. */ +{ + register Tcl_Obj *cmdPtr; + int length = strlen(string); + int result; + + if (length > 0) { + /* + * Initialize a Tcl object from the command string. + */ + + TclNewObj(cmdPtr); + TclInitStringRep(cmdPtr, string, length); + Tcl_IncrRefCount(cmdPtr); + + /* + * Compile and execute the bytecodes. + */ + + result = Tcl_EvalObj(interp, cmdPtr); + + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + TCL_VOLATILE); + + /* + * Discard the Tcl object created to hold the command and its code. + */ + + Tcl_DecrRefCount(cmdPtr); + } else { + /* + * An empty string. Just reset the interpreter's result. + */ + + Tcl_ResetResult(interp); + result = TCL_OK; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalObj -- + * + * Execute Tcl commands stored in a Tcl object. These commands are + * compiled into bytecodes if necessary. + * + * Results: + * The return value is one of the return codes defined in tcl.h + * (such as TCL_OK), and the interpreter's result contains a value + * to supplement the return code. + * + * Side effects: + * The object is converted, if necessary, to a ByteCode object that + * holds the bytecode instructions for the commands. Executing the + * commands will almost certainly have side effects that depend + * on those commands. + * + * Just as in Tcl_Eval, interp->termOffset is set to the offset of the + * last character executed in the objPtr's string. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EvalObj(interp, objPtr) + Tcl_Interp *interp; /* Token for command interpreter + * (returned by a previous call to + * Tcl_CreateInterp). */ + Tcl_Obj *objPtr; /* Pointer to object containing + * commands to execute. */ +{ + register Interp *iPtr = (Interp *) interp; + int flags; /* Interp->evalFlags value when the + * procedure was called. */ + register ByteCode* codePtr; /* Tcl Internal type of bytecode. */ + int oldCount = iPtr->cmdCount; /* Used to tell whether any commands + * at all were executed. */ + int numSrcChars; + register int result; + + /* + * Reset both the interpreter's string and object results and clear out + * any error information. This makes sure that we return an empty + * result if there are no commands in the command string. + */ + + Tcl_ResetResult(interp); + + /* + * Check depth of nested calls to Tcl_Eval: if this gets too large, + * it's probably because of an infinite loop somewhere. + */ + + iPtr->numLevels++; + if (iPtr->numLevels > iPtr->maxNestingDepth) { + iPtr->numLevels--; + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); + return TCL_ERROR; + } + + /* + * On the Mac, we will never reach the default recursion limit before blowing + * the stack. So we need to do a check here. + */ + + if (TclpCheckStackSpace() == 0) { + /*NOTREACHED*/ + iPtr->numLevels--; + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); + return TCL_ERROR; + } + + /* + * If the interpreter has been deleted, return an error. + */ + + if (iPtr->flags & DELETED) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "attempt to call eval in deleted interpreter", -1); + Tcl_SetErrorCode(interp, "CORE", "IDELETE", + "attempt to call eval in deleted interpreter", (char *) NULL); + iPtr->numLevels--; + return TCL_ERROR; + } + + /* + * Get the ByteCode from the object. If it exists, make sure it hasn't + * been invalidated by, e.g., someone redefining a command with a + * compile procedure (this might make the compiled code wrong). If + * necessary, convert the object to be a ByteCode object and compile it. + * Also, if the code was compiled in/for a different interpreter, + * we recompile it. + */ + + if (objPtr->typePtr == &tclByteCodeType) { + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + + if ((codePtr->iPtr != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch)) { + tclByteCodeType.freeIntRepProc(objPtr); + } + } + if (objPtr->typePtr != &tclByteCodeType) { + /* + * First reset any error line number information. + */ + + iPtr->errorLine = 1; /* no correct line # information yet */ + result = tclByteCodeType.setFromAnyProc(interp, objPtr); + if (result != TCL_OK) { + iPtr->numLevels--; + return result; + } + } + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + + /* + * Extract then reset the compilation flags in the interpreter. + * Resetting the flags must be done after any compilation. + */ + + flags = iPtr->evalFlags; + iPtr->evalFlags = 0; + + /* + * Execute the commands. If the code was compiled from an empty string, + * don't bother executing the code. + */ + + numSrcChars = codePtr->numSrcChars; + if (numSrcChars > 0) { + /* + * Increment the code's ref count while it is being executed. If + * afterwards no references to it remain, free the code. + */ + + codePtr->refCount++; + result = TclExecuteByteCode(interp, codePtr); + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + } else { + Tcl_ResetResult(interp); + result = TCL_OK; + } + + /* + * If no commands at all were executed, check for asynchronous + * handlers so that they at least get one change to execute. + * This is needed to handle event loops written in Tcl with + * empty bodies. + */ + + if ((oldCount == iPtr->cmdCount) && (Tcl_AsyncReady())) { + result = Tcl_AsyncInvoke(interp, result); + } + + /* + * Free up any extra resources that were allocated. + */ + + iPtr->numLevels--; + if (iPtr->numLevels == 0) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } + if ((result != TCL_OK) && (result != TCL_ERROR) + && !(flags & TCL_ALLOW_EXCEPTIONS)) { + Tcl_ResetResult(interp); + if (result == TCL_BREAK) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"break\" outside of a loop", -1); + } else if (result == TCL_CONTINUE) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"continue\" outside of a loop", -1); + } else { + char buf[50]; + sprintf(buf, "command returned bad code: %d", result); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + } + result = TCL_ERROR; + } + } + + /* + * If an error occurred, record information about what was being + * executed when the error occurred. + */ + + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + char buf[200]; + char *ellipsis = ""; + char *bytes; + int length; + + /* + * Figure out how much of the command to print in the error + * message (up to a certain number of characters, or up to + * the first new-line). + * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL. + */ + + bytes = Tcl_GetStringFromObj(objPtr, &length); + length = TclMin(numSrcChars, length); + if (length > 150) { + length = 150; + ellipsis = " ..."; + } + + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + sprintf(buf, "\n while executing\n\"%.*s%s\"", + length, bytes, ellipsis); + } else { + sprintf(buf, "\n invoked from within\n\"%.*s%s\"", + length, bytes, ellipsis); + } + Tcl_AddObjErrorInfo(interp, buf, -1); + } + + /* + * Set the interpreter's termOffset member to the offset of the + * character just after the last one executed. We approximate the offset + * of the last character executed by using the number of characters + * compiled. + */ + + iPtr->termOffset = numSrcChars; + iPtr->flags &= ~ERR_ALREADY_LOGGED; + return result; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- + * + * Procedures to evaluate an expression and return its value in a + * particular form. + * + * Results: + * Each of the procedures below returns a standard Tcl result. If an + * error occurs then an error message is left in interp->result. + * Otherwise the value of the expression, in the appropriate form, is + * stored at *ptr. If the expression had a result that was + * incompatible with the desired form then an error is returned. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tcl_ExprLong(interp, string, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + char *string; /* Expression to evaluate. */ + long *ptr; /* Where to store result. */ +{ + register Tcl_Obj *exprPtr; + Tcl_Obj *resultPtr; + int length = strlen(string); + int result = TCL_OK; + + if (length > 0) { + exprPtr = Tcl_NewStringObj(string, length); + Tcl_IncrRefCount(exprPtr); + result = Tcl_ExprObj(interp, exprPtr, &resultPtr); + if (result == TCL_OK) { + /* + * Store an integer based on the expression result. + */ + + if (resultPtr->typePtr == &tclIntType) { + *ptr = resultPtr->internalRep.longValue; + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = (long) resultPtr->internalRep.doubleValue; + } else { + Tcl_SetResult(interp, + "expression didn't have numeric value", TCL_STATIC); + result = TCL_ERROR; + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } else { + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), + (int *) NULL), + TCL_VOLATILE); + } + Tcl_DecrRefCount(exprPtr); /* discard the expression object */ + } else { + /* + * An empty string. Just set the result integer to 0. + */ + + *ptr = 0; + } + return result; +} + +int +Tcl_ExprDouble(interp, string, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + char *string; /* Expression to evaluate. */ + double *ptr; /* Where to store result. */ +{ + register Tcl_Obj *exprPtr; + Tcl_Obj *resultPtr; + int length = strlen(string); + int result = TCL_OK; + + if (length > 0) { + exprPtr = Tcl_NewStringObj(string, length); + Tcl_IncrRefCount(exprPtr); + result = Tcl_ExprObj(interp, exprPtr, &resultPtr); + if (result == TCL_OK) { + /* + * Store a double based on the expression result. + */ + + if (resultPtr->typePtr == &tclIntType) { + *ptr = (double) resultPtr->internalRep.longValue; + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = resultPtr->internalRep.doubleValue; + } else { + Tcl_SetResult(interp, + "expression didn't have numeric value", TCL_STATIC); + result = TCL_ERROR; + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } else { + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), + (int *) NULL), + TCL_VOLATILE); + } + Tcl_DecrRefCount(exprPtr); /* discard the expression object */ + } else { + /* + * An empty string. Just set the result double to 0.0. + */ + + *ptr = 0.0; + } + return result; +} + +int +Tcl_ExprBoolean(interp, string, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + char *string; /* Expression to evaluate. */ + int *ptr; /* Where to store 0/1 result. */ +{ + register Tcl_Obj *exprPtr; + Tcl_Obj *resultPtr; + int length = strlen(string); + int result = TCL_OK; + + if (length > 0) { + exprPtr = Tcl_NewStringObj(string, length); + Tcl_IncrRefCount(exprPtr); + result = Tcl_ExprObj(interp, exprPtr, &resultPtr); + if (result == TCL_OK) { + /* + * Store a boolean based on the expression result. + */ + + if (resultPtr->typePtr == &tclIntType) { + *ptr = (resultPtr->internalRep.longValue != 0); + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = (resultPtr->internalRep.doubleValue != 0.0); + } else { + result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } + if (result != TCL_OK) { + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), + (int *) NULL), + TCL_VOLATILE); + } + Tcl_DecrRefCount(exprPtr); /* discard the expression object */ + } else { + /* + * An empty string. Just set the result boolean to 0 (false). + */ + + *ptr = 0; + } + return result; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj -- + * + * Procedures to evaluate an expression in an object and return its + * value in a particular form. + * + * Results: + * Each of the procedures below returns a standard Tcl result + * object. If an error occurs then an error message is left in the + * interpreter's result. Otherwise the value of the expression, in the + * appropriate form, is stored at *ptr. If the expression had a result + * that was incompatible with the desired form then an error is + * returned. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tcl_ExprLongObj(interp, objPtr, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr; /* Expression to evaluate. */ + long *ptr; /* Where to store long result. */ +{ + Tcl_Obj *resultPtr; + int result; + + result = Tcl_ExprObj(interp, objPtr, &resultPtr); + if (result == TCL_OK) { + if (resultPtr->typePtr == &tclIntType) { + *ptr = resultPtr->internalRep.longValue; + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = (long) resultPtr->internalRep.doubleValue; + } else { + result = Tcl_GetLongFromObj(interp, resultPtr, ptr); + if (result != TCL_OK) { + return result; + } + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } + return result; +} + +int +Tcl_ExprDoubleObj(interp, objPtr, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr; /* Expression to evaluate. */ + double *ptr; /* Where to store double result. */ +{ + Tcl_Obj *resultPtr; + int result; + + result = Tcl_ExprObj(interp, objPtr, &resultPtr); + if (result == TCL_OK) { + if (resultPtr->typePtr == &tclIntType) { + *ptr = (double) resultPtr->internalRep.longValue; + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = resultPtr->internalRep.doubleValue; + } else { + result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr); + if (result != TCL_OK) { + return result; + } + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } + return result; +} + +int +Tcl_ExprBooleanObj(interp, objPtr, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr; /* Expression to evaluate. */ + int *ptr; /* Where to store 0/1 result. */ +{ + Tcl_Obj *resultPtr; + int result; + + result = Tcl_ExprObj(interp, objPtr, &resultPtr); + if (result == TCL_OK) { + if (resultPtr->typePtr == &tclIntType) { + *ptr = (resultPtr->internalRep.longValue != 0); + } else if (resultPtr->typePtr == &tclDoubleType) { + *ptr = (resultPtr->internalRep.doubleValue != 0.0); + } else { + result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); + if (result != TCL_OK) { + return result; + } + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclInvoke -- + * + * Invokes a Tcl command, given an argv/argc, from either the + * exposed or the hidden sets of commands in the given interpreter. + * NOTE: The command is invoked in the current stack frame of + * the interpreter, thus it can modify local variables. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Whatever the command does. + * + *---------------------------------------------------------------------- + */ + +int +TclInvoke(interp, argc, argv, flags) + Tcl_Interp *interp; /* Where to invoke the command. */ + int argc; /* Count of args. */ + register char **argv; /* The arg strings; argv[0] is the name of + * the command to invoke. */ + int flags; /* Combination of flags controlling the + * call: TCL_INVOKE_HIDDEN and + * TCL_INVOKE_NO_UNKNOWN. */ +{ + register Tcl_Obj *objPtr; + register int i; + int length, result; + + /* + * This procedure generates an objv array for object arguments that hold + * the argv strings. It starts out with stack-allocated space but uses + * dynamically-allocated storage if needed. + */ + +#define NUM_ARGS 20 + Tcl_Obj *(objStorage[NUM_ARGS]); + register Tcl_Obj **objv = objStorage; + + /* + * Create the object argument array "objv". Make sure objv is large + * enough to hold the objc arguments plus 1 extra for the zero + * end-of-objv word. + */ + + if ((argc + 1) > NUM_ARGS) { + objv = (Tcl_Obj **) + ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); + } + + for (i = 0; i < argc; i++) { + length = strlen(argv[i]); + objv[i] = Tcl_NewStringObj(argv[i], length); + Tcl_IncrRefCount(objv[i]); + } + objv[argc] = 0; + + /* + * Use TclObjInterpProc to actually invoke the command. + */ + + result = TclObjInvoke(interp, argc, objv, flags); + + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + TCL_VOLATILE); + + /* + * Decrement the ref counts on the objv elements since we are done + * with them. + */ + + for (i = 0; i < argc; i++) { + objPtr = objv[i]; + Tcl_DecrRefCount(objPtr); + } + + /* + * Free the objv array if malloc'ed storage was used. + */ + + if (objv != objStorage) { + ckfree((char *) objv); + } + return result; +#undef NUM_ARGS +} + +/* + *---------------------------------------------------------------------- + * + * TclGlobalInvoke -- + * + * Invokes a Tcl command, given an argv/argc, from either the + * exposed or hidden sets of commands in the given interpreter. + * NOTE: The command is invoked in the global stack frame of + * the interpreter, thus it cannot see any current state on + * the stack for that interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Whatever the command does. + * + *---------------------------------------------------------------------- + */ + +int +TclGlobalInvoke(interp, argc, argv, flags) + Tcl_Interp *interp; /* Where to invoke the command. */ + int argc; /* Count of args. */ + register char **argv; /* The arg strings; argv[0] is the name of + * the command to invoke. */ + int flags; /* Combination of flags controlling the + * call: TCL_INVOKE_HIDDEN and + * TCL_INVOKE_NO_UNKNOWN. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = NULL; + result = TclInvoke(interp, argc, argv, flags); + iPtr->varFramePtr = savedVarFramePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclObjInvokeGlobal -- + * + * Object version: Invokes a Tcl command, given an objv/objc, from + * either the exposed or hidden set of commands in the given + * interpreter. + * NOTE: The command is invoked in the global stack frame of the + * interpreter, thus it cannot see any current state on the + * stack of that interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Whatever the command does. + * + *---------------------------------------------------------------------- + */ + +int +TclObjInvokeGlobal(interp, objc, objv, flags) + Tcl_Interp *interp; /* Interpreter in which command is + * to be invoked. */ + int objc; /* Count of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0] + * points to the name of the + * command to invoke. */ + int flags; /* Combination of flags controlling + * the call: TCL_INVOKE_HIDDEN and + * TCL_INVOKE_NO_UNKNOWN. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = NULL; + result = TclObjInvoke(interp, objc, objv, flags); + iPtr->varFramePtr = savedVarFramePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclObjInvoke -- + * + * Invokes a Tcl command, given an objv/objc, from either the + * exposed or the hidden sets of commands in the given interpreter. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * Whatever the command does. + * + *---------------------------------------------------------------------- + */ + +int +TclObjInvoke(interp, objc, objv, flags) + Tcl_Interp *interp; /* Interpreter in which command is + * to be invoked. */ + int objc; /* Count of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0] + * points to the name of the + * command to invoke. */ + int flags; /* Combination of flags controlling + * the call: TCL_INVOKE_HIDDEN and + * TCL_INVOKE_NO_UNKNOWN. */ +{ + register Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ + char *cmdName; /* Name of the command from objv[0]. */ + register Tcl_HashEntry *hPtr; + Tcl_Command cmd; + Command *cmdPtr; + int localObjc; /* Used to invoke "unknown" if the */ + Tcl_Obj **localObjv = NULL; /* command is not found. */ + register int i; + int length, result; + char *bytes; + + if (interp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + + if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "illegal argument vector", -1); + return TCL_ERROR; + } + + /* + * THE FOLLOWING CODE FAILS IF THE STRING REP CONTAINS NULLS. + */ + + cmdName = Tcl_GetStringFromObj(objv[0], (int *) NULL); + if (flags & TCL_INVOKE_HIDDEN) { + /* + * Find the table of hidden commands; error out if none. + */ + + hTblPtr = (Tcl_HashTable *) + Tcl_GetAssocData(interp, "tclHiddenCmds", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + badhiddenCmdToken: + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid hidden command name \"", cmdName, "\"", + (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); + + /* + * We never invoke "unknown" for hidden commands. + */ + + if (hPtr == NULL) { + goto badhiddenCmdToken; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + } else { + cmdPtr = NULL; + cmd = Tcl_FindCommand(interp, cmdName, + (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); + if (cmd != (Tcl_Command) NULL) { + cmdPtr = (Command *) cmd; + } + if (cmdPtr == NULL) { + if (!(flags & TCL_INVOKE_NO_UNKNOWN)) { + cmd = Tcl_FindCommand(interp, "unknown", + (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); + if (cmd != (Tcl_Command) NULL) { + cmdPtr = (Command *) cmd; + } + if (cmdPtr != NULL) { + localObjc = (objc + 1); + localObjv = (Tcl_Obj **) + ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc)); + localObjv[0] = Tcl_NewStringObj("unknown", -1); + Tcl_IncrRefCount(localObjv[0]); + for (i = 0; i < objc; i++) { + localObjv[i+1] = objv[i]; + } + objc = localObjc; + objv = localObjv; + } + } + + /* + * Check again if we found the command. If not, "unknown" is + * not present and we cannot help, or the caller said not to + * call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN). + */ + + if (cmdPtr == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", cmdName, "\"", + (char *) NULL); + return TCL_ERROR; + } + } + } + + /* + * Invoke the command procedure. First reset the interpreter's string + * and object results to their default empty values since they could + * have gotten changed by earlier invocations. + */ + + Tcl_ResetResult(interp); + iPtr->cmdCount++; + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); + + /* + * If an error occurred, record information about what was being + * executed when the error occurred. + */ + + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + Tcl_DString ds; + + Tcl_DStringInit(&ds); + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + Tcl_DStringAppend(&ds, "\n while invoking\n\"", -1); + } else { + Tcl_DStringAppend(&ds, "\n invoked from within\n\"", -1); + } + for (i = 0; i < objc; i++) { + bytes = Tcl_GetStringFromObj(objv[i], &length); + Tcl_DStringAppend(&ds, bytes, length); + if (i < (objc - 1)) { + Tcl_DStringAppend(&ds, " ", -1); + } else if (Tcl_DStringLength(&ds) > 100) { + Tcl_DStringSetLength(&ds, 100); + Tcl_DStringAppend(&ds, "...", -1); + break; + } + } + + Tcl_DStringAppend(&ds, "\"", -1); + Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&ds), -1); + Tcl_DStringFree(&ds); + iPtr->flags &= ~ERR_ALREADY_LOGGED; + } + + /* + * Free any locally allocated storage used to call "unknown". + */ + + if (localObjv != (Tcl_Obj **) NULL) { + ckfree((char *) localObjv); + } + return result; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_ExprString -- + * + * Evaluate an expression in a string and return its value in string + * form. + * + * Results: + * A standard Tcl result. If the result is TCL_OK, then the + * interpreter's result is set to the string value of the + * expression. If the result is TCL_OK, then interp->result + * contains an error message. + * + * Side effects: + * A Tcl object is allocated to hold a copy of the expression string. + * This expression object is passed to Tcl_ExprObj and then + * deallocated. + * + *-------------------------------------------------------------- + */ + +int +Tcl_ExprString(interp, string) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + char *string; /* Expression to evaluate. */ +{ + register Tcl_Obj *exprPtr; + Tcl_Obj *resultPtr; + int length = strlen(string); + char buf[100]; + int result = TCL_OK; + + if (length > 0) { + TclNewObj(exprPtr); + TclInitStringRep(exprPtr, string, length); + Tcl_IncrRefCount(exprPtr); + + result = Tcl_ExprObj(interp, exprPtr, &resultPtr); + if (result == TCL_OK) { + /* + * Set the interpreter's string result from the result object. + */ + + if (resultPtr->typePtr == &tclIntType) { + sprintf(buf, "%ld", resultPtr->internalRep.longValue); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } else if (resultPtr->typePtr == &tclDoubleType) { + Tcl_PrintDouble((Tcl_Interp *) NULL, + resultPtr->internalRep.doubleValue, buf); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } else { + /* + * Set interpreter's string result from the result object. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(resultPtr, (int *) NULL), + TCL_VOLATILE); + } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ + } else { + /* + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. + */ + + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), + (int *) NULL), + TCL_VOLATILE); + } + Tcl_DecrRefCount(exprPtr); /* discard the expression object */ + } else { + /* + * An empty string. Just set the interpreter's result to 0. + */ + + Tcl_SetResult(interp, "0", TCL_VOLATILE); + } + return result; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_ExprObj -- + * + * Evaluate an expression in a Tcl_Obj. + * + * Results: + * A standard Tcl object result. If the result is other than TCL_OK, + * then the interpreter's result contains an error message. If the + * result is TCL_OK, then a pointer to the expression's result value + * object is stored in resultPtrPtr. In that case, the object's ref + * count is incremented to reflect the reference returned to the + * caller; the caller is then responsible for the resulting object + * and must, for example, decrement the ref count when it is finished + * with the object. + * + * Side effects: + * Any side effects caused by subcommands in the expression, if any. + * The interpreter result is not modified unless there is an error. + * + *-------------------------------------------------------------- + */ + +int +Tcl_ExprObj(interp, objPtr, resultPtrPtr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr; /* Points to Tcl object containing + * expression to evaluate. */ + Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression + * result is stored if no errors occur. */ +{ + Interp *iPtr = (Interp *) interp; + CompileEnv compEnv; /* Compilation environment structure + * allocated in frame. */ + register ByteCode *codePtr = NULL; + /* Tcl Internal type of bytecode. + * Initialized to avoid compiler warning. */ + AuxData *auxDataPtr; + Interp dummy; + Tcl_Obj *saveObjPtr; + char *string; + int result; + int i; + + /* + * Get the ByteCode from the object. If it exists, make sure it hasn't + * been invalidated by, e.g., someone redefining a command with a + * compile procedure (this might make the compiled code wrong). If + * necessary, convert the object to be a ByteCode object and compile it. + * Also, if the code was compiled in/for a different interpreter, we + * recompile it. + * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE. + */ + + if (objPtr->typePtr == &tclByteCodeType) { + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + if ((codePtr->iPtr != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch)) { + tclByteCodeType.freeIntRepProc(objPtr); + objPtr->typePtr = (Tcl_ObjType *) NULL; + } + } + if (objPtr->typePtr != &tclByteCodeType) { + int length; + string = Tcl_GetStringFromObj(objPtr, &length); + TclInitCompileEnv(interp, &compEnv, string); + result = TclCompileExpr(interp, string, string + length, + /*flags*/ 0, &compEnv); + if (result == TCL_OK) { + /* + * If the expression yielded no instructions (e.g., was empty), + * push an integer zero object as the expressions's result. + */ + + if (compEnv.codeNext == NULL) { + int objIndex = TclObjIndexForString("0", 0, + /*allocStrRep*/ 0, /*inHeap*/ 0, &compEnv); + Tcl_Obj *objPtr = compEnv.objArrayPtr[objIndex]; + + Tcl_InvalidateStringRep(objPtr); + objPtr->internalRep.longValue = 0; + objPtr->typePtr = &tclIntType; + + TclEmitPush(objIndex, &compEnv); + } + + /* + * Add done instruction at the end of the instruction sequence. + */ + + TclEmitOpcode(INST_DONE, &compEnv); + + TclInitByteCodeObj(objPtr, &compEnv); + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + if (tclTraceCompile == 2) { + TclPrintByteCodeObj(interp, objPtr); + } + TclFreeCompileEnv(&compEnv); + } else { + /* + * Compilation errors. Decrement the ref counts on any objects + * in the object array before freeing the compilation + * environment. + */ + + for (i = 0; i < compEnv.objArrayNext; i++) { + Tcl_Obj *elemPtr = compEnv.objArrayPtr[i]; + Tcl_DecrRefCount(elemPtr); + } + + auxDataPtr = compEnv.auxDataArrayPtr; + for (i = 0; i < compEnv.auxDataArrayNext; i++) { + if (auxDataPtr->freeProc != NULL) { + auxDataPtr->freeProc(auxDataPtr->clientData); + } + auxDataPtr++; + } + TclFreeCompileEnv(&compEnv); + return result; + } + } + + /* + * Execute the expression after first saving the interpreter's result. + */ + + dummy.objResultPtr = Tcl_NewObj(); + Tcl_IncrRefCount(dummy.objResultPtr); + if (interp->freeProc == 0) { + dummy.freeProc = (Tcl_FreeProc *) 0; + dummy.result = ""; + Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, + TCL_VOLATILE); + } else { + dummy.freeProc = interp->freeProc; + dummy.result = interp->result; + interp->freeProc = (Tcl_FreeProc *) 0; + } + + saveObjPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(saveObjPtr); + + /* + * Increment the code's ref count while it is being executed. If + * afterwards no references to it remain, free the code. + */ + + codePtr->refCount++; + result = TclExecuteByteCode(interp, codePtr); + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + + /* + * If the expression evaluated successfully, store a pointer to its + * value object in resultPtrPtr then restore the old interpreter result. + * We increment the object's ref count to reflect the reference that we + * are returning to the caller. We also decrement the ref count of the + * interpreter's result object after calling Tcl_SetResult since we + * next store into that field directly. + */ + + if (result == TCL_OK) { + *resultPtrPtr = iPtr->objResultPtr; + Tcl_IncrRefCount(iPtr->objResultPtr); + + Tcl_SetResult(interp, dummy.result, + ((dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc)); + Tcl_DecrRefCount(iPtr->objResultPtr); + iPtr->objResultPtr = saveObjPtr; + } else { + Tcl_DecrRefCount(saveObjPtr); + Tcl_FreeResult((Tcl_Interp *) &dummy); + } + + Tcl_DecrRefCount(dummy.objResultPtr); + dummy.objResultPtr = NULL; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateTrace -- + * + * Arrange for a procedure to be called to trace command execution. + * + * Results: + * The return value is a token for the trace, which may be passed + * to Tcl_DeleteTrace to eliminate the trace. + * + * Side effects: + * From now on, proc will be called just before a command procedure + * is called to execute a Tcl command. Calls to proc will have the + * following form: + * + * void + * proc(clientData, interp, level, command, cmdProc, cmdClientData, + * argc, argv) + * ClientData clientData; + * Tcl_Interp *interp; + * int level; + * char *command; + * int (*cmdProc)(); + * ClientData cmdClientData; + * int argc; + * char **argv; + * { + * } + * + * The clientData and interp arguments to proc will be the same + * as the corresponding arguments to this procedure. Level gives + * the nesting level of command interpretation for this interpreter + * (0 corresponds to top level). Command gives the ASCII text of + * the raw command, cmdProc and cmdClientData give the procedure that + * will be called to process the command and the ClientData value it + * will receive, and argc and argv give the arguments to the + * command, after any argument parsing and substitution. Proc + * does not return a value. + * + *---------------------------------------------------------------------- + */ + +Tcl_Trace +Tcl_CreateTrace(interp, level, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which to create trace. */ + int level; /* Only call proc for commands at nesting + * level<=argument level (1=>top level). */ + Tcl_CmdTraceProc *proc; /* Procedure to call before executing each + * command. */ + ClientData clientData; /* Arbitrary value word to pass to proc. */ +{ + register Trace *tracePtr; + register Interp *iPtr = (Interp *) interp; + + /* + * Invalidate existing compiled code for this interpreter and arrange + * (by setting the DONT_COMPILE_CMDS_INLINE flag) that when compiling + * new code, no commands will be compiled inline (i.e., into an inline + * sequence of instructions). We do this because commands that were + * compiled inline will never result in a command trace being called. + */ + + iPtr->compileEpoch++; + iPtr->flags |= DONT_COMPILE_CMDS_INLINE; + + tracePtr = (Trace *) ckalloc(sizeof(Trace)); + tracePtr->level = level; + tracePtr->proc = proc; + tracePtr->clientData = clientData; + tracePtr->nextPtr = iPtr->tracePtr; + iPtr->tracePtr = tracePtr; + + return (Tcl_Trace) tracePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteTrace -- + * + * Remove a trace. + * + * Results: + * None. + * + * Side effects: + * From now on there will be no more calls to the procedure given + * in trace. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteTrace(interp, trace) + Tcl_Interp *interp; /* Interpreter that contains trace. */ + Tcl_Trace trace; /* Token for trace (returned previously by + * Tcl_CreateTrace). */ +{ + register Interp *iPtr = (Interp *) interp; + register Trace *tracePtr = (Trace *) trace; + register Trace *tracePtr2; + + if (iPtr->tracePtr == tracePtr) { + iPtr->tracePtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + } else { + for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL; + tracePtr2 = tracePtr2->nextPtr) { + if (tracePtr2->nextPtr == tracePtr) { + tracePtr2->nextPtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + break; + } + } + } + + if (iPtr->tracePtr == NULL) { + /* + * When compiling new code, allow commands to be compiled inline. + */ + + iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AddErrorInfo -- + * + * Add information to the "errorInfo" variable that describes the + * current error. + * + * Results: + * None. + * + * Side effects: + * The contents of message are added to the "errorInfo" variable. + * If Tcl_Eval has been called since the current value of errorInfo + * was set, errorInfo is cleared before adding the new message. + * If we are just starting to log an error, errorInfo is initialized + * from the error message in the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AddErrorInfo(interp, message) + Tcl_Interp *interp; /* Interpreter to which error information + * pertains. */ + char *message; /* Message to record. */ +{ + Tcl_AddObjErrorInfo(interp, message, -1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AddObjErrorInfo -- + * + * Add information to the "errorInfo" variable that describes the + * current error. This routine differs from Tcl_AddErrorInfo by + * taking a byte pointer and length. + * + * Results: + * None. + * + * Side effects: + * "length" bytes from "message" are added to the "errorInfo" variable. + * If "length" is negative, use bytes up to the first NULL byte. + * If Tcl_EvalObj has been called since the current value of errorInfo + * was set, errorInfo is cleared before adding the new message. + * If we are just starting to log an error, errorInfo is initialized + * from the error message in the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AddObjErrorInfo(interp, message, length) + Tcl_Interp *interp; /* Interpreter to which error information + * pertains. */ + char *message; /* Points to the first byte of an array of + * bytes of the message. */ + register int length; /* The number of bytes in the message. + * If < 0, then append all bytes up to a + * NULL byte. */ +{ + register Interp *iPtr = (Interp *) interp; + Tcl_Obj *namePtr, *messagePtr; + + /* + * If we are just starting to log an error, errorInfo is initialized + * from the error message in the interpreter's result. + */ + + namePtr = Tcl_NewStringObj("errorInfo", -1); + Tcl_IncrRefCount(namePtr); + + if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */ + iPtr->flags |= ERR_IN_PROGRESS; + + if (iPtr->result[0] == 0) { + (void) Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, + iPtr->objResultPtr, TCL_GLOBAL_ONLY); + } else { /* use the string result */ + Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result, + TCL_GLOBAL_ONLY); + } + + /* + * If the errorCode variable wasn't set by the code that generated + * the error, set it to "NONE". + */ + + if (!(iPtr->flags & ERROR_CODE_SET)) { + (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE", + TCL_GLOBAL_ONLY); + } + } + + /* + * Now append "message" to the end of errorInfo. + */ + + if (length != 0) { + messagePtr = Tcl_NewStringObj(message, length); + Tcl_IncrRefCount(messagePtr); + Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr, + (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); + Tcl_DecrRefCount(messagePtr); /* free msg object appended above */ + } + + Tcl_DecrRefCount(namePtr); /* free the name object */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VarEval -- + * + * Given a variable number of string arguments, concatenate them + * all together and execute the result as a Tcl command. + * + * Results: + * A standard Tcl return result. An error message or other + * result may be left in interp->result. + * + * Side effects: + * Depends on what was done by the command. + * + *---------------------------------------------------------------------- + */ + /* VARARGS2 */ /* ARGSUSED */ +int +Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) +{ + va_list argList; + Tcl_DString buf; + char *string; + Tcl_Interp *interp; + int result; + + /* + * Copy the strings one after the other into a single larger + * string. Use stack-allocated space for small commands, but if + * the command gets too large than call ckalloc to create the + * space. + */ + + interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + Tcl_DStringInit(&buf); + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + Tcl_DStringAppend(&buf, string, -1); + } + va_end(argList); + + result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); + Tcl_DStringFree(&buf); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GlobalEval -- + * + * Evaluate a command at global level in an interpreter. + * + * Results: + * A standard Tcl result is returned, and interp->result is + * modified accordingly. + * + * Side effects: + * The command string is executed in interp, and the execution + * is carried out in the variable context of global level (no + * procedures active), just as if an "uplevel #0" command were + * being executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GlobalEval(interp, command) + Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ + char *command; /* Command to evaluate. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = NULL; + result = Tcl_Eval(interp, command); + iPtr->varFramePtr = savedVarFramePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GlobalEvalObj -- + * + * Execute Tcl commands stored in a Tcl object at global level in + * an interpreter. These commands are compiled into bytecodes if + * necessary. + * + * Results: + * A standard Tcl result is returned, and the interpreter's result + * contains a Tcl object value to supplement the return code. + * + * Side effects: + * The object is converted, if necessary, to a ByteCode object that + * holds the bytecode instructions for the commands. Executing the + * commands will almost certainly have side effects that depend on + * those commands. + * + * The commands are executed in interp, and the execution + * is carried out in the variable context of global level (no + * procedures active), just as if an "uplevel #0" command were + * being executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GlobalEvalObj(interp, objPtr) + Tcl_Interp *interp; /* Interpreter in which to evaluate + * commands. */ + Tcl_Obj *objPtr; /* Pointer to object containing commands + * to execute. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = NULL; + result = Tcl_EvalObj(interp, objPtr); + iPtr->varFramePtr = savedVarFramePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetRecursionLimit -- + * + * Set the maximum number of recursive calls that may be active + * for an interpreter at once. + * + * Results: + * The return value is the old limit on nesting for interp. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetRecursionLimit(interp, depth) + Tcl_Interp *interp; /* Interpreter whose nesting limit + * is to be set. */ + int depth; /* New value for maximimum depth. */ +{ + Interp *iPtr = (Interp *) interp; + int old; + + old = iPtr->maxNestingDepth; + if (depth > 0) { + iPtr->maxNestingDepth = depth; + } + return old; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AllowExceptions -- + * + * Sets a flag in an interpreter so that exceptions can occur + * in the next call to Tcl_Eval without them being turned into + * errors. + * + * Results: + * None. + * + * Side effects: + * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's + * evalFlags structure. See the reference documentation for + * more details. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AllowExceptions(interp) + Tcl_Interp *interp; /* Interpreter in which to set flag. */ +{ + Interp *iPtr = (Interp *) interp; + + iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; +} + |