diff options
Diffstat (limited to 'contrib/tcl/generic/tclBasic.c')
| -rw-r--r-- | contrib/tcl/generic/tclBasic.c | 1826 |
1 files changed, 1826 insertions, 0 deletions
diff --git a/contrib/tcl/generic/tclBasic.c b/contrib/tcl/generic/tclBasic.c new file mode 100644 index 0000000..e081402 --- /dev/null +++ b/contrib/tcl/generic/tclBasic.c @@ -0,0 +1,1826 @@ +/* + * 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-1996 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.210 96/03/25 17:17:54 + */ + +#include "tclInt.h" +#ifndef TCL_GENERIC_ONLY +# include "tclPort.h" +#endif +#include "patchlevel.h" + +/* + * Static procedures in this file: + */ + +static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); + +/* + * The following structure defines all of the commands in the Tcl core, + * and the C procedures that execute them. + */ + +typedef struct { + char *name; /* Name of command. */ + Tcl_CmdProc *proc; /* Procedure that executes command. */ +} CmdInfo; + +/* + * Built-in commands, and the procedures associated with them: + */ + +static CmdInfo builtInCmds[] = { + /* + * Commands in the generic core: + */ + + {"append", Tcl_AppendCmd}, + {"array", Tcl_ArrayCmd}, + {"break", Tcl_BreakCmd}, + {"case", Tcl_CaseCmd}, + {"catch", Tcl_CatchCmd}, + {"clock", Tcl_ClockCmd}, + {"concat", Tcl_ConcatCmd}, + {"continue", Tcl_ContinueCmd}, + {"error", Tcl_ErrorCmd}, + {"eval", Tcl_EvalCmd}, + {"exit", Tcl_ExitCmd}, + {"expr", Tcl_ExprCmd}, + {"fileevent", Tcl_FileEventCmd}, + {"for", Tcl_ForCmd}, + {"foreach", Tcl_ForeachCmd}, + {"format", Tcl_FormatCmd}, + {"global", Tcl_GlobalCmd}, + {"history", Tcl_HistoryCmd}, + {"if", Tcl_IfCmd}, + {"incr", Tcl_IncrCmd}, + {"info", Tcl_InfoCmd}, + {"interp", Tcl_InterpCmd}, + {"join", Tcl_JoinCmd}, + {"lappend", Tcl_LappendCmd}, + {"lindex", Tcl_LindexCmd}, + {"linsert", Tcl_LinsertCmd}, + {"list", Tcl_ListCmd}, + {"llength", Tcl_LlengthCmd}, + {"load", Tcl_LoadCmd}, + {"lrange", Tcl_LrangeCmd}, + {"lreplace", Tcl_LreplaceCmd}, + {"lsearch", Tcl_LsearchCmd}, + {"lsort", Tcl_LsortCmd}, + {"package", Tcl_PackageCmd}, + {"proc", Tcl_ProcCmd}, + {"regexp", Tcl_RegexpCmd}, + {"regsub", Tcl_RegsubCmd}, + {"rename", Tcl_RenameCmd}, + {"return", Tcl_ReturnCmd}, + {"scan", Tcl_ScanCmd}, + {"set", Tcl_SetCmd}, + {"split", Tcl_SplitCmd}, + {"string", Tcl_StringCmd}, + {"subst", Tcl_SubstCmd}, + {"switch", Tcl_SwitchCmd}, + {"trace", Tcl_TraceCmd}, + {"unset", Tcl_UnsetCmd}, + {"uplevel", Tcl_UplevelCmd}, + {"upvar", Tcl_UpvarCmd}, + {"while", Tcl_WhileCmd}, + + /* + * Commands in the UNIX core: + */ + +#ifndef TCL_GENERIC_ONLY + {"after", Tcl_AfterCmd}, + {"cd", Tcl_CdCmd}, + {"close", Tcl_CloseCmd}, + {"eof", Tcl_EofCmd}, + {"fblocked", Tcl_FblockedCmd}, + {"fconfigure", Tcl_FconfigureCmd}, + {"file", Tcl_FileCmd}, + {"flush", Tcl_FlushCmd}, + {"gets", Tcl_GetsCmd}, + {"glob", Tcl_GlobCmd}, + {"open", Tcl_OpenCmd}, + {"pid", Tcl_PidCmd}, + {"puts", Tcl_PutsCmd}, + {"pwd", Tcl_PwdCmd}, + {"read", Tcl_ReadCmd}, + {"seek", Tcl_SeekCmd}, + {"socket", Tcl_SocketCmd}, + {"tell", Tcl_TellCmd}, + {"time", Tcl_TimeCmd}, + {"update", Tcl_UpdateCmd}, + {"vwait", Tcl_VwaitCmd}, + {"unsupported0", TclUnsupported0Cmd}, + +#ifndef MAC_TCL + {"exec", Tcl_ExecCmd}, + {"source", Tcl_SourceCmd}, +#endif + +#ifdef MAC_TCL + {"beep", Tcl_MacBeepCmd}, + {"cp", Tcl_CpCmd}, + {"echo", Tcl_EchoCmd}, + {"ls", Tcl_LsCmd}, + {"mkdir", Tcl_MkdirCmd}, + {"mv", Tcl_MvCmd}, + {"rm", Tcl_RmCmd}, + {"rmdir", Tcl_RmdirCmd}, + {"source", Tcl_MacSourceCmd}, +#endif /* MAC_TCL */ + +#endif /* TCL_GENERIC_ONLY */ + {NULL, (Tcl_CmdProc *) NULL} +}; + +/* + *---------------------------------------------------------------------- + * + * 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; + Tcl_Channel chan; + int i; + + iPtr = (Interp *) ckalloc(sizeof(Interp)); + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + iPtr->errorLine = 0; + Tcl_InitHashTable(&iPtr->commandTable, TCL_STRING_KEYS); + Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); + Tcl_InitHashTable(&iPtr->globalTable, 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->numEvents = 0; + iPtr->events = NULL; + iPtr->curEvent = 0; + iPtr->curEventNum = 0; + iPtr->revPtr = NULL; + iPtr->historyFirst = NULL; + iPtr->revDisables = 1; + iPtr->evalFirst = iPtr->evalLast = 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; + strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT); + iPtr->pdPrec = DEFAULT_PD_PREC; + iPtr->cmdCount = 0; + iPtr->noEval = 0; + iPtr->evalFlags = 0; + iPtr->scriptFile = NULL; + iPtr->flags = 0; + iPtr->tracePtr = NULL; + iPtr->assocData = (Tcl_HashTable *) NULL; + iPtr->resultSpace[0] = 0; + + /* + * Create the built-in 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). + */ + + for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { + int new; + Tcl_HashEntry *hPtr; + + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, + cmdInfoPtr->name, &new); + if (new) { + cmdPtr = (Command *) ckalloc(sizeof(Command)); + cmdPtr->hPtr = hPtr; + cmdPtr->proc = cmdInfoPtr->proc; + cmdPtr->clientData = (ClientData) NULL; + cmdPtr->deleteProc = NULL; + cmdPtr->deleteData = (ClientData) NULL; + cmdPtr->deleted = 0; + Tcl_SetHashValue(hPtr, cmdPtr); + } + } + +#ifndef TCL_GENERIC_ONLY + TclSetupEnv((Tcl_Interp *) iPtr); +#endif + + /* + * Do Safe-Tcl init stuff + */ + + (void) TclInterpInit((Tcl_Interp *)iPtr); + + /* + * Set up variables such as tcl_library and tcl_precision. + */ + + 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_WRITES|TCL_TRACE_UNSETS, + TclPrecTraceProc, (ClientData) NULL); + + /* + * Register Tcl's version number. + */ + + Tcl_PkgProvide((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION); + + /* + * Add the standard channels. + */ + + chan = Tcl_GetStdChannel(TCL_STDIN); + if (chan != (Tcl_Channel) NULL) { + Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan); + } + chan = Tcl_GetStdChannel(TCL_STDOUT); + if (chan != (Tcl_Channel) NULL) { + Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan); + } + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan != (Tcl_Channel) NULL) { + Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan); + } + + return (Tcl_Interp *) iPtr; +} + +/* + *-------------------------------------------------------------- + * + * 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; + int i; + Tcl_HashTable *hTablePtr; + AssocData *dPtr; + + /* + * 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"); + } + + /* + * First delete all the commands. There's a special hack here + * because "tkerror" is just a synonym for "bgerror" (they share + * a Command structure). Just delete the hash table entry for + * "tkerror" without invoking its callback or cleaning up its + * Command structure. + */ + + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "tkerror"); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search)) { + Tcl_DeleteCommand(interp, + Tcl_GetHashKey(&iPtr->commandTable, hPtr)); + } + Tcl_DeleteHashTable(&iPtr->commandTable); + 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); + } + + /* + * Delete all global variables: + */ + + TclDeleteVars(iPtr, &iPtr->globalTable); + + /* + * 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; + + if (iPtr->errorInfo != NULL) { + ckfree(iPtr->errorInfo); + iPtr->errorInfo = NULL; + } + if (iPtr->errorCode != NULL) { + ckfree(iPtr->errorCode); + iPtr->errorCode = NULL; + } + if (iPtr->events != NULL) { + int i; + + for (i = 0; i < iPtr->numEvents; i++) { + ckfree(iPtr->events[i].command); + } + ckfree((char *) iPtr->events); + iPtr->events = NULL; + } + while (iPtr->revPtr != NULL) { + HistoryRev *nextPtr = iPtr->revPtr->nextPtr; + + ckfree(iPtr->revPtr->newBytes); + ckfree((char *) iPtr->revPtr); + iPtr->revPtr = nextPtr; + } + 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; + } + + 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); +} + +/* + *---------------------------------------------------------------------- + * + * 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_NameOfCommand. + * + * 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. 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. */ + Tcl_CmdProc *proc; /* Command procedure to associate with + * cmdName. */ + ClientData clientData; /* Arbitrary one-word value to pass to proc. */ + Tcl_CmdDeleteProc *deleteProc; + /* If not NULL, gives a procedure to call when + * this command is deleted. */ +{ + Interp *iPtr = (Interp *) interp; + Command *cmdPtr; + Tcl_HashEntry *hPtr; + int new; + + /* + * The code below was added in 11/95 to preserve backwards compatibility + * when "tkerror" was renamed "bgerror": if anyone attempts to define + * "tkerror" as a command, it is actually created as "bgerror". This + * code should eventually be removed. + */ + + if ((cmdName[0] == 't') && (strcmp(cmdName, "tkerror") == 0)) { + cmdName = "bgerror"; + } + + 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; + } + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new); + if (!new) { + /* + * Command already exists: delete the old one. + */ + + Tcl_DeleteCommand(interp, Tcl_GetHashKey(&iPtr->commandTable, hPtr)); + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new); + if (!new) { + /* + * Drat. The stupid 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->proc = proc; + cmdPtr->clientData = clientData; + cmdPtr->deleteProc = deleteProc; + cmdPtr->deleteData = clientData; + cmdPtr->deleted = 0; + + /* + * The code below provides more backwards compatibility for the + * renaming of "tkerror" to "bgerror". Like the code above, this + * code should eventually become unnecessary. + */ + + if ((cmdName[0] == 'b') && (strcmp(cmdName, "bgerror") == 0)) { + /* + * We're currently creating the "bgerror" command; create + * a "tkerror" command that shares the same Command structure. + */ + + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, "tkerror", &new); + Tcl_SetHashValue(hPtr, cmdPtr); + } + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetCommandInfo -- + * + * Modifies various information about a Tcl command. + * + * 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_HashEntry *hPtr; + Command *cmdPtr; + + hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName); + if (hPtr == NULL) { + return 0; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + cmdPtr->proc = infoPtr->proc; + cmdPtr->clientData = infoPtr->clientData; + 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_HashEntry *hPtr; + Command *cmdPtr; + + hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName); + if (hPtr == NULL) { + return 0; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + infoPtr->proc = cmdPtr->proc; + infoPtr->clientData = cmdPtr->clientData; + infoPtr->deleteProc = cmdPtr->deleteProc; + infoPtr->deleteData = cmdPtr->deleteData; + 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 the command, returned by a + * previous call to Tcl_CreateCommand. + * The command must not have been deleted. */ +{ + Command *cmdPtr = (Command *) command; + Interp *iPtr = (Interp *) interp; + + 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(&iPtr->commandTable, cmdPtr->hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * 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 call to Tcl_CreateInterp). */ + char *cmdName; /* Name of command to remove. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr, *tkErrorHPtr; + Command *cmdPtr; + + /* + * The code below was added in 11/95 to preserve backwards compatibility + * when "tkerror" was renamed "bgerror": if anyone attempts to delete + * "tkerror", delete both it and "bgerror". This code should + * eventually be removed. + */ + + if ((cmdName[0] == 't') && (strcmp(cmdName, "tkerror") == 0)) { + cmdName = "bgerror"; + } + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName); + if (hPtr == NULL) { + return -1; + } + 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; + return 0; + } + cmdPtr->deleted = 1; + if (cmdPtr->deleteProc != NULL) { + (*cmdPtr->deleteProc)(cmdPtr->deleteData); + } + + /* + * The code below provides more backwards compatibility for the + * renaming of "tkerror" to "bgerror". Like the code above, this + * code should eventually become unnecessary. + */ + + if ((cmdName[0] == 'b') && (strcmp(cmdName, "bgerror") == 0)) { + + /* + * When the "bgerror" command is deleted, delete "tkerror" + * as well. It shared the same Command structure as "bgerror", + * so all we have to do is throw away the hash table entry. + * NOTE: we have to be careful since tkerror may already have + * been deleted before bgerror. + */ + + tkErrorHPtr = Tcl_FindHashEntry(&iPtr->commandTable, "tkerror"); + if (tkErrorHPtr != (Tcl_HashEntry *) NULL) { + Tcl_DeleteHashEntry(tkErrorHPtr); + } + } + + /* + * 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); + } + ckfree((char *) cmdPtr); + + return 0; +} + +/* + *----------------------------------------------------------------- + * + * Tcl_Eval -- + * + * Parse and execute a command in the Tcl language. + * + * Results: + * The return value is one of the return codes defined in tcl.hd + * (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: copy it or + * lose it! *TermPtr is filled in with the character just after + * the last one that was part of the command (usually a NULL + * character or a closing bracket). + * + * Side effects: + * Almost certainly; depends on the command. + * + *----------------------------------------------------------------- + */ + +int +Tcl_Eval(interp, cmd) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by a previous call to Tcl_CreateInterp). */ + char *cmd; /* Pointer to TCL command to interpret. */ +{ + /* + * The storage immediately below is used to generate a copy + * of the command, after all argument substitutions. Pv will + * contain the argv values passed to the command procedure. + */ + +# define NUM_CHARS 200 + char copyStorage[NUM_CHARS]; + ParseValue pv; + char *oldBuffer; + + /* + * This procedure generates an (argv, argc) array for the command, + * It starts out with stack-allocated space but uses dynamically- + * allocated storage to increase it if needed. + */ + +# define NUM_ARGS 10 + char *(argStorage[NUM_ARGS]); + char **argv = argStorage; + int argc; + int argSize = NUM_ARGS; + + register char *src; /* Points to current character + * in cmd. */ + char termChar; /* Return when this character is found + * (either ']' or '\0'). Zero means + * that newlines terminate commands. */ + int flags; /* Interp->evalFlags value when the + * procedure was called. */ + int result; /* Return value. */ + register Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + Command *cmdPtr; + char *termPtr; /* Contains character just after the + * last one in the command. */ + char *cmdStart; /* Points to first non-blank char. in + * command (used in calling trace + * procedures). */ + char *ellipsis = ""; /* Used in setting errorInfo variable; + * set to "..." to indicate that not + * all of offending command is included + * in errorInfo. "" means that the + * command is all there. */ + register Trace *tracePtr; + int oldCount = iPtr->cmdCount; /* Used to tell whether any commands + * at all were executed. */ + + /* + * Initialize the result to an empty string 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_FreeResult((Tcl_Interp *) iPtr); + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + result = TCL_OK; + + /* + * Initialize the area in which command copies will be assembled. + */ + + pv.buffer = copyStorage; + pv.end = copyStorage + NUM_CHARS - 1; + pv.expandProc = TclExpandParseValue; + pv.clientData = (ClientData) NULL; + + src = cmd; + flags = iPtr->evalFlags; + iPtr->evalFlags = 0; + if (flags & TCL_BRACKET_TERM) { + termChar = ']'; + } else { + termChar = 0; + } + termPtr = src; + cmdStart = src; + + /* + * 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--; + iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)"; + iPtr->termPtr = termPtr; + return TCL_ERROR; + } + + /* + * There can be many sub-commands (separated by semi-colons or + * newlines) in one command string. This outer loop iterates over + * individual commands. + */ + + while (*src != termChar) { + + /* + * If we have been deleted, return an error preventing further + * evals. + */ + + if (iPtr->flags & DELETED) { + Tcl_ResetResult(interp); + interp->result = "attempt to call eval in deleted interpreter"; + Tcl_SetErrorCode(interp, "CORE", "IDELETE", interp->result, + (char *) NULL); + iPtr->numLevels--; + return TCL_ERROR; + } + + iPtr->flags &= ~(ERR_IN_PROGRESS | ERROR_CODE_SET); + + /* + * Skim off leading white space and semi-colons, and skip + * comments. + */ + + while (1) { + register char c = *src; + + if ((CHAR_TYPE(c) != TCL_SPACE) && (c != ';') && (c != '\n')) { + break; + } + src += 1; + } + if (*src == '#') { + while (*src != 0) { + if (*src == '\\') { + int length; + Tcl_Backslash(src, &length); + src += length; + } else if (*src == '\n') { + src++; + termPtr = src; + break; + } else { + src++; + } + } + continue; + } + cmdStart = src; + + /* + * Parse the words of the command, generating the argc and + * argv for the command procedure. May have to call + * TclParseWords several times, expanding the argv array + * between calls. + */ + + pv.next = oldBuffer = pv.buffer; + argc = 0; + while (1) { + int newArgs, maxArgs; + char **newArgv; + int i; + + /* + * Note: the "- 2" below guarantees that we won't use the + * last two argv slots here. One is for a NULL pointer to + * mark the end of the list, and the other is to leave room + * for inserting the command name "unknown" as the first + * argument (see below). + */ + + maxArgs = argSize - argc - 2; + result = TclParseWords((Tcl_Interp *) iPtr, src, flags, + maxArgs, &termPtr, &newArgs, &argv[argc], &pv); + src = termPtr; + if (result != TCL_OK) { + ellipsis = "..."; + goto done; + } + + /* + * Careful! Buffer space may have gotten reallocated while + * parsing words. If this happened, be sure to update all + * of the older argv pointers to refer to the new space. + */ + + if (oldBuffer != pv.buffer) { + int i; + + for (i = 0; i < argc; i++) { + argv[i] = pv.buffer + (argv[i] - oldBuffer); + } + oldBuffer = pv.buffer; + } + argc += newArgs; + if (newArgs < maxArgs) { + argv[argc] = (char *) NULL; + break; + } + + /* + * Args didn't all fit in the current array. Make it bigger. + */ + + argSize *= 2; + newArgv = (char **) + ckalloc((unsigned) argSize * sizeof(char *)); + for (i = 0; i < argc; i++) { + newArgv[i] = argv[i]; + } + if (argv != argStorage) { + ckfree((char *) argv); + } + argv = newArgv; + } + + /* + * If this is an empty command (or if we're just parsing + * commands without evaluating them), then just skip to the + * next command. + */ + + if ((argc == 0) || iPtr->noEval) { + continue; + } + argv[argc] = NULL; + + /* + * Save information for the history module, if needed. + */ + + if (flags & TCL_RECORD_BOUNDS) { + iPtr->evalFirst = cmdStart; + iPtr->evalLast = src-1; + } + + /* + * Find the procedure to execute this command. If there isn't + * one, then see if there is a command "unknown". If so, + * invoke it instead, passing it the words of the original + * command as arguments. + */ + + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[0]); + if (hPtr == NULL) { + int i; + + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "unknown"); + if (hPtr == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "invalid command name \"", + argv[0], "\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + for (i = argc; i >= 0; i--) { + argv[i+1] = argv[i]; + } + argv[0] = "unknown"; + argc++; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + + /* + * Call trace procedures, if any. + */ + + for (tracePtr = iPtr->tracePtr; tracePtr != NULL; + tracePtr = tracePtr->nextPtr) { + char saved; + + if (tracePtr->level < iPtr->numLevels) { + continue; + } + saved = *src; + *src = 0; + (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, + cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv); + *src = saved; + } + + /* + * At long last, invoke the command procedure. Reset the + * result to its default empty value first (it could have + * gotten changed by earlier commands in the same command + * string). + */ + + iPtr->cmdCount++; + Tcl_FreeResult(iPtr); + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv); + if (Tcl_AsyncReady()) { + result = Tcl_AsyncInvoke(interp, result); + } + if (result != TCL_OK) { + break; + } + } + + done: + + /* + * 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 (I'm not sure that loops like this are a good + * idea, * but...). + */ + + if ((oldCount == iPtr->cmdCount) && (Tcl_AsyncReady())) { + result = Tcl_AsyncInvoke(interp, result); + } + + /* + * Free up any extra resources that were allocated. + */ + + if (pv.buffer != copyStorage) { + ckfree((char *) pv.buffer); + } + if (argv != argStorage) { + ckfree((char *) argv); + } + 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) { + iPtr->result = "invoked \"break\" outside of a loop"; + } else if (result == TCL_CONTINUE) { + iPtr->result = "invoked \"continue\" outside of a loop"; + } else { + iPtr->result = iPtr->resultSpace; + sprintf(iPtr->resultSpace, "command returned bad code: %d", + result); + } + 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)) { + int numChars; + register char *p; + + /* + * Compute the line number where the error occurred. + */ + + iPtr->errorLine = 1; + for (p = cmd; p != cmdStart; p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + + /* + * 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). + */ + + numChars = src - cmdStart; + if (numChars > (NUM_CHARS-50)) { + numChars = NUM_CHARS-50; + ellipsis = " ..."; + } + + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + sprintf(copyStorage, "\n while executing\n\"%.*s%s\"", + numChars, cmdStart, ellipsis); + } else { + sprintf(copyStorage, "\n invoked from within\n\"%.*s%s\"", + numChars, cmdStart, ellipsis); + } + Tcl_AddErrorInfo(interp, copyStorage); + iPtr->flags &= ~ERR_ALREADY_LOGGED; + } else { + iPtr->flags &= ~ERR_ALREADY_LOGGED; + } + iPtr->termPtr = termPtr; + 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 the trace. */ + int level; /* Only call proc for commands at nesting level + * <= level (1 => top level). */ + Tcl_CmdTraceProc *proc; /* Procedure to call before executing each + * command. */ + ClientData clientData; /* Arbitrary one-word value to pass to proc. */ +{ + register Trace *tracePtr; + register Interp *iPtr = (Interp *) interp; + + 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); + return; + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AddErrorInfo -- + * + * Add information to a message being accumulated 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. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AddErrorInfo(interp, message) + Tcl_Interp *interp; /* Interpreter to which error information + * pertains. */ + char *message; /* Message to record. */ +{ + register Interp *iPtr = (Interp *) interp; + + /* + * If an error is already being logged, then the new errorInfo + * is the concatenation of the old info and the new message. + * If this is the first piece of info for the error, then the + * new errorInfo is the concatenation of the message in + * interp->result and the new message. + */ + + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result, + TCL_GLOBAL_ONLY); + iPtr->flags |= ERR_IN_PROGRESS; + + /* + * 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); + } + } + Tcl_SetVar2(interp, "errorInfo", (char *) NULL, message, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); +} + +/* + *---------------------------------------------------------------------- + * + * 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_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; +} |
