--- projs/trunk/shared_source/tcl_base/tclbasic.c 2016/10/14 01:50:00 42 +++ projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclbasic.c 2016/11/05 11:07:06 71 @@ -1,4266 +1,4256 @@ -/* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclbasic.c,v 1.1.1.1 2001/06/13 04:33:43 dtashley Exp $ */ - -/* - * 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.1.1.1 2001/06/13 04:33:43 dtashley 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; - - 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); - -#ifdef TCL_THREADS - /* - * The existence of the "threaded" element of the tcl_platform array indicates - * that this particular Tcl shell has been compiled with threads turned on. - * Using "info exists tcl_platform(threaded)" a Tcl script can introspect on the - * interpreter level of thread safety. - */ - - - Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", - TCL_GLOBAL_ONLY); -#endif - - /* - * 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; - - /* - * 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; - } - 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 find information - * to store in the 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. - */ - - /* - * If you are getting a crash during the call to deleteProc and - * cmdPtr->deleteProc is a pointer to the function free(), the - * most likely cause is that your extension allocated memory - * for the clientData argument to Tcl_CreateObjCommand() with - * the ckalloc() macro and you are now trying to deallocate - * this memory with free() instead of ckfree(). You should - * pass a pointer to your own method that calls ckfree(). - */ - - (*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, unless TCL_EVAL_DIRECT - * is specified. - * - * 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; - - 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). - * - * Pure List Optimization (no string representation). In this - * case, we can safely use Tcl_EvalObjv instead and get an - * appreciable improvement in execution speed. This is because it - * allows us to avoid a setFromAny step that would just pack - * everything into a string and back out again. - * - * USE_EVAL_DIRECT is a special flag used for testing purpose only - * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt) - */ - if (!(iPtr->flags & USE_EVAL_DIRECT) && - (objPtr->typePtr == &tclListType) && /* is a list... */ - (objPtr->bytes == NULL) /* ...without a string rep */) { - register List *listRepPtr = - (List *) objPtr->internalRep.otherValuePtr; - result = Tcl_EvalObjv(interp, listRepPtr->elemCount, - listRepPtr->elements, flags); - } else { - register char *p; - p = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - result = Tcl_EvalEx(interp, p, numSrcBytes, flags); - } - Tcl_DecrRefCount(objPtr); - return result; - } - - /* - * Prevent the object from being deleted as a side effect of evaling it. - */ - - 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) { - 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*/ - 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. - * - * To be pedantically correct, we should also check that the - * originating procPtr is the same as the current context procPtr - * (assuming one exists at all - none for global level). This - * code is #def'ed out because [info body] was changed to never - * return a bytecode type object, which should obviate us from - * the extra checks here. - */ - - 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) -#ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */ - || (codePtr->procPtr != NULL && !(iPtr->varFramePtr && - iPtr->varFramePtr->procPtr == codePtr->procPtr)) -#endif - || (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(majorV, minorV, patchLevelV, type) - int *majorV; - int *minorV; - int *patchLevelV; - int *type; -{ - if (majorV != NULL) { - *majorV = TCL_MAJOR_VERSION; - } - if (minorV != NULL) { - *minorV = TCL_MINOR_VERSION; - } - if (patchLevelV != NULL) { - *patchLevelV = TCL_RELEASE_SERIAL; - } - if (type != NULL) { - *type = TCL_RELEASE_LEVEL; - } -} - - -/* $History: tclbasic.c $ - * - * ***************** Version 1 ***************** - * User: Dtashley Date: 1/02/01 Time: 1:34a - * Created in $/IjuScripter, IjuConsole/Source/Tcl Base - * Initial check-in. - */ - -/* End of TCLBASIC.C */ \ No newline at end of file +/* $Header$ */ +/* + * 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.1.1.1 2001/06/13 04:33:43 dtashley 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; + + 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); + +#ifdef TCL_THREADS + /* + * The existence of the "threaded" element of the tcl_platform array indicates + * that this particular Tcl shell has been compiled with threads turned on. + * Using "info exists tcl_platform(threaded)" a Tcl script can introspect on the + * interpreter level of thread safety. + */ + + + Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", + TCL_GLOBAL_ONLY); +#endif + + /* + * 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; + + /* + * 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; + } + 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 find information + * to store in the 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. + */ + + /* + * If you are getting a crash during the call to deleteProc and + * cmdPtr->deleteProc is a pointer to the function free(), the + * most likely cause is that your extension allocated memory + * for the clientData argument to Tcl_CreateObjCommand() with + * the ckalloc() macro and you are now trying to deallocate + * this memory with free() instead of ckfree(). You should + * pass a pointer to your own method that calls ckfree(). + */ + + (*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, unless TCL_EVAL_DIRECT + * is specified. + * + * 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; + + 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). + * + * Pure List Optimization (no string representation). In this + * case, we can safely use Tcl_EvalObjv instead and get an + * appreciable improvement in execution speed. This is because it + * allows us to avoid a setFromAny step that would just pack + * everything into a string and back out again. + * + * USE_EVAL_DIRECT is a special flag used for testing purpose only + * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt) + */ + if (!(iPtr->flags & USE_EVAL_DIRECT) && + (objPtr->typePtr == &tclListType) && /* is a list... */ + (objPtr->bytes == NULL) /* ...without a string rep */) { + register List *listRepPtr = + (List *) objPtr->internalRep.otherValuePtr; + result = Tcl_EvalObjv(interp, listRepPtr->elemCount, + listRepPtr->elements, flags); + } else { + register char *p; + p = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + result = Tcl_EvalEx(interp, p, numSrcBytes, flags); + } + Tcl_DecrRefCount(objPtr); + return result; + } + + /* + * Prevent the object from being deleted as a side effect of evaling it. + */ + + 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) { + 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*/ + 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. + * + * To be pedantically correct, we should also check that the + * originating procPtr is the same as the current context procPtr + * (assuming one exists at all - none for global level). This + * code is #def'ed out because [info body] was changed to never + * return a bytecode type object, which should obviate us from + * the extra checks here. + */ + + 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) +#ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */ + || (codePtr->procPtr != NULL && !(iPtr->varFramePtr && + iPtr->varFramePtr->procPtr == codePtr->procPtr)) +#endif + || (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(majorV, minorV, patchLevelV, type) + int *majorV; + int *minorV; + int *patchLevelV; + int *type; +{ + if (majorV != NULL) { + *majorV = TCL_MAJOR_VERSION; + } + if (minorV != NULL) { + *minorV = TCL_MINOR_VERSION; + } + if (patchLevelV != NULL) { + *patchLevelV = TCL_RELEASE_SERIAL; + } + if (type != NULL) { + *type = TCL_RELEASE_LEVEL; + } +} + +/* End of tclbasic.c */