diff options
Diffstat (limited to 'generic/tclBasic.c')
| -rw-r--r-- | generic/tclBasic.c | 4220 |
1 files changed, 0 insertions, 4220 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c deleted file mode 100644 index e673a3c..0000000 --- a/generic/tclBasic.c +++ /dev/null @@ -1,4220 +0,0 @@ -/* - * 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. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclBasic.c,v 1.19 1999/04/16 00:46:42 stanton Exp $ - */ - -#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 ProcessUnexpectedResult _ANSI_ARGS_(( - Tcl_Interp *interp, int returnCode)); -static void RecordTracebackInfo _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Obj *objPtr, - int numSrcBytes)); - -extern TclStubs tclStubs; - -/* - * 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_CmdProc *) NULL, Tcl_BreakObjCmd, - 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_CmdProc *) NULL, Tcl_ContinueObjCmd, - TclCompileContinueCmd, 1}, - {"encoding", (Tcl_CmdProc *) NULL, Tcl_EncodingObjCmd, - (CompileProc *) NULL, 0}, - {"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_CmdProc *) NULL, Tcl_FileEventObjCmd, - (CompileProc *) NULL, 1}, - {"for", (Tcl_CmdProc *) NULL, Tcl_ForObjCmd, - 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_CmdProc *) NULL, Tcl_IfObjCmd, - TclCompileIfCmd, 1}, - {"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd, - TclCompileIncrCmd, 1}, - {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd, - (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_CmdProc *) NULL, Tcl_LoadObjCmd, - (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_CmdProc *) NULL, Tcl_PackageObjCmd, - (CompileProc *) NULL, 1}, - {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd, - (CompileProc *) NULL, 1}, - {"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd, - (CompileProc *) NULL, 1}, - {"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd, - (CompileProc *) NULL, 1}, - {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd, - (CompileProc *) NULL, 1}, - {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd, - (CompileProc *) NULL, 1}, - {"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd, - (CompileProc *) NULL, 1}, - {"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd, - TclCompileSetCmd, 1}, - {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd, - (CompileProc *) NULL, 1}, - {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd, - (CompileProc *) NULL, 1}, - {"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd, - (CompileProc *) NULL, 1}, - {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd, - (CompileProc *) NULL, 1}, - {"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd, - (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_CmdProc *) NULL, Tcl_WhileObjCmd, - 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_CmdProc *) NULL, Tcl_FconfigureObjCmd, - (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_CmdProc *) NULL, Tcl_GlobObjCmd, - (CompileProc *) NULL, 0}, - {"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd, - (CompileProc *) NULL, 0}, - {"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd, - (CompileProc *) NULL, 1}, - {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd, - (CompileProc *) NULL, 1}, - {"pwd", (Tcl_CmdProc *) NULL, Tcl_PwdObjCmd, - (CompileProc *) NULL, 0}, - {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd, - (CompileProc *) NULL, 1}, - {"seek", (Tcl_CmdProc *) NULL, Tcl_SeekObjCmd, - (CompileProc *) NULL, 1}, - {"socket", (Tcl_CmdProc *) NULL, Tcl_SocketObjCmd, - (CompileProc *) NULL, 0}, - {"tell", (Tcl_CmdProc *) NULL, Tcl_TellObjCmd, - (CompileProc *) NULL, 1}, - {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd, - (CompileProc *) NULL, 1}, - {"update", (Tcl_CmdProc *) NULL, Tcl_UpdateObjCmd, - (CompileProc *) NULL, 1}, - {"vwait", (Tcl_CmdProc *) NULL, Tcl_VwaitObjCmd, - (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_CmdProc *) NULL, Tcl_LsObjCmd, - (CompileProc *) NULL, 0}, - {"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd, - (CompileProc *) NULL, 1}, - {"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd, - (CompileProc *) NULL, 0}, -#else - {"exec", (Tcl_CmdProc *) NULL, Tcl_ExecObjCmd, - (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() -{ - Interp *iPtr; - Tcl_Interp *interp; - Command *cmdPtr; - BuiltinFunc *builtinFuncPtr; - MathFunc *mathFuncPtr; - Tcl_HashEntry *hPtr; - CmdInfo *cmdInfoPtr; - int i; - union { - char c[sizeof(short)]; - short s; - } order; -#ifdef TCL_COMPILE_STATS - ByteCodeStats *statsPtr; -#endif /* TCL_COMPILE_STATS */ - - TclInitSubsystems(NULL); - - /* - * 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. - */ - - iPtr = (Interp *) ckalloc(sizeof(Interp)); - interp = (Tcl_Interp *) iPtr; - - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = NULL; - iPtr->errorLine = 0; - iPtr->objResultPtr = Tcl_NewObj(); - Tcl_IncrRefCount(iPtr->objResultPtr); - iPtr->handle = TclHandleCreate(iPtr); - iPtr->globalNsPtr = NULL; - iPtr->hiddenCmdTablePtr = NULL; - iPtr->interpInfo = NULL; - 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; - TclInitLiteralTable(&(iPtr->literalTable)); - iPtr->compileEpoch = 0; - iPtr->compiledProcPtr = NULL; - iPtr->resolverPtr = 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(interp, "", - (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); - if (iPtr->globalNsPtr == NULL) { - panic("Tcl_CreateInterp: can't create global namespace"); - } - - /* - * Initialize support for code compilation and execution. We call - * TclCreateExecEnv after initializing namespaces since it tries to - * reference a Tcl variable (it links to the Tcl "tcl_traceExec" - * variable). - */ - - iPtr->execEnvPtr = TclCreateExecEnv(interp); - - /* - * Initialize the compilation and execution statistics kept for this - * interpreter. - */ - -#ifdef TCL_COMPILE_STATS - statsPtr = &(iPtr->stats); - statsPtr->numExecutions = 0; - statsPtr->numCompilations = 0; - statsPtr->numByteCodesFreed = 0; - (VOID *) memset(statsPtr->instructionCount, 0, - sizeof(statsPtr->instructionCount)); - - statsPtr->totalSrcBytes = 0.0; - statsPtr->totalByteCodeBytes = 0.0; - statsPtr->currentSrcBytes = 0.0; - statsPtr->currentByteCodeBytes = 0.0; - (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); - (VOID *) memset(statsPtr->byteCodeCount, 0, - sizeof(statsPtr->byteCodeCount)); - (VOID *) memset(statsPtr->lifetimeCount, 0, - sizeof(statsPtr->lifetimeCount)); - - statsPtr->currentInstBytes = 0.0; - statsPtr->currentLitBytes = 0.0; - statsPtr->currentExceptBytes = 0.0; - statsPtr->currentAuxBytes = 0.0; - statsPtr->currentCmdMapBytes = 0.0; - - statsPtr->numLiteralsCreated = 0; - statsPtr->totalLitStringBytes = 0.0; - statsPtr->currentLitStringBytes = 0.0; - (VOID *) memset(statsPtr->literalCount, 0, - sizeof(statsPtr->literalCount)); -#endif /* TCL_COMPILE_STATS */ - - /* - * Initialise the stub table pointer. - */ - - iPtr->stubTable = &tclStubs; - - - /* - * 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); - } - } - - /* - * Register the builtin math functions. - */ - - i = 0; - for (builtinFuncPtr = builtinFuncTable; builtinFuncPtr->name != NULL; - builtinFuncPtr++) { - Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name, - builtinFuncPtr->numArgs, builtinFuncPtr->argTypes, - (Tcl_MathProc *) NULL, (ClientData) 0); - hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, - builtinFuncPtr->name); - if (hPtr == NULL) { - panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name); - return NULL; - } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - mathFuncPtr->builtinFuncIndex = i; - i++; - } - iPtr->flags |= EXPR_INITIALIZED; - - /* - * Do Multiple/Safe Interps Tcl init stuff - */ - - TclInterpInit(interp); - - /* - * We used to create the "errorInfo" and "errorCode" global vars at this - * point because so much of the Tcl implementation assumes they already - * exist. This is not quite enough, however, since they can be unset - * at any time. - * - * There are 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 choose 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(interp); -#endif - - /* - * Compute the byte order of this machine. - */ - - order.s = 1; - Tcl_SetVar2(interp, "tcl_platform", "byteOrder", - ((order.c[0] == 1) ? "littleEndian" : "bigEndian"), - TCL_GLOBAL_ONLY); - - /* - * Set up other variables such as tcl_version and tcl_library - */ - - Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); - Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - TclPrecTraceProc, (ClientData) NULL); - TclpSetVariables(interp); - - /* - * Register Tcl's version number. - */ - - Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs); - -#ifdef Tcl_InitStubs -#undef Tcl_InitStubs -#endif - Tcl_InitStubs(interp, TCL_VERSION, 1); - - return interp; -} - -/* - *---------------------------------------------------------------------- - * - * 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; -#ifdef TCL_THREADS - static Tcl_Mutex assocMutex; -#endif - int new; - char buffer[32 + TCL_INTEGER_SPACE]; - AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); - Tcl_HashEntry *hPtr; - - Tcl_MutexLock(&assocMutex); - sprintf(buffer, "Assoc Data Key #%d", assocDataCounter); - assocDataCounter++; - Tcl_MutexUnlock(&assocMutex); - - 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; -} - -/* - *---------------------------------------------------------------------- - * - * 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); -} - -/* - *---------------------------------------------------------------------- - * - * 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; - ResolverScheme *resPtr, *nextResPtr; - 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"); - } - - TclHandleFree(iPtr->handle); - - /* - * 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); - - /* - * Delete all the hidden commands. - */ - - hTablePtr = iPtr->hiddenCmdTablePtr; - if (hTablePtr != NULL) { - /* - * Non-pernicious deletion. The deletion callbacks will not be - * allowed to create any new hidden or non-hidden commands. - * Tcl_DeleteCommandFromToken() will remove the entry from the - * hiddenCmdTablePtr. - */ - - hPtr = Tcl_FirstHashEntry(hTablePtr, &search); - for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Tcl_DeleteCommandFromToken(interp, - (Tcl_Command) Tcl_GetHashValue(hPtr)); - } - Tcl_DeleteHashTable(hTablePtr); - ckfree((char *) hTablePtr); - } - /* - * 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) { - AssocData *dPtr; - - 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; - - resPtr = iPtr->resolverPtr; - while (resPtr) { - nextResPtr = resPtr->nextPtr; - ckfree(resPtr->name); - ckfree((char *) resPtr); - resPtr = nextResPtr; - } - - /* - * Free up literal objects created for scripts compiled by the - * interpreter. - */ - - TclDeleteLiteralTable(interp, &(iPtr->literalTable)); - ckfree((char *) iPtr); -} - -/* - *--------------------------------------------------------------------------- - * - * 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 the interp's 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 *hiddenCmdTablePtr; - 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. - */ - - hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; - if (hiddenCmdTablePtr == NULL) { - hiddenCmdTablePtr = (Tcl_HashTable *) - ckalloc((unsigned) sizeof(Tcl_HashTable)); - Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); - iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; - } - - /* - * 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(hiddenCmdTablePtr, 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 the interp's 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 *hiddenCmdTablePtr; - 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; - } - - /* - * Get the command from the hidden command table: - */ - - hPtr = NULL; - hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; - if (hiddenCmdTablePtr != NULL) { - hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, 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; - ImportRef *oldRefPtr = NULL; - Namespace *nsPtr, *dummy1, *dummy2; - Command *cmdPtr, *refCmdPtr; - Tcl_HashEntry *hPtr; - char *tail; - int new; - ImportedCmdData *dataPtr; - - 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) { - TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, - CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); - if ((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. - * Be careful to preserve any existing import links so we can - * restore them down below. That way, you can redefine a - * command and its import status will remain intact. - */ - - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - oldRefPtr = cmdPtr->importRefPtr; - cmdPtr->importRefPtr = NULL; - - 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 = TclInvokeStringCommand; - cmdPtr->objClientData = (ClientData) cmdPtr; - cmdPtr->proc = proc; - cmdPtr->clientData = clientData; - cmdPtr->deleteProc = deleteProc; - cmdPtr->deleteData = clientData; - cmdPtr->deleted = 0; - cmdPtr->importRefPtr = NULL; - - /* - * Plug in any existing import references found above. Be sure - * to update all of these references to point to the new command. - */ - - if (oldRefPtr != NULL) { - cmdPtr->importRefPtr = oldRefPtr; - while (oldRefPtr != NULL) { - refCmdPtr = oldRefPtr->importedCmdPtr; - dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; - dataPtr->realCmdPtr = cmdPtr; - oldRefPtr = oldRefPtr->nextPtr; - } - } - - /* - * 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_GetCommandName. - * - * 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; - ImportRef *oldRefPtr = NULL; - Namespace *nsPtr, *dummy1, *dummy2; - Command *cmdPtr, *refCmdPtr; - Tcl_HashEntry *hPtr; - char *tail; - int new; - ImportedCmdData *dataPtr; - - 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) { - TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, - CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); - if ((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; - } - - /* - * Otherwise, we delete the old command. Be careful to preserve - * any existing import links so we can restore them down below. - * That way, you can redefine a command and its import status - * will remain intact. - */ - - oldRefPtr = cmdPtr->importRefPtr; - cmdPtr->importRefPtr = NULL; - - 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; - - /* - * Plug in any existing import references found above. Be sure - * to update all of these references to point to the new command. - */ - - if (oldRefPtr != NULL) { - cmdPtr->importRefPtr = oldRefPtr; - while (oldRefPtr != NULL) { - refCmdPtr = oldRefPtr->importedCmdPtr; - dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; - dataPtr->realCmdPtr = cmdPtr; - oldRefPtr = oldRefPtr->nextPtr; - } - } - - /* - * 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; -} - -/* - *---------------------------------------------------------------------- - * - * 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. - */ - - if ((objc + 1) > NUM_ARGS) { - argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); - } - - for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetString(objv[i]); - } - 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. - */ - - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - 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. - */ - - TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL, - CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); - - 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_CreateMathFunc -- - * - * Creates a new math function for expressions in a given - * interpreter. - * - * Results: - * None. - * - * Side effects: - * The function defined by "name" is created or redefined. If the - * function already exists then its definition is replaced; this - * includes the builtin functions. Redefining a builtin function forces - * all existing code to be invalidated since that code may be compiled - * using an instruction specific to the replaced function. In addition, - * redefioning a non-builtin function will force existing code to be - * invalidated if the number of arguments has changed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) - Tcl_Interp *interp; /* Interpreter in which function is - * to be available. */ - char *name; /* Name of function (e.g. "sin"). */ - int numArgs; /* Nnumber of arguments required by - * function. */ - Tcl_ValueType *argTypes; /* Array of types acceptable for - * each argument. */ - Tcl_MathProc *proc; /* Procedure that implements the - * math function. */ - ClientData clientData; /* Additional value to pass to the - * function. */ -{ - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - MathFunc *mathFuncPtr; - int new, i; - - hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); - if (new) { - Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); - } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - - if (!new) { - if (mathFuncPtr->builtinFuncIndex >= 0) { - /* - * We are redefining a builtin math function. Invalidate the - * interpreter's existing code by incrementing its - * compileEpoch member. This field is checked in Tcl_EvalObj - * and ObjInterpProc, and code whose compilation epoch doesn't - * match is recompiled. Newly compiled code will no longer - * treat the function as builtin. - */ - - iPtr->compileEpoch++; - } else { - /* - * A non-builtin function is being redefined. We must invalidate - * existing code if the number of arguments has changed. This - * is because existing code was compiled assuming that number. - */ - - if (numArgs != mathFuncPtr->numArgs) { - iPtr->compileEpoch++; - } - } - } - - mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */ - if (numArgs > MAX_MATH_ARGS) { - numArgs = MAX_MATH_ARGS; - } - mathFuncPtr->numArgs = numArgs; - for (i = 0; i < numArgs; i++) { - mathFuncPtr->argTypes[i] = argTypes[i]; - } - mathFuncPtr->proc = proc; - mathFuncPtr->clientData = clientData; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_EvalObjEx -- - * - * 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_EvalObjEx(interp, objPtr, flags) - Tcl_Interp *interp; /* Token for command interpreter - * (returned by a previous call to - * Tcl_CreateInterp). */ - register Tcl_Obj *objPtr; /* Pointer to object containing - * commands to execute. */ - int flags; /* Collection of OR-ed bits that - * control the evaluation of the - * script. Supported values are - * TCL_EVAL_GLOBAL and - * TCL_EVAL_DIRECT. */ -{ - register Interp *iPtr = (Interp *) interp; - int evalFlags; /* 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 numSrcBytes; - int result; - CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr - * in case TCL_EVAL_GLOBAL was set. */ - Namespace *namespacePtr; - - /* - * Prevent the object from being deleted as a side effect of evaling it. - */ - - Tcl_IncrRefCount(objPtr); - - if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) { - /* - * We're not supposed to use the compiler or byte-code interpreter. - * Let Tcl_EvalEx evaluate the command directly (and probably - * more slowly). - */ - - char *p; - int length; - - p = Tcl_GetStringFromObj(objPtr, &length); - result = Tcl_EvalEx(interp, p, length, flags); - Tcl_DecrRefCount(objPtr); - return result; - } - - savedVarFramePtr = iPtr->varFramePtr; - if (flags & TCL_EVAL_GLOBAL) { - iPtr->varFramePtr = NULL; - } - - /* - * 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); - result = TCL_ERROR; - goto done; - } - - /* - * 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); - result = TCL_ERROR; - goto done; - } - - /* - * 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); - result = TCL_ERROR; - goto done; - } - - /* - * 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, - * or for a different namespace, or for the same namespace but - * with different name resolution rules, we recompile it. - * - * Precompiled objects, however, are immutable and therefore - * they are not recompiled, even if the epoch has changed. - */ - - if (iPtr->varFramePtr != NULL) { - namespacePtr = iPtr->varFramePtr->nsPtr; - } else { - namespacePtr = iPtr->globalNsPtr; - } - - if (objPtr->typePtr == &tclByteCodeType) { - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - - if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch) - || (codePtr->nsPtr != namespacePtr) - || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if ((Interp *) *codePtr->interpHandle != iPtr) { - panic("Tcl_EvalObj: compiled script jumped interps"); - } - codePtr->compileEpoch = iPtr->compileEpoch; - } else { - tclByteCodeType.freeIntRepProc(objPtr); - } - } - } - if (objPtr->typePtr != &tclByteCodeType) { - iPtr->errorLine = 1; - result = tclByteCodeType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - goto done; - } - } else { - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch)) { - (*tclByteCodeType.freeIntRepProc)(objPtr); - iPtr->errorLine = 1; - 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. - */ - - evalFlags = iPtr->evalFlags; - iPtr->evalFlags = 0; - - /* - * Execute the commands. If the code was compiled from an empty string, - * don't bother executing the code. - */ - - numSrcBytes = codePtr->numSrcBytes; - if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { - /* - * 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 { - 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); - } - - /* - * Update the interpreter's evaluation level count. If we are again at - * the top level, process any unusual return code returned by the - * evaluated code. - */ - - if (iPtr->numLevels == 1) { - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo(iPtr); - } - if ((result != TCL_OK) && (result != TCL_ERROR) - && ((evalFlags & TCL_ALLOW_EXCEPTIONS) == 0)) { - ProcessUnexpectedResult(interp, 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)) { - RecordTracebackInfo(interp, objPtr, numSrcBytes); - } - - /* - * 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 = numSrcBytes; - iPtr->flags &= ~ERR_ALREADY_LOGGED; - - done: - TclDecrRefCount(objPtr); - iPtr->varFramePtr = savedVarFramePtr; - iPtr->numLevels--; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * ProcessUnexpectedResult -- - * - * Procedure called by Tcl_EvalObj to set the interpreter's result - * value to an appropriate error message when the code it evaluates - * returns an unexpected result code (not TCL_OK and not TCL_ERROR) to - * the topmost evaluation level. - * - * Results: - * None. - * - * Side effects: - * The interpreter result is set to an error message appropriate to - * the result code. - * - *---------------------------------------------------------------------- - */ - -static void -ProcessUnexpectedResult(interp, returnCode) - Tcl_Interp *interp; /* The interpreter in which the unexpected - * result code was returned. */ - int returnCode; /* The unexpected result code. */ -{ - Tcl_ResetResult(interp); - if (returnCode == TCL_BREAK) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "invoked \"break\" outside of a loop", -1); - } else if (returnCode == TCL_CONTINUE) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "invoked \"continue\" outside of a loop", -1); - } else { - char buf[30 + TCL_INTEGER_SPACE]; - - sprintf(buf, "command returned bad code: %d", returnCode); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } -} - -/* - *---------------------------------------------------------------------- - * - * RecordTracebackInfo -- - * - * Procedure called by Tcl_EvalObj to record information about what was - * being executed when the error occurred. - * - * Results: - * None. - * - * Side effects: - * Appends information about the script being evaluated to the - * interpreter's "errorInfo" variable. - * - *---------------------------------------------------------------------- - */ - -static void -RecordTracebackInfo(interp, objPtr, numSrcBytes) - Tcl_Interp *interp; /* The interpreter in which the error - * occurred. */ - Tcl_Obj *objPtr; /* Points to object containing script whose - * evaluation resulted in an error. */ - int numSrcBytes; /* Number of bytes compiled in script. */ -{ - Interp *iPtr = (Interp *) interp; - char buf[200]; - char *ellipsis, *bytes; - int length; - - /* - * Decide how much of the command to print in the error message - * (up to a certain number of bytes). - */ - - bytes = Tcl_GetStringFromObj(objPtr, &length); - length = TclMin(numSrcBytes, length); - - ellipsis = ""; - 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); -} - -/* - *--------------------------------------------------------------------------- - * - * 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 the interp'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_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. - */ - - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - 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. - */ - - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - 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. - */ - - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - 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); - } - 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. - */ - - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - 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 objects; objv[0] points to the - * name of the command to invoke. */ - int flags; /* Combination of flags controlling the - * call: TCL_INVOKE_HIDDEN, - * TCL_INVOKE_NO_UNKNOWN, or - * TCL_INVOKE_NO_TRACEBACK. */ -{ - 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 objects; objv[0] points to the - * name of the command to invoke. */ - int flags; /* Combination of flags controlling the - * call: TCL_INVOKE_HIDDEN, - * TCL_INVOKE_NO_UNKNOWN, or - * TCL_INVOKE_NO_TRACEBACK. */ -{ - 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; - } - - cmdName = Tcl_GetString(objv[0]); - if (flags & TCL_INVOKE_HIDDEN) { - /* - * We never invoke "unknown" for hidden commands. - */ - - hPtr = NULL; - hTblPtr = ((Interp *) interp)->hiddenCmdTablePtr; - if (hTblPtr != NULL) { - hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); - } - if (hPtr == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "invalid hidden command name \"", cmdName, "\"", - (char *) NULL); - return TCL_ERROR; - } - 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) - && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) - && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { - 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) { - Tcl_DecrRefCount(localObjv[0]); - 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 interp's - * result is set to the string value of the expression. If the result - * is TCL_ERROR, then the interp's 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[TCL_DOUBLE_SPACE]; - 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. - */ - - Tcl_SetResult(interp, TclGetString(resultPtr), - 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. - */ - - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - 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. */ - LiteralTable *localTablePtr = &(compEnv.localLitTable); - register ByteCode *codePtr = NULL; - /* Tcl Internal type of bytecode. - * Initialized to avoid compiler warning. */ - AuxData *auxDataPtr; - LiteralEntry *entryPtr; - Tcl_Obj *saveObjPtr; - char *string; - int length, i, result; - - /* - * First handle some common expressions specially. - */ - - string = Tcl_GetStringFromObj(objPtr, &length); - if (length == 1) { - if (*string == '0') { - *resultPtrPtr = Tcl_NewLongObj(0); - Tcl_IncrRefCount(*resultPtrPtr); - return TCL_OK; - } else if (*string == '1') { - *resultPtrPtr = Tcl_NewLongObj(1); - Tcl_IncrRefCount(*resultPtrPtr); - return TCL_OK; - } - } else if ((length == 2) && (*string == '!')) { - if (*(string+1) == '0') { - *resultPtrPtr = Tcl_NewLongObj(1); - Tcl_IncrRefCount(*resultPtrPtr); - return TCL_OK; - } else if (*(string+1) == '1') { - *resultPtrPtr = Tcl_NewLongObj(0); - Tcl_IncrRefCount(*resultPtrPtr); - return TCL_OK; - } - } - - /* - * 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. - * - * Precompiled expressions, however, are immutable and therefore - * they are not recompiled, even if the epoch has changed. - * - */ - - if (objPtr->typePtr == &tclByteCodeType) { - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch)) { - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if ((Interp *) *codePtr->interpHandle != iPtr) { - panic("Tcl_ExprObj: compiled expression jumped interps"); - } - codePtr->compileEpoch = iPtr->compileEpoch; - } else { - (*tclByteCodeType.freeIntRepProc)(objPtr); - objPtr->typePtr = (Tcl_ObjType *) NULL; - } - } - } - if (objPtr->typePtr != &tclByteCodeType) { - TclInitCompileEnv(interp, &compEnv, string, length); - result = TclCompileExpr(interp, string, length, &compEnv); - - /* - * Free the compilation environment's literal table bucket array if - * it was dynamically allocated. - */ - - if (localTablePtr->buckets != localTablePtr->staticBuckets) { - ckfree((char *) localTablePtr->buckets); - } - - if (result != TCL_OK) { - /* - * Compilation errors. Free storage allocated for compilation. - */ - -#ifdef TCL_COMPILE_DEBUG - TclVerifyLocalLiteralTable(&compEnv); -#endif /*TCL_COMPILE_DEBUG*/ - entryPtr = compEnv.literalArrayPtr; - for (i = 0; i < compEnv.literalArrayNext; i++) { - TclReleaseLiteral(interp, entryPtr->objPtr); - entryPtr++; - } -#ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable(iPtr); -#endif /*TCL_COMPILE_DEBUG*/ - - auxDataPtr = compEnv.auxDataArrayPtr; - for (i = 0; i < compEnv.auxDataArrayNext; i++) { - if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); - } - auxDataPtr++; - } - TclFreeCompileEnv(&compEnv); - return result; - } - - /* - * Successful compilation. If the expression yielded no - * instructions, push an zero object as the expression's result. - */ - - if (compEnv.codeNext == compEnv.codeStart) { - TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0), - &compEnv); - } - - /* - * Add a "done" instruction as the last instruction and change the - * object into a ByteCode object. Ownership of the literal objects - * and aux data items is given to the ByteCode object. - */ - - compEnv.numSrcBytes = iPtr->termOffset; - TclEmitOpcode(INST_DONE, &compEnv); - TclInitByteCodeObj(objPtr, &compEnv); - TclFreeCompileEnv(&compEnv); - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile == 2) { - TclPrintByteCodeObj(interp, objPtr); - } -#endif /* TCL_COMPILE_DEBUG */ - } - - /* - * Execute the expression after first saving the interpreter's result. - */ - - saveObjPtr = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(saveObjPtr); - Tcl_ResetResult(interp); - - /* - * 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); - objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; - } - - /* - * 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_SetObjResult(interp, saveObjPtr); - } - Tcl_DecrRefCount(saveObjPtr); - 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. */ - CONST 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. */ - CONST char *message; /* Points to the first byte of an array of - * bytes of the message. */ - 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 *messagePtr; - - /* - * If we are just starting to log an error, errorInfo is initialized - * from the error message in the interpreter's result. - */ - - if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */ - iPtr->flags |= ERR_IN_PROGRESS; - - if (iPtr->result[0] == 0) { - (void) Tcl_SetVar2Ex(interp, "errorInfo", 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_SetVar2Ex(interp, "errorInfo", NULL, messagePtr, - (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); - Tcl_DecrRefCount(messagePtr); /* free msg object appended above */ - } -} - -/* - *--------------------------------------------------------------------------- - * - * Tcl_VarEvalVA -- - * - * 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 the interp's result. - * - * Side effects: - * Depends on what was done by the command. - * - *--------------------------------------------------------------------------- - */ - -int -Tcl_VarEvalVA (interp, argList) - Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ - va_list argList; /* Variable argument list. */ -{ - Tcl_DString buf; - char *string; - 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. - */ - - Tcl_DStringInit(&buf); - while (1) { - string = va_arg(argList, char *); - if (string == NULL) { - break; - } - Tcl_DStringAppend(&buf, string, -1); - } - - result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); - Tcl_DStringFree(&buf); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * 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) -{ - Tcl_Interp *interp; - va_list argList; - int result; - - interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); - result = Tcl_VarEvalVA(interp, argList); - va_end(argList); - - return result; -} - -/* - *--------------------------------------------------------------------------- - * - * Tcl_GlobalEval -- - * - * Evaluate a command at global level in an interpreter. - * - * Results: - * A standard Tcl result is returned, and the interp's 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; -} - - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetVersion - * - * Get the Tcl major, minor, and patchlevel version numbers and - * the release type. A patch is a release type TCL_FINAL_RELEASE - * with a patchLevel > 0. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void Tcl_GetVersion(major, minor, patchLevel, type) - int *major; - int *minor; - int *patchLevel; - int *type; -{ - if (major != NULL) { - *major = TCL_MAJOR_VERSION; - } - if (minor != NULL) { - *minor = TCL_MINOR_VERSION; - } - if (patchLevel != NULL) { - *patchLevel = TCL_RELEASE_SERIAL; - } - if (type != NULL) { - *type = TCL_RELEASE_LEVEL; - } -} - |