sl@0: /* sl@0: * tclBasic.c -- sl@0: * sl@0: * Contains the basic facilities for TCL command interpretation, sl@0: * including interpreter creation and deletion, command creation sl@0: * and deletion, and command/script execution. sl@0: * sl@0: * Copyright (c) 1987-1994 The Regents of the University of California. sl@0: * Copyright (c) 1994-1997 Sun Microsystems, Inc. sl@0: * Copyright (c) 1998-1999 by Scriptics Corporation. sl@0: * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. sl@0: * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved. sl@0: * sl@0: * See the file "license.terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclBasic.c,v 1.75.2.26 2006/11/28 22:19:59 andreas_kupries Exp $ sl@0: */ sl@0: sl@0: #include "tclInt.h" sl@0: #include "tclCompile.h" sl@0: #ifndef TCL_GENERIC_ONLY sl@0: # include "tclPort.h" sl@0: #endif sl@0: sl@0: /* sl@0: * Static procedures in this file: sl@0: */ sl@0: sl@0: static char * CallCommandTraces _ANSI_ARGS_((Interp *iPtr, sl@0: Command *cmdPtr, CONST char *oldName, sl@0: CONST char* newName, int flags)); sl@0: static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); sl@0: static void ProcessUnexpectedResult _ANSI_ARGS_(( sl@0: Tcl_Interp *interp, int returnCode)); sl@0: static int StringTraceProc _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp* interp, sl@0: int level, sl@0: CONST char* command, sl@0: Tcl_Command commandInfo, sl@0: int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData)); sl@0: sl@0: #ifdef TCL_TIP280 sl@0: /* TIP #280 - Modified token based evulation, with line information */ sl@0: static int EvalEx _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script, sl@0: int numBytes, int flags, int line)); sl@0: sl@0: static int EvalTokensStandard _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Token *tokenPtr, sl@0: int count, int line)); sl@0: sl@0: #endif sl@0: sl@0: extern TclStubs tclStubs; sl@0: sl@0: /* sl@0: * The following structure defines the commands in the Tcl core. sl@0: */ sl@0: sl@0: typedef struct { sl@0: char *name; /* Name of object-based command. */ sl@0: Tcl_CmdProc *proc; /* String-based procedure for command. */ sl@0: Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */ sl@0: CompileProc *compileProc; /* Procedure called to compile command. */ sl@0: int isSafe; /* If non-zero, command will be present sl@0: * in safe interpreter. Otherwise it will sl@0: * be hidden. */ sl@0: } CmdInfo; sl@0: sl@0: /* sl@0: * The built-in commands, and the procedures that implement them: sl@0: */ sl@0: sl@0: static CmdInfo builtInCmds[] = { sl@0: /* sl@0: * Commands in the generic core. Note that at least one of the proc or sl@0: * objProc members should be non-NULL. This avoids infinitely recursive sl@0: * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a sl@0: * command name is computed at runtime and results in the name of a sl@0: * compiled command. sl@0: */ sl@0: sl@0: {"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd, sl@0: TclCompileAppendCmd, 1}, sl@0: {"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"break", (Tcl_CmdProc *) NULL, Tcl_BreakObjCmd, sl@0: TclCompileBreakCmd, 1}, sl@0: {"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd, sl@0: TclCompileCatchCmd, 1}, sl@0: {"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"continue", (Tcl_CmdProc *) NULL, Tcl_ContinueObjCmd, sl@0: TclCompileContinueCmd, 1}, sl@0: {"encoding", (Tcl_CmdProc *) NULL, Tcl_EncodingObjCmd, sl@0: (CompileProc *) NULL, 0}, sl@0: {"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd, sl@0: (CompileProc *) NULL, 0}, sl@0: {"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd, sl@0: TclCompileExprCmd, 1}, sl@0: {"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"fileevent", (Tcl_CmdProc *) NULL, Tcl_FileEventObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"for", (Tcl_CmdProc *) NULL, Tcl_ForObjCmd, sl@0: TclCompileForCmd, 1}, sl@0: {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd, sl@0: TclCompileForeachCmd, 1}, sl@0: {"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"if", (Tcl_CmdProc *) NULL, Tcl_IfObjCmd, sl@0: TclCompileIfCmd, 1}, sl@0: {"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd, sl@0: TclCompileIncrCmd, 1}, sl@0: {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd, sl@0: TclCompileLappendCmd, 1}, sl@0: {"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd, sl@0: TclCompileLindexCmd, 1}, sl@0: {"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd, sl@0: TclCompileListCmd, 1}, sl@0: {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd, sl@0: TclCompileLlengthCmd, 1}, sl@0: {"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd, sl@0: (CompileProc *) NULL, 0}, sl@0: {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"lset", (Tcl_CmdProc *) NULL, Tcl_LsetObjCmd, sl@0: TclCompileLsetCmd, 1}, sl@0: {"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"package", (Tcl_CmdProc *) NULL, Tcl_PackageObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd, sl@0: TclCompileRegexpCmd, 1}, sl@0: {"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd, sl@0: TclCompileReturnCmd, 1}, sl@0: {"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd, sl@0: TclCompileSetCmd, 1}, sl@0: {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd, sl@0: TclCompileStringCmd, 1}, sl@0: {"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"while", (Tcl_CmdProc *) NULL, Tcl_WhileObjCmd, sl@0: TclCompileWhileCmd, 1}, sl@0: sl@0: /* sl@0: * Commands in the UNIX core: sl@0: */ sl@0: sl@0: #ifndef TCL_GENERIC_ONLY sl@0: {"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd, sl@0: (CompileProc *) NULL, 0}, sl@0: {"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"fconfigure", (Tcl_CmdProc *) NULL, Tcl_FconfigureObjCmd, sl@0: (CompileProc *) NULL, 0}, sl@0: {"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd, sl@0: (CompileProc *) NULL, 0}, sl@0: {"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"glob", (Tcl_CmdProc *) NULL, Tcl_GlobObjCmd, sl@0: (CompileProc *) NULL, 0}, sl@0: {"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd, sl@0: (CompileProc *) NULL, 0}, sl@0: {"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"pwd", (Tcl_CmdProc *) NULL, Tcl_PwdObjCmd, sl@0: (CompileProc *) NULL, 0}, sl@0: {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"seek", (Tcl_CmdProc *) NULL, Tcl_SeekObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"socket", (Tcl_CmdProc *) NULL, Tcl_SocketObjCmd, sl@0: (CompileProc *) NULL, 0}, sl@0: {"tell", (Tcl_CmdProc *) NULL, Tcl_TellObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"update", (Tcl_CmdProc *) NULL, Tcl_UpdateObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"vwait", (Tcl_CmdProc *) NULL, Tcl_VwaitObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: sl@0: #ifdef MAC_TCL sl@0: {"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd, sl@0: (CompileProc *) NULL, 0}, sl@0: {"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL, sl@0: (CompileProc *) NULL, 0}, sl@0: {"ls", (Tcl_CmdProc *) NULL, Tcl_LsObjCmd, sl@0: (CompileProc *) NULL, 0}, sl@0: {"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd, sl@0: (CompileProc *) NULL, 1}, sl@0: {"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd, sl@0: (CompileProc *) NULL, 0}, sl@0: #else sl@0: {"exec", (Tcl_CmdProc *) NULL, Tcl_ExecObjCmd, sl@0: (CompileProc *) NULL, 0}, sl@0: {"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd, sl@0: (CompileProc *) NULL, 0}, sl@0: #endif /* MAC_TCL */ sl@0: sl@0: #endif /* TCL_GENERIC_ONLY */ sl@0: {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL, sl@0: (CompileProc *) NULL, 0} sl@0: }; sl@0: sl@0: /* sl@0: * The following structure holds the client data for string-based sl@0: * trace procs sl@0: */ sl@0: sl@0: typedef struct StringTraceData { sl@0: ClientData clientData; /* Client data from Tcl_CreateTrace */ sl@0: Tcl_CmdTraceProc* proc; /* Trace procedure from Tcl_CreateTrace */ sl@0: } StringTraceData; sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_CreateInterp -- sl@0: * sl@0: * Create a new TCL command interpreter. sl@0: * sl@0: * Results: sl@0: * The return value is a token for the interpreter, which may be sl@0: * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or sl@0: * Tcl_DeleteInterp. sl@0: * sl@0: * Side effects: sl@0: * The command interpreter is initialized with the built-in commands sl@0: * and with the variables documented in tclvars(n). sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Interp * sl@0: Tcl_CreateInterp() sl@0: { sl@0: Interp *iPtr; sl@0: Tcl_Interp *interp; sl@0: Command *cmdPtr; sl@0: BuiltinFunc *builtinFuncPtr; sl@0: MathFunc *mathFuncPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: CmdInfo *cmdInfoPtr; sl@0: int i; sl@0: union { sl@0: char c[sizeof(short)]; sl@0: short s; sl@0: } order; sl@0: #ifdef TCL_COMPILE_STATS sl@0: ByteCodeStats *statsPtr; sl@0: #endif /* TCL_COMPILE_STATS */ sl@0: sl@0: TclInitSubsystems(NULL); sl@0: sl@0: /* sl@0: * Panic if someone updated the CallFrame structure without sl@0: * also updating the Tcl_CallFrame structure (or vice versa). sl@0: */ sl@0: sl@0: if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) { sl@0: /*NOTREACHED*/ sl@0: panic("Tcl_CallFrame and CallFrame are not the same size"); sl@0: } sl@0: sl@0: /* sl@0: * Initialize support for namespaces and create the global namespace sl@0: * (whose name is ""; an alias is "::"). This also initializes the sl@0: * Tcl object type table and other object management code. sl@0: */ sl@0: sl@0: iPtr = (Interp *) ckalloc(sizeof(Interp)); sl@0: interp = (Tcl_Interp *) iPtr; sl@0: sl@0: iPtr->result = iPtr->resultSpace; sl@0: iPtr->freeProc = NULL; sl@0: iPtr->errorLine = 0; sl@0: iPtr->objResultPtr = Tcl_NewObj(); sl@0: Tcl_IncrRefCount(iPtr->objResultPtr); sl@0: iPtr->handle = TclHandleCreate(iPtr); sl@0: iPtr->globalNsPtr = NULL; sl@0: iPtr->hiddenCmdTablePtr = NULL; sl@0: iPtr->interpInfo = NULL; sl@0: Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); sl@0: sl@0: iPtr->numLevels = 0; sl@0: iPtr->maxNestingDepth = MAX_NESTING_DEPTH; sl@0: iPtr->framePtr = NULL; sl@0: iPtr->varFramePtr = NULL; sl@0: sl@0: #ifdef TCL_TIP280 sl@0: /* sl@0: * TIP #280 - Initialize the arrays used to extend the ByteCode and sl@0: * Proc structures. sl@0: */ sl@0: iPtr->cmdFramePtr = NULL; sl@0: iPtr->linePBodyPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); sl@0: iPtr->lineBCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); sl@0: Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS); sl@0: Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS); sl@0: #endif sl@0: sl@0: iPtr->activeVarTracePtr = NULL; sl@0: iPtr->returnCode = TCL_OK; sl@0: iPtr->errorInfo = NULL; sl@0: iPtr->errorCode = NULL; sl@0: sl@0: iPtr->appendResult = NULL; sl@0: iPtr->appendAvl = 0; sl@0: iPtr->appendUsed = 0; sl@0: sl@0: Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); sl@0: iPtr->packageUnknown = NULL; sl@0: #ifdef TCL_TIP268 sl@0: /* TIP #268 */ sl@0: iPtr->packagePrefer = (getenv ("TCL_PKG_PREFER_LATEST") == NULL ? sl@0: PKG_PREFER_STABLE : sl@0: PKG_PREFER_LATEST); sl@0: #endif sl@0: iPtr->cmdCount = 0; sl@0: iPtr->termOffset = 0; sl@0: TclInitLiteralTable(&(iPtr->literalTable)); sl@0: iPtr->compileEpoch = 0; sl@0: iPtr->compiledProcPtr = NULL; sl@0: iPtr->resolverPtr = NULL; sl@0: iPtr->evalFlags = 0; sl@0: iPtr->scriptFile = NULL; sl@0: iPtr->flags = 0; sl@0: iPtr->tracePtr = NULL; sl@0: iPtr->tracesForbiddingInline = 0; sl@0: iPtr->activeCmdTracePtr = NULL; sl@0: iPtr->activeInterpTracePtr = NULL; sl@0: iPtr->assocData = (Tcl_HashTable *) NULL; sl@0: iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ sl@0: iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ sl@0: Tcl_IncrRefCount(iPtr->emptyObjPtr); sl@0: iPtr->resultSpace[0] = 0; sl@0: iPtr->threadId = Tcl_GetCurrentThread(); sl@0: sl@0: iPtr->globalNsPtr = NULL; /* force creation of global ns below */ sl@0: iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "", sl@0: (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); sl@0: if (iPtr->globalNsPtr == NULL) { sl@0: panic("Tcl_CreateInterp: can't create global namespace"); sl@0: } sl@0: sl@0: /* sl@0: * Initialize support for code compilation and execution. We call sl@0: * TclCreateExecEnv after initializing namespaces since it tries to sl@0: * reference a Tcl variable (it links to the Tcl "tcl_traceExec" sl@0: * variable). sl@0: */ sl@0: sl@0: iPtr->execEnvPtr = TclCreateExecEnv(interp); sl@0: sl@0: /* sl@0: * Initialize the compilation and execution statistics kept for this sl@0: * interpreter. sl@0: */ sl@0: sl@0: #ifdef TCL_COMPILE_STATS sl@0: statsPtr = &(iPtr->stats); sl@0: statsPtr->numExecutions = 0; sl@0: statsPtr->numCompilations = 0; sl@0: statsPtr->numByteCodesFreed = 0; sl@0: (VOID *) memset(statsPtr->instructionCount, 0, sl@0: sizeof(statsPtr->instructionCount)); sl@0: sl@0: statsPtr->totalSrcBytes = 0.0; sl@0: statsPtr->totalByteCodeBytes = 0.0; sl@0: statsPtr->currentSrcBytes = 0.0; sl@0: statsPtr->currentByteCodeBytes = 0.0; sl@0: (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); sl@0: (VOID *) memset(statsPtr->byteCodeCount, 0, sl@0: sizeof(statsPtr->byteCodeCount)); sl@0: (VOID *) memset(statsPtr->lifetimeCount, 0, sl@0: sizeof(statsPtr->lifetimeCount)); sl@0: sl@0: statsPtr->currentInstBytes = 0.0; sl@0: statsPtr->currentLitBytes = 0.0; sl@0: statsPtr->currentExceptBytes = 0.0; sl@0: statsPtr->currentAuxBytes = 0.0; sl@0: statsPtr->currentCmdMapBytes = 0.0; sl@0: sl@0: statsPtr->numLiteralsCreated = 0; sl@0: statsPtr->totalLitStringBytes = 0.0; sl@0: statsPtr->currentLitStringBytes = 0.0; sl@0: (VOID *) memset(statsPtr->literalCount, 0, sl@0: sizeof(statsPtr->literalCount)); sl@0: #endif /* TCL_COMPILE_STATS */ sl@0: sl@0: /* sl@0: * Initialise the stub table pointer. sl@0: */ sl@0: sl@0: iPtr->stubTable = &tclStubs; sl@0: sl@0: sl@0: /* sl@0: * Create the core commands. Do it here, rather than calling sl@0: * Tcl_CreateCommand, because it's faster (there's no need to check for sl@0: * a pre-existing command by the same name). If a command has a sl@0: * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to sl@0: * TclInvokeStringCommand. This is an object-based wrapper procedure sl@0: * that extracts strings, calls the string procedure, and creates an sl@0: * object for the result. Similarly, if a command has a Tcl_ObjCmdProc sl@0: * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. sl@0: */ sl@0: sl@0: for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; sl@0: cmdInfoPtr++) { sl@0: int new; sl@0: Tcl_HashEntry *hPtr; sl@0: sl@0: if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) sl@0: && (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) sl@0: && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) { sl@0: panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n"); sl@0: } sl@0: sl@0: hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, sl@0: cmdInfoPtr->name, &new); sl@0: if (new) { sl@0: cmdPtr = (Command *) ckalloc(sizeof(Command)); sl@0: cmdPtr->hPtr = hPtr; sl@0: cmdPtr->nsPtr = iPtr->globalNsPtr; sl@0: cmdPtr->refCount = 1; sl@0: cmdPtr->cmdEpoch = 0; sl@0: cmdPtr->compileProc = cmdInfoPtr->compileProc; sl@0: if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) { sl@0: cmdPtr->proc = TclInvokeObjectCommand; sl@0: cmdPtr->clientData = (ClientData) cmdPtr; sl@0: } else { sl@0: cmdPtr->proc = cmdInfoPtr->proc; sl@0: cmdPtr->clientData = (ClientData) NULL; sl@0: } sl@0: if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { sl@0: cmdPtr->objProc = TclInvokeStringCommand; sl@0: cmdPtr->objClientData = (ClientData) cmdPtr; sl@0: } else { sl@0: cmdPtr->objProc = cmdInfoPtr->objProc; sl@0: cmdPtr->objClientData = (ClientData) NULL; sl@0: } sl@0: cmdPtr->deleteProc = NULL; sl@0: cmdPtr->deleteData = (ClientData) NULL; sl@0: cmdPtr->flags = 0; sl@0: cmdPtr->importRefPtr = NULL; sl@0: cmdPtr->tracePtr = NULL; sl@0: Tcl_SetHashValue(hPtr, cmdPtr); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Register the builtin math functions. sl@0: */ sl@0: sl@0: i = 0; sl@0: for (builtinFuncPtr = tclBuiltinFuncTable; builtinFuncPtr->name != NULL; sl@0: builtinFuncPtr++) { sl@0: Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name, sl@0: builtinFuncPtr->numArgs, builtinFuncPtr->argTypes, sl@0: (Tcl_MathProc *) NULL, (ClientData) 0); sl@0: hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, sl@0: builtinFuncPtr->name); sl@0: if (hPtr == NULL) { sl@0: panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name); sl@0: return NULL; sl@0: } sl@0: mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); sl@0: mathFuncPtr->builtinFuncIndex = i; sl@0: i++; sl@0: } sl@0: iPtr->flags |= EXPR_INITIALIZED; sl@0: sl@0: /* sl@0: * Do Multiple/Safe Interps Tcl init stuff sl@0: */ sl@0: sl@0: TclInterpInit(interp); sl@0: sl@0: /* sl@0: * We used to create the "errorInfo" and "errorCode" global vars at this sl@0: * point because so much of the Tcl implementation assumes they already sl@0: * exist. This is not quite enough, however, since they can be unset sl@0: * at any time. sl@0: * sl@0: * There are 2 choices: sl@0: * + Check every place where a GetVar of those is used sl@0: * and the NULL result is not checked (like in tclLoad.c) sl@0: * + Make SetVar,... NULL friendly sl@0: * We choose the second option because : sl@0: * + It is easy and low cost to check for NULL pointer before sl@0: * calling strlen() sl@0: * + It can be helpfull to other people using those API sl@0: * + Passing a NULL value to those closest 'meaning' is empty string sl@0: * (specially with the new objects where 0 bytes strings are ok) sl@0: * So the following init is commented out: -- dl sl@0: * sl@0: * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, sl@0: * "", TCL_GLOBAL_ONLY); sl@0: * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, sl@0: * "NONE", TCL_GLOBAL_ONLY); sl@0: */ sl@0: sl@0: #ifndef TCL_GENERIC_ONLY sl@0: TclSetupEnv(interp); sl@0: #endif sl@0: sl@0: /* sl@0: * Compute the byte order of this machine. sl@0: */ sl@0: sl@0: order.s = 1; sl@0: Tcl_SetVar2(interp, "tcl_platform", "byteOrder", sl@0: ((order.c[0] == 1) ? "littleEndian" : "bigEndian"), sl@0: TCL_GLOBAL_ONLY); sl@0: sl@0: Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize", sl@0: Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY); sl@0: sl@0: /* sl@0: * Set up other variables such as tcl_version and tcl_library sl@0: */ sl@0: sl@0: Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); sl@0: Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); sl@0: Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL, sl@0: TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, sl@0: TclPrecTraceProc, (ClientData) NULL); sl@0: TclpSetVariables(interp); sl@0: sl@0: #ifdef TCL_THREADS sl@0: /* sl@0: * The existence of the "threaded" element of the tcl_platform array indicates sl@0: * that this particular Tcl shell has been compiled with threads turned on. sl@0: * Using "info exists tcl_platform(threaded)" a Tcl script can introspect on the sl@0: * interpreter level of thread safety. sl@0: */ sl@0: sl@0: sl@0: Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", sl@0: TCL_GLOBAL_ONLY); sl@0: #endif sl@0: sl@0: /* sl@0: * Register Tcl's version number. sl@0: * TIP#268: Expose information about its status, sl@0: * for runtime switches in the core library sl@0: * and tests. sl@0: */ sl@0: sl@0: Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs); sl@0: sl@0: #ifdef TCL_TIP268 sl@0: Tcl_SetVar2(interp, "tcl_platform", "tip,268", "1", sl@0: TCL_GLOBAL_ONLY); sl@0: #endif sl@0: #ifdef TCL_TIP280 sl@0: Tcl_SetVar2(interp, "tcl_platform", "tip,280", "1", sl@0: TCL_GLOBAL_ONLY); sl@0: #endif sl@0: #ifdef Tcl_InitStubs sl@0: #undef Tcl_InitStubs sl@0: #endif sl@0: Tcl_InitStubs(interp, TCL_VERSION, 1); sl@0: sl@0: return interp; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclHideUnsafeCommands -- sl@0: * sl@0: * Hides base commands that are not marked as safe from this sl@0: * interpreter. sl@0: * sl@0: * Results: sl@0: * TCL_OK if it succeeds, TCL_ERROR else. sl@0: * sl@0: * Side effects: sl@0: * Hides functionality in an interpreter. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclHideUnsafeCommands(interp) sl@0: Tcl_Interp *interp; /* Hide commands in this interpreter. */ sl@0: { sl@0: register CmdInfo *cmdInfoPtr; sl@0: sl@0: if (interp == (Tcl_Interp *) NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { sl@0: if (!cmdInfoPtr->isSafe) { sl@0: Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *-------------------------------------------------------------- sl@0: * sl@0: * Tcl_CallWhenDeleted -- sl@0: * sl@0: * Arrange for a procedure to be called before a given sl@0: * interpreter is deleted. The procedure is called as soon sl@0: * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is sl@0: * called on an interpreter that has already been deleted, sl@0: * the procedure will be called when the last Tcl_Release is sl@0: * done on the interpreter. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * When Tcl_DeleteInterp is invoked to delete interp, sl@0: * proc will be invoked. See the manual entry for sl@0: * details. sl@0: * sl@0: *-------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_CallWhenDeleted(interp, proc, clientData) sl@0: Tcl_Interp *interp; /* Interpreter to watch. */ sl@0: Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter sl@0: * is about to be deleted. */ sl@0: ClientData clientData; /* One-word value to pass to proc. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: static Tcl_ThreadDataKey assocDataCounterKey; sl@0: int *assocDataCounterPtr = sl@0: Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int)); sl@0: int new; sl@0: char buffer[32 + TCL_INTEGER_SPACE]; sl@0: AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); sl@0: Tcl_HashEntry *hPtr; sl@0: sl@0: sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr); sl@0: (*assocDataCounterPtr)++; sl@0: sl@0: if (iPtr->assocData == (Tcl_HashTable *) NULL) { sl@0: iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); sl@0: Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); sl@0: } sl@0: hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new); sl@0: dPtr->proc = proc; sl@0: dPtr->clientData = clientData; sl@0: Tcl_SetHashValue(hPtr, dPtr); sl@0: } sl@0: sl@0: /* sl@0: *-------------------------------------------------------------- sl@0: * sl@0: * Tcl_DontCallWhenDeleted -- sl@0: * sl@0: * Cancel the arrangement for a procedure to be called when sl@0: * a given interpreter is deleted. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * If proc and clientData were previously registered as a sl@0: * callback via Tcl_CallWhenDeleted, they are unregistered. sl@0: * If they weren't previously registered then nothing sl@0: * happens. sl@0: * sl@0: *-------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_DontCallWhenDeleted(interp, proc, clientData) sl@0: Tcl_Interp *interp; /* Interpreter to watch. */ sl@0: Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter sl@0: * is about to be deleted. */ sl@0: ClientData clientData; /* One-word value to pass to proc. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Tcl_HashTable *hTablePtr; sl@0: Tcl_HashSearch hSearch; sl@0: Tcl_HashEntry *hPtr; sl@0: AssocData *dPtr; sl@0: sl@0: hTablePtr = iPtr->assocData; sl@0: if (hTablePtr == (Tcl_HashTable *) NULL) { sl@0: return; sl@0: } sl@0: for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; sl@0: hPtr = Tcl_NextHashEntry(&hSearch)) { sl@0: dPtr = (AssocData *) Tcl_GetHashValue(hPtr); sl@0: if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { sl@0: ckfree((char *) dPtr); sl@0: Tcl_DeleteHashEntry(hPtr); sl@0: return; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetAssocData -- sl@0: * sl@0: * Creates a named association between user-specified data, a delete sl@0: * function and this interpreter. If the association already exists sl@0: * the data is overwritten with the new data. The delete function will sl@0: * be invoked when the interpreter is deleted. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Sets the associated data, creates the association if needed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_SetAssocData(interp, name, proc, clientData) sl@0: Tcl_Interp *interp; /* Interpreter to associate with. */ sl@0: CONST char *name; /* Name for association. */ sl@0: Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is sl@0: * about to be deleted. */ sl@0: ClientData clientData; /* One-word value to pass to proc. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: AssocData *dPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: int new; sl@0: sl@0: if (iPtr->assocData == (Tcl_HashTable *) NULL) { sl@0: iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); sl@0: Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); sl@0: } sl@0: hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new); sl@0: if (new == 0) { sl@0: dPtr = (AssocData *) Tcl_GetHashValue(hPtr); sl@0: } else { sl@0: dPtr = (AssocData *) ckalloc(sizeof(AssocData)); sl@0: } sl@0: dPtr->proc = proc; sl@0: dPtr->clientData = clientData; sl@0: sl@0: Tcl_SetHashValue(hPtr, dPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DeleteAssocData -- sl@0: * sl@0: * Deletes a named association of user-specified data with sl@0: * the specified interpreter. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Deletes the association. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_DeleteAssocData(interp, name) sl@0: Tcl_Interp *interp; /* Interpreter to associate with. */ sl@0: CONST char *name; /* Name of association. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: AssocData *dPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: sl@0: if (iPtr->assocData == (Tcl_HashTable *) NULL) { sl@0: return; sl@0: } sl@0: hPtr = Tcl_FindHashEntry(iPtr->assocData, name); sl@0: if (hPtr == (Tcl_HashEntry *) NULL) { sl@0: return; sl@0: } sl@0: dPtr = (AssocData *) Tcl_GetHashValue(hPtr); sl@0: if (dPtr->proc != NULL) { sl@0: (dPtr->proc) (dPtr->clientData, interp); sl@0: } sl@0: ckfree((char *) dPtr); sl@0: Tcl_DeleteHashEntry(hPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetAssocData -- sl@0: * sl@0: * Returns the client data associated with this name in the sl@0: * specified interpreter. sl@0: * sl@0: * Results: sl@0: * The client data in the AssocData record denoted by the named sl@0: * association, or NULL. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C ClientData sl@0: Tcl_GetAssocData(interp, name, procPtr) sl@0: Tcl_Interp *interp; /* Interpreter associated with. */ sl@0: CONST char *name; /* Name of association. */ sl@0: Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address sl@0: * of current deletion callback. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: AssocData *dPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: sl@0: if (iPtr->assocData == (Tcl_HashTable *) NULL) { sl@0: return (ClientData) NULL; sl@0: } sl@0: hPtr = Tcl_FindHashEntry(iPtr->assocData, name); sl@0: if (hPtr == (Tcl_HashEntry *) NULL) { sl@0: return (ClientData) NULL; sl@0: } sl@0: dPtr = (AssocData *) Tcl_GetHashValue(hPtr); sl@0: if (procPtr != (Tcl_InterpDeleteProc **) NULL) { sl@0: *procPtr = dPtr->proc; sl@0: } sl@0: return dPtr->clientData; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_InterpDeleted -- sl@0: * sl@0: * Returns nonzero if the interpreter has been deleted with a call sl@0: * to Tcl_DeleteInterp. sl@0: * sl@0: * Results: sl@0: * Nonzero if the interpreter is deleted, zero otherwise. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_InterpDeleted(interp) sl@0: Tcl_Interp *interp; sl@0: { sl@0: return (((Interp *) interp)->flags & DELETED) ? 1 : 0; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DeleteInterp -- sl@0: * sl@0: * Ensures that the interpreter will be deleted eventually. If there sl@0: * are no Tcl_Preserve calls in effect for this interpreter, it is sl@0: * deleted immediately, otherwise the interpreter is deleted when sl@0: * the last Tcl_Preserve is matched by a call to Tcl_Release. In either sl@0: * case, the procedure runs the currently registered deletion callbacks. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The interpreter is marked as deleted. The caller may still use it sl@0: * safely if there are calls to Tcl_Preserve in effect for the sl@0: * interpreter, but further calls to Tcl_Eval etc in this interpreter sl@0: * will fail. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_DeleteInterp(interp) sl@0: Tcl_Interp *interp; /* Token for command interpreter (returned sl@0: * by a previous call to Tcl_CreateInterp). */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: sl@0: /* sl@0: * If the interpreter has already been marked deleted, just punt. sl@0: */ sl@0: sl@0: if (iPtr->flags & DELETED) { sl@0: return; sl@0: } sl@0: sl@0: /* sl@0: * Mark the interpreter as deleted. No further evals will be allowed. sl@0: */ sl@0: sl@0: iPtr->flags |= DELETED; sl@0: sl@0: /* sl@0: * Ensure that the interpreter is eventually deleted. sl@0: */ sl@0: sl@0: Tcl_EventuallyFree((ClientData) interp, sl@0: (Tcl_FreeProc *) DeleteInterpProc); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * DeleteInterpProc -- sl@0: * sl@0: * Helper procedure to delete an interpreter. This procedure is sl@0: * called when the last call to Tcl_Preserve on this interpreter sl@0: * is matched by a call to Tcl_Release. The procedure cleans up sl@0: * all resources used in the interpreter and calls all currently sl@0: * registered interpreter deletion callbacks. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Whatever the interpreter deletion callbacks do. Frees resources sl@0: * used by the interpreter. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: DeleteInterpProc(interp) sl@0: Tcl_Interp *interp; /* Interpreter to delete. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Tcl_HashEntry *hPtr; sl@0: Tcl_HashSearch search; sl@0: Tcl_HashTable *hTablePtr; sl@0: ResolverScheme *resPtr, *nextResPtr; sl@0: sl@0: /* sl@0: * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. sl@0: */ sl@0: sl@0: if (iPtr->numLevels > 0) { sl@0: panic("DeleteInterpProc called with active evals"); sl@0: } sl@0: sl@0: /* sl@0: * The interpreter should already be marked deleted; otherwise how sl@0: * did we get here? sl@0: */ sl@0: sl@0: if (!(iPtr->flags & DELETED)) { sl@0: panic("DeleteInterpProc called on interpreter not marked deleted"); sl@0: } sl@0: sl@0: TclHandleFree(iPtr->handle); sl@0: sl@0: /* sl@0: * Dismantle everything in the global namespace except for the sl@0: * "errorInfo" and "errorCode" variables. These remain until the sl@0: * namespace is actually destroyed, in case any errors occur. sl@0: * sl@0: * Dismantle the namespace here, before we clear the assocData. If any sl@0: * background errors occur here, they will be deleted below. sl@0: */ sl@0: sl@0: TclTeardownNamespace(iPtr->globalNsPtr); sl@0: sl@0: /* sl@0: * Delete all the hidden commands. sl@0: */ sl@0: sl@0: hTablePtr = iPtr->hiddenCmdTablePtr; sl@0: if (hTablePtr != NULL) { sl@0: /* sl@0: * Non-pernicious deletion. The deletion callbacks will not be sl@0: * allowed to create any new hidden or non-hidden commands. sl@0: * Tcl_DeleteCommandFromToken() will remove the entry from the sl@0: * hiddenCmdTablePtr. sl@0: */ sl@0: sl@0: hPtr = Tcl_FirstHashEntry(hTablePtr, &search); sl@0: for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { sl@0: Tcl_DeleteCommandFromToken(interp, sl@0: (Tcl_Command) Tcl_GetHashValue(hPtr)); sl@0: } sl@0: Tcl_DeleteHashTable(hTablePtr); sl@0: ckfree((char *) hTablePtr); sl@0: } sl@0: /* sl@0: * Tear down the math function table. sl@0: */ sl@0: sl@0: for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search); sl@0: hPtr != NULL; sl@0: hPtr = Tcl_NextHashEntry(&search)) { sl@0: ckfree((char *) Tcl_GetHashValue(hPtr)); sl@0: } sl@0: Tcl_DeleteHashTable(&iPtr->mathFuncTable); sl@0: sl@0: /* sl@0: * Invoke deletion callbacks; note that a callback can create new sl@0: * callbacks, so we iterate. sl@0: */ sl@0: sl@0: while (iPtr->assocData != (Tcl_HashTable *) NULL) { sl@0: AssocData *dPtr; sl@0: sl@0: hTablePtr = iPtr->assocData; sl@0: iPtr->assocData = (Tcl_HashTable *) NULL; sl@0: for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); sl@0: hPtr != NULL; sl@0: hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { sl@0: dPtr = (AssocData *) Tcl_GetHashValue(hPtr); sl@0: Tcl_DeleteHashEntry(hPtr); sl@0: if (dPtr->proc != NULL) { sl@0: (*dPtr->proc)(dPtr->clientData, interp); sl@0: } sl@0: ckfree((char *) dPtr); sl@0: } sl@0: Tcl_DeleteHashTable(hTablePtr); sl@0: ckfree((char *) hTablePtr); sl@0: } sl@0: sl@0: /* sl@0: * Finish deleting the global namespace. sl@0: */ sl@0: sl@0: Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); sl@0: sl@0: /* sl@0: * Free up the result *after* deleting variables, since variable sl@0: * deletion could have transferred ownership of the result string sl@0: * to Tcl. sl@0: */ sl@0: sl@0: Tcl_FreeResult(interp); sl@0: interp->result = NULL; sl@0: Tcl_DecrRefCount(iPtr->objResultPtr); sl@0: iPtr->objResultPtr = NULL; sl@0: if (iPtr->errorInfo != NULL) { sl@0: ckfree(iPtr->errorInfo); sl@0: iPtr->errorInfo = NULL; sl@0: } sl@0: if (iPtr->errorCode != NULL) { sl@0: ckfree(iPtr->errorCode); sl@0: iPtr->errorCode = NULL; sl@0: } sl@0: if (iPtr->appendResult != NULL) { sl@0: ckfree(iPtr->appendResult); sl@0: iPtr->appendResult = NULL; sl@0: } sl@0: TclFreePackageInfo(iPtr); sl@0: while (iPtr->tracePtr != NULL) { sl@0: Tcl_DeleteTrace((Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr); sl@0: } sl@0: if (iPtr->execEnvPtr != NULL) { sl@0: TclDeleteExecEnv(iPtr->execEnvPtr); sl@0: } sl@0: Tcl_DecrRefCount(iPtr->emptyObjPtr); sl@0: iPtr->emptyObjPtr = NULL; sl@0: sl@0: resPtr = iPtr->resolverPtr; sl@0: while (resPtr) { sl@0: nextResPtr = resPtr->nextPtr; sl@0: ckfree(resPtr->name); sl@0: ckfree((char *) resPtr); sl@0: resPtr = nextResPtr; sl@0: } sl@0: sl@0: /* sl@0: * Free up literal objects created for scripts compiled by the sl@0: * interpreter. sl@0: */ sl@0: sl@0: TclDeleteLiteralTable(interp, &(iPtr->literalTable)); sl@0: sl@0: #ifdef TCL_TIP280 sl@0: /* TIP #280 - Release the arrays for ByteCode/Proc extension, and contents. sl@0: */ sl@0: { sl@0: Tcl_HashEntry *hPtr; sl@0: Tcl_HashSearch hSearch; sl@0: CmdFrame* cfPtr; sl@0: ExtCmdLoc* eclPtr; sl@0: int i; sl@0: sl@0: for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &hSearch); sl@0: hPtr != NULL; sl@0: hPtr = Tcl_NextHashEntry(&hSearch)) { sl@0: sl@0: cfPtr = (CmdFrame*) Tcl_GetHashValue (hPtr); sl@0: sl@0: if (cfPtr->type == TCL_LOCATION_SOURCE) { sl@0: Tcl_DecrRefCount (cfPtr->data.eval.path); sl@0: } sl@0: ckfree ((char*) cfPtr->line); sl@0: ckfree ((char*) cfPtr); sl@0: Tcl_DeleteHashEntry (hPtr); sl@0: sl@0: } sl@0: Tcl_DeleteHashTable (iPtr->linePBodyPtr); sl@0: ckfree ((char*) iPtr->linePBodyPtr); sl@0: iPtr->linePBodyPtr = NULL; sl@0: sl@0: /* See also tclCompile.c, TclCleanupByteCode */ sl@0: sl@0: for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &hSearch); sl@0: hPtr != NULL; sl@0: hPtr = Tcl_NextHashEntry(&hSearch)) { sl@0: sl@0: eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hPtr); sl@0: sl@0: if (eclPtr->type == TCL_LOCATION_SOURCE) { sl@0: Tcl_DecrRefCount (eclPtr->path); sl@0: } sl@0: for (i=0; i< eclPtr->nuloc; i++) { sl@0: ckfree ((char*) eclPtr->loc[i].line); sl@0: } sl@0: sl@0: if (eclPtr->loc != NULL) { sl@0: ckfree ((char*) eclPtr->loc); sl@0: } sl@0: sl@0: ckfree ((char*) eclPtr); sl@0: Tcl_DeleteHashEntry (hPtr); sl@0: } sl@0: Tcl_DeleteHashTable (iPtr->lineBCPtr); sl@0: ckfree((char*) iPtr->lineBCPtr); sl@0: iPtr->lineBCPtr = NULL; sl@0: } sl@0: #endif sl@0: ckfree((char *) iPtr); sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_HideCommand -- sl@0: * sl@0: * Makes a command hidden so that it cannot be invoked from within sl@0: * an interpreter, only from within an ancestor. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result; also leaves a message in the interp's result sl@0: * if an error occurs. sl@0: * sl@0: * Side effects: sl@0: * Removes a command from the command table and create an entry sl@0: * into the hidden command table under the specified token name. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_HideCommand(interp, cmdName, hiddenCmdToken) sl@0: Tcl_Interp *interp; /* Interpreter in which to hide command. */ sl@0: CONST char *cmdName; /* Name of command to hide. */ sl@0: CONST char *hiddenCmdToken; /* Token name of the to-be-hidden command. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Tcl_Command cmd; sl@0: Command *cmdPtr; sl@0: Tcl_HashTable *hiddenCmdTablePtr; sl@0: Tcl_HashEntry *hPtr; sl@0: int new; sl@0: sl@0: if (iPtr->flags & DELETED) { sl@0: sl@0: /* sl@0: * The interpreter is being deleted. Do not create any new sl@0: * structures, because it is not safe to modify the interpreter. sl@0: */ sl@0: sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Disallow hiding of commands that are currently in a namespace or sl@0: * renaming (as part of hiding) into a namespace. sl@0: * sl@0: * (because the current implementation with a single global table sl@0: * and the needed uniqueness of names cause problems with namespaces) sl@0: * sl@0: * we don't need to check for "::" in cmdName because the real check is sl@0: * on the nsPtr below. sl@0: * sl@0: * hiddenCmdToken is just a string which is not interpreted in any way. sl@0: * It may contain :: but the string is not interpreted as a namespace sl@0: * qualifier command name. Thus, hiding foo::bar to foo::bar and then sl@0: * trying to expose or invoke ::foo::bar will NOT work; but if the sl@0: * application always uses the same strings it will get consistent sl@0: * behaviour. sl@0: * sl@0: * But as we currently limit ourselves to the global namespace only sl@0: * for the source, in order to avoid potential confusion, sl@0: * lets prevent "::" in the token too. --dl sl@0: */ sl@0: sl@0: if (strstr(hiddenCmdToken, "::") != NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "cannot use namespace qualifiers in hidden command", sl@0: " token (rename)", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Find the command to hide. An error is returned if cmdName can't sl@0: * be found. Look up the command only from the global namespace. sl@0: * Full path of the command must be given if using namespaces. sl@0: */ sl@0: sl@0: cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, sl@0: /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); sl@0: if (cmd == (Tcl_Command) NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: cmdPtr = (Command *) cmd; sl@0: sl@0: /* sl@0: * Check that the command is really in global namespace sl@0: */ sl@0: sl@0: if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "can only hide global namespace commands", sl@0: " (use rename then hide)", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Initialize the hidden command table if necessary. sl@0: */ sl@0: sl@0: hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; sl@0: if (hiddenCmdTablePtr == NULL) { sl@0: hiddenCmdTablePtr = (Tcl_HashTable *) sl@0: ckalloc((unsigned) sizeof(Tcl_HashTable)); sl@0: Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); sl@0: iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; sl@0: } sl@0: sl@0: /* sl@0: * It is an error to move an exposed command to a hidden command with sl@0: * hiddenCmdToken if a hidden command with the name hiddenCmdToken already sl@0: * exists. sl@0: */ sl@0: sl@0: hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new); sl@0: if (!new) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "hidden command named \"", hiddenCmdToken, "\" already exists", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Nb : This code is currently 'like' a rename to a specialy set apart sl@0: * name table. Changes here and in TclRenameCommand must sl@0: * be kept in synch untill the common parts are actually sl@0: * factorized out. sl@0: */ sl@0: sl@0: /* sl@0: * Remove the hash entry for the command from the interpreter command sl@0: * table. This is like deleting the command, so bump its command epoch; sl@0: * this invalidates any cached references that point to the command. sl@0: */ sl@0: sl@0: if (cmdPtr->hPtr != NULL) { sl@0: Tcl_DeleteHashEntry(cmdPtr->hPtr); sl@0: cmdPtr->hPtr = (Tcl_HashEntry *) NULL; sl@0: cmdPtr->cmdEpoch++; sl@0: } sl@0: sl@0: /* sl@0: * Now link the hash table entry with the command structure. sl@0: * We ensured above that the nsPtr was right. sl@0: */ sl@0: sl@0: cmdPtr->hPtr = hPtr; sl@0: Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); sl@0: sl@0: /* sl@0: * If the command being hidden has a compile procedure, increment the sl@0: * interpreter's compileEpoch to invalidate its compiled code. This sl@0: * makes sure that we don't later try to execute old code compiled with sl@0: * command-specific (i.e., inline) bytecodes for the now-hidden sl@0: * command. This field is checked in Tcl_EvalObj and ObjInterpProc, sl@0: * and code whose compilation epoch doesn't match is recompiled. sl@0: */ sl@0: sl@0: if (cmdPtr->compileProc != NULL) { sl@0: iPtr->compileEpoch++; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ExposeCommand -- sl@0: * sl@0: * Makes a previously hidden command callable from inside the sl@0: * interpreter instead of only by its ancestors. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. If an error occurs, a message is left sl@0: * in the interp's result. sl@0: * sl@0: * Side effects: sl@0: * Moves commands from one hash table to another. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) sl@0: Tcl_Interp *interp; /* Interpreter in which to make command sl@0: * callable. */ sl@0: CONST char *hiddenCmdToken; /* Name of hidden command. */ sl@0: CONST char *cmdName; /* Name of to-be-exposed command. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Command *cmdPtr; sl@0: Namespace *nsPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: Tcl_HashTable *hiddenCmdTablePtr; sl@0: int new; sl@0: sl@0: if (iPtr->flags & DELETED) { sl@0: /* sl@0: * The interpreter is being deleted. Do not create any new sl@0: * structures, because it is not safe to modify the interpreter. sl@0: */ sl@0: sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Check that we have a regular name for the command sl@0: * (that the user is not trying to do an expose and a rename sl@0: * (to another namespace) at the same time) sl@0: */ sl@0: sl@0: if (strstr(cmdName, "::") != NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "can not expose to a namespace ", sl@0: "(use expose to toplevel, then rename)", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Get the command from the hidden command table: sl@0: */ sl@0: sl@0: hPtr = NULL; sl@0: hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; sl@0: if (hiddenCmdTablePtr != NULL) { sl@0: hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); sl@0: } sl@0: if (hPtr == (Tcl_HashEntry *) NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "unknown hidden command \"", hiddenCmdToken, sl@0: "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: cmdPtr = (Command *) Tcl_GetHashValue(hPtr); sl@0: sl@0: sl@0: /* sl@0: * Check that we have a true global namespace sl@0: * command (enforced by Tcl_HideCommand() but let's double sl@0: * check. (If it was not, we would not really know how to sl@0: * handle it). sl@0: */ sl@0: if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { sl@0: /* sl@0: * This case is theoritically impossible, sl@0: * we might rather panic() than 'nicely' erroring out ? sl@0: */ sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "trying to expose a non global command name space command", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* This is the global table */ sl@0: nsPtr = cmdPtr->nsPtr; sl@0: sl@0: /* sl@0: * It is an error to overwrite an existing exposed command as a result sl@0: * of exposing a previously hidden command. sl@0: */ sl@0: sl@0: hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new); sl@0: if (!new) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "exposed command \"", cmdName, sl@0: "\" already exists", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Remove the hash entry for the command from the interpreter hidden sl@0: * command table. sl@0: */ sl@0: sl@0: if (cmdPtr->hPtr != NULL) { sl@0: Tcl_DeleteHashEntry(cmdPtr->hPtr); sl@0: cmdPtr->hPtr = NULL; sl@0: } sl@0: sl@0: /* sl@0: * Now link the hash table entry with the command structure. sl@0: * This is like creating a new command, so deal with any shadowing sl@0: * of commands in the global namespace. sl@0: */ sl@0: sl@0: cmdPtr->hPtr = hPtr; sl@0: sl@0: Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); sl@0: sl@0: /* sl@0: * Not needed as we are only in the global namespace sl@0: * (but would be needed again if we supported namespace command hiding) sl@0: * sl@0: * TclResetShadowedCmdRefs(interp, cmdPtr); sl@0: */ sl@0: sl@0: sl@0: /* sl@0: * If the command being exposed has a compile procedure, increment sl@0: * interpreter's compileEpoch to invalidate its compiled code. This sl@0: * makes sure that we don't later try to execute old code compiled sl@0: * assuming the command is hidden. This field is checked in Tcl_EvalObj sl@0: * and ObjInterpProc, and code whose compilation epoch doesn't match is sl@0: * recompiled. sl@0: */ sl@0: sl@0: if (cmdPtr->compileProc != NULL) { sl@0: iPtr->compileEpoch++; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_CreateCommand -- sl@0: * sl@0: * Define a new command in a command table. sl@0: * sl@0: * Results: sl@0: * The return value is a token for the command, which can sl@0: * be used in future calls to Tcl_GetCommandName. sl@0: * sl@0: * Side effects: sl@0: * If a command named cmdName already exists for interp, it is deleted. sl@0: * In the future, when cmdName is seen as the name of a command by sl@0: * Tcl_Eval, proc will be called. To support the bytecode interpreter, sl@0: * the command is created with a wrapper Tcl_ObjCmdProc sl@0: * (TclInvokeStringCommand) that eventially calls proc. When the sl@0: * command is deleted from the table, deleteProc will be called. sl@0: * See the manual entry for details on the calling sequence. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Command sl@0: Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) sl@0: Tcl_Interp *interp; /* Token for command interpreter returned by sl@0: * a previous call to Tcl_CreateInterp. */ sl@0: CONST char *cmdName; /* Name of command. If it contains namespace sl@0: * qualifiers, the new command is put in the sl@0: * specified namespace; otherwise it is put sl@0: * in the global namespace. */ sl@0: Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */ sl@0: ClientData clientData; /* Arbitrary value passed to string proc. */ sl@0: Tcl_CmdDeleteProc *deleteProc; sl@0: /* If not NULL, gives a procedure to call sl@0: * when this command is deleted. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: ImportRef *oldRefPtr = NULL; sl@0: Namespace *nsPtr, *dummy1, *dummy2; sl@0: Command *cmdPtr, *refCmdPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: CONST char *tail; sl@0: int new; sl@0: ImportedCmdData *dataPtr; sl@0: sl@0: if (iPtr->flags & DELETED) { sl@0: /* sl@0: * The interpreter is being deleted. Don't create any new sl@0: * commands; it's not safe to muck with the interpreter anymore. sl@0: */ sl@0: sl@0: return (Tcl_Command) NULL; sl@0: } sl@0: sl@0: /* sl@0: * Determine where the command should reside. If its name contains sl@0: * namespace qualifiers, we put it in the specified namespace; sl@0: * otherwise, we always put it in the global namespace. sl@0: */ sl@0: sl@0: if (strstr(cmdName, "::") != NULL) { sl@0: TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, sl@0: CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); sl@0: if ((nsPtr == NULL) || (tail == NULL)) { sl@0: return (Tcl_Command) NULL; sl@0: } sl@0: } else { sl@0: nsPtr = iPtr->globalNsPtr; sl@0: tail = cmdName; sl@0: } sl@0: sl@0: hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); sl@0: if (!new) { sl@0: /* sl@0: * Command already exists. Delete the old one. sl@0: * Be careful to preserve any existing import links so we can sl@0: * restore them down below. That way, you can redefine a sl@0: * command and its import status will remain intact. sl@0: */ sl@0: sl@0: cmdPtr = (Command *) Tcl_GetHashValue(hPtr); sl@0: oldRefPtr = cmdPtr->importRefPtr; sl@0: cmdPtr->importRefPtr = NULL; sl@0: sl@0: Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); sl@0: hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); sl@0: if (!new) { sl@0: /* sl@0: * If the deletion callback recreated the command, just throw sl@0: * away the new command (if we try to delete it again, we sl@0: * could get stuck in an infinite loop). sl@0: */ sl@0: sl@0: ckfree((char*) Tcl_GetHashValue(hPtr)); sl@0: } sl@0: } sl@0: cmdPtr = (Command *) ckalloc(sizeof(Command)); sl@0: Tcl_SetHashValue(hPtr, cmdPtr); sl@0: cmdPtr->hPtr = hPtr; sl@0: cmdPtr->nsPtr = nsPtr; sl@0: cmdPtr->refCount = 1; sl@0: cmdPtr->cmdEpoch = 0; sl@0: cmdPtr->compileProc = (CompileProc *) NULL; sl@0: cmdPtr->objProc = TclInvokeStringCommand; sl@0: cmdPtr->objClientData = (ClientData) cmdPtr; sl@0: cmdPtr->proc = proc; sl@0: cmdPtr->clientData = clientData; sl@0: cmdPtr->deleteProc = deleteProc; sl@0: cmdPtr->deleteData = clientData; sl@0: cmdPtr->flags = 0; sl@0: cmdPtr->importRefPtr = NULL; sl@0: cmdPtr->tracePtr = NULL; sl@0: sl@0: /* sl@0: * Plug in any existing import references found above. Be sure sl@0: * to update all of these references to point to the new command. sl@0: */ sl@0: sl@0: if (oldRefPtr != NULL) { sl@0: cmdPtr->importRefPtr = oldRefPtr; sl@0: while (oldRefPtr != NULL) { sl@0: refCmdPtr = oldRefPtr->importedCmdPtr; sl@0: dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; sl@0: dataPtr->realCmdPtr = cmdPtr; sl@0: oldRefPtr = oldRefPtr->nextPtr; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * We just created a command, so in its namespace and all of its parent sl@0: * namespaces, it may shadow global commands with the same name. If any sl@0: * shadowed commands are found, invalidate all cached command references sl@0: * in the affected namespaces. sl@0: */ sl@0: sl@0: TclResetShadowedCmdRefs(interp, cmdPtr); sl@0: return (Tcl_Command) cmdPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_CreateObjCommand -- sl@0: * sl@0: * Define a new object-based command in a command table. sl@0: * sl@0: * Results: sl@0: * The return value is a token for the command, which can sl@0: * be used in future calls to Tcl_GetCommandName. sl@0: * sl@0: * Side effects: sl@0: * If no command named "cmdName" already exists for interp, one is sl@0: * created. Otherwise, if a command does exist, then if the sl@0: * object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume sl@0: * Tcl_CreateCommand was called previously for the same command and sl@0: * just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we sl@0: * delete the old command. sl@0: * sl@0: * In the future, during bytecode evaluation when "cmdName" is seen as sl@0: * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based sl@0: * Tcl_ObjCmdProc proc will be called. When the command is deleted from sl@0: * the table, deleteProc will be called. See the manual entry for sl@0: * details on the calling sequence. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Command sl@0: Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) sl@0: Tcl_Interp *interp; /* Token for command interpreter (returned sl@0: * by previous call to Tcl_CreateInterp). */ sl@0: CONST char *cmdName; /* Name of command. If it contains namespace sl@0: * qualifiers, the new command is put in the sl@0: * specified namespace; otherwise it is put sl@0: * in the global namespace. */ sl@0: Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with sl@0: * name. */ sl@0: ClientData clientData; /* Arbitrary value to pass to object sl@0: * procedure. */ sl@0: Tcl_CmdDeleteProc *deleteProc; sl@0: /* If not NULL, gives a procedure to call sl@0: * when this command is deleted. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: ImportRef *oldRefPtr = NULL; sl@0: Namespace *nsPtr, *dummy1, *dummy2; sl@0: Command *cmdPtr, *refCmdPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: CONST char *tail; sl@0: int new; sl@0: ImportedCmdData *dataPtr; sl@0: sl@0: if (iPtr->flags & DELETED) { sl@0: /* sl@0: * The interpreter is being deleted. Don't create any new sl@0: * commands; it's not safe to muck with the interpreter anymore. sl@0: */ sl@0: sl@0: return (Tcl_Command) NULL; sl@0: } sl@0: sl@0: /* sl@0: * Determine where the command should reside. If its name contains sl@0: * namespace qualifiers, we put it in the specified namespace; sl@0: * otherwise, we always put it in the global namespace. sl@0: */ sl@0: sl@0: if (strstr(cmdName, "::") != NULL) { sl@0: TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, sl@0: CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); sl@0: if ((nsPtr == NULL) || (tail == NULL)) { sl@0: return (Tcl_Command) NULL; sl@0: } sl@0: } else { sl@0: nsPtr = iPtr->globalNsPtr; sl@0: tail = cmdName; sl@0: } sl@0: sl@0: hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); sl@0: if (!new) { sl@0: cmdPtr = (Command *) Tcl_GetHashValue(hPtr); sl@0: sl@0: /* sl@0: * Command already exists. If its object-based Tcl_ObjCmdProc is sl@0: * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the sl@0: * argument "proc". Otherwise, we delete the old command. sl@0: */ sl@0: sl@0: if (cmdPtr->objProc == TclInvokeStringCommand) { sl@0: cmdPtr->objProc = proc; sl@0: cmdPtr->objClientData = clientData; sl@0: cmdPtr->deleteProc = deleteProc; sl@0: cmdPtr->deleteData = clientData; sl@0: return (Tcl_Command) cmdPtr; sl@0: } sl@0: sl@0: /* sl@0: * Otherwise, we delete the old command. Be careful to preserve sl@0: * any existing import links so we can restore them down below. sl@0: * That way, you can redefine a command and its import status sl@0: * will remain intact. sl@0: */ sl@0: sl@0: oldRefPtr = cmdPtr->importRefPtr; sl@0: cmdPtr->importRefPtr = NULL; sl@0: sl@0: Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); sl@0: hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); sl@0: if (!new) { sl@0: /* sl@0: * If the deletion callback recreated the command, just throw sl@0: * away the new command (if we try to delete it again, we sl@0: * could get stuck in an infinite loop). sl@0: */ sl@0: sl@0: ckfree((char *) Tcl_GetHashValue(hPtr)); sl@0: } sl@0: } sl@0: cmdPtr = (Command *) ckalloc(sizeof(Command)); sl@0: Tcl_SetHashValue(hPtr, cmdPtr); sl@0: cmdPtr->hPtr = hPtr; sl@0: cmdPtr->nsPtr = nsPtr; sl@0: cmdPtr->refCount = 1; sl@0: cmdPtr->cmdEpoch = 0; sl@0: cmdPtr->compileProc = (CompileProc *) NULL; sl@0: cmdPtr->objProc = proc; sl@0: cmdPtr->objClientData = clientData; sl@0: cmdPtr->proc = TclInvokeObjectCommand; sl@0: cmdPtr->clientData = (ClientData) cmdPtr; sl@0: cmdPtr->deleteProc = deleteProc; sl@0: cmdPtr->deleteData = clientData; sl@0: cmdPtr->flags = 0; sl@0: cmdPtr->importRefPtr = NULL; sl@0: cmdPtr->tracePtr = NULL; sl@0: sl@0: /* sl@0: * Plug in any existing import references found above. Be sure sl@0: * to update all of these references to point to the new command. sl@0: */ sl@0: sl@0: if (oldRefPtr != NULL) { sl@0: cmdPtr->importRefPtr = oldRefPtr; sl@0: while (oldRefPtr != NULL) { sl@0: refCmdPtr = oldRefPtr->importedCmdPtr; sl@0: dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; sl@0: dataPtr->realCmdPtr = cmdPtr; sl@0: oldRefPtr = oldRefPtr->nextPtr; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * We just created a command, so in its namespace and all of its parent sl@0: * namespaces, it may shadow global commands with the same name. If any sl@0: * shadowed commands are found, invalidate all cached command references sl@0: * in the affected namespaces. sl@0: */ sl@0: sl@0: TclResetShadowedCmdRefs(interp, cmdPtr); sl@0: return (Tcl_Command) cmdPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclInvokeStringCommand -- sl@0: * sl@0: * "Wrapper" Tcl_ObjCmdProc used to call an existing string-based sl@0: * Tcl_CmdProc if no object-based procedure exists for a command. A sl@0: * pointer to this procedure is stored as the Tcl_ObjCmdProc in a sl@0: * Command structure. It simply turns around and calls the string sl@0: * Tcl_CmdProc in the Command structure. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result value. sl@0: * sl@0: * Side effects: sl@0: * Besides those side effects of the called Tcl_CmdProc, sl@0: * TclInvokeStringCommand allocates and frees storage. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclInvokeStringCommand(clientData, interp, objc, objv) sl@0: ClientData clientData; /* Points to command's Command structure. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: register int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: register Command *cmdPtr = (Command *) clientData; sl@0: register int i; sl@0: int result; sl@0: sl@0: /* sl@0: * This procedure generates an argv array for the string arguments. It sl@0: * starts out with stack-allocated space but uses dynamically-allocated sl@0: * storage if needed. sl@0: */ sl@0: sl@0: #define NUM_ARGS 20 sl@0: CONST char *(argStorage[NUM_ARGS]); sl@0: CONST char **argv = argStorage; sl@0: sl@0: /* sl@0: * Create the string argument array "argv". Make sure argv is large sl@0: * enough to hold the objc arguments plus 1 extra for the zero sl@0: * end-of-argv word. sl@0: */ sl@0: sl@0: if ((objc + 1) > NUM_ARGS) { sl@0: argv = (CONST char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); sl@0: } sl@0: sl@0: for (i = 0; i < objc; i++) { sl@0: argv[i] = Tcl_GetString(objv[i]); sl@0: } sl@0: argv[objc] = 0; sl@0: sl@0: /* sl@0: * Invoke the command's string-based Tcl_CmdProc. sl@0: */ sl@0: sl@0: result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv); sl@0: sl@0: /* sl@0: * Free the argv array if malloc'ed storage was used. sl@0: */ sl@0: sl@0: if (argv != argStorage) { sl@0: ckfree((char *) argv); sl@0: } sl@0: return result; sl@0: #undef NUM_ARGS sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclInvokeObjectCommand -- sl@0: * sl@0: * "Wrapper" Tcl_CmdProc used to call an existing object-based sl@0: * Tcl_ObjCmdProc if no string-based procedure exists for a command. sl@0: * A pointer to this procedure is stored as the Tcl_CmdProc in a sl@0: * Command structure. It simply turns around and calls the object sl@0: * Tcl_ObjCmdProc in the Command structure. sl@0: * sl@0: * Results: sl@0: * A standard Tcl string result value. sl@0: * sl@0: * Side effects: sl@0: * Besides those side effects of the called Tcl_CmdProc, sl@0: * TclInvokeStringCommand allocates and frees storage. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclInvokeObjectCommand(clientData, interp, argc, argv) sl@0: ClientData clientData; /* Points to command's Command structure. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int argc; /* Number of arguments. */ sl@0: register CONST char **argv; /* Argument strings. */ sl@0: { sl@0: Command *cmdPtr = (Command *) clientData; sl@0: register Tcl_Obj *objPtr; sl@0: register int i; sl@0: int length, result; sl@0: sl@0: /* sl@0: * This procedure generates an objv array for object arguments that hold sl@0: * the argv strings. It starts out with stack-allocated space but uses sl@0: * dynamically-allocated storage if needed. sl@0: */ sl@0: sl@0: #define NUM_ARGS 20 sl@0: Tcl_Obj *(argStorage[NUM_ARGS]); sl@0: register Tcl_Obj **objv = argStorage; sl@0: sl@0: /* sl@0: * Create the object argument array "objv". Make sure objv is large sl@0: * enough to hold the objc arguments plus 1 extra for the zero sl@0: * end-of-objv word. sl@0: */ sl@0: sl@0: if (argc > NUM_ARGS) { sl@0: objv = (Tcl_Obj **) sl@0: ckalloc((unsigned)(argc * sizeof(Tcl_Obj *))); sl@0: } sl@0: sl@0: for (i = 0; i < argc; i++) { sl@0: length = strlen(argv[i]); sl@0: TclNewObj(objPtr); sl@0: TclInitStringRep(objPtr, argv[i], length); sl@0: Tcl_IncrRefCount(objPtr); sl@0: objv[i] = objPtr; sl@0: } sl@0: sl@0: /* sl@0: * Invoke the command's object-based Tcl_ObjCmdProc. sl@0: */ sl@0: sl@0: result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv); sl@0: sl@0: /* sl@0: * Move the interpreter's object result to the string result, sl@0: * then reset the object result. sl@0: */ sl@0: sl@0: Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), sl@0: TCL_VOLATILE); sl@0: sl@0: /* sl@0: * Decrement the ref counts for the argument objects created above, sl@0: * then free the objv array if malloc'ed storage was used. sl@0: */ sl@0: sl@0: for (i = 0; i < argc; i++) { sl@0: objPtr = objv[i]; sl@0: Tcl_DecrRefCount(objPtr); sl@0: } sl@0: if (objv != argStorage) { sl@0: ckfree((char *) objv); sl@0: } sl@0: return result; sl@0: #undef NUM_ARGS sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclRenameCommand -- sl@0: * sl@0: * Called to give an existing Tcl command a different name. Both the sl@0: * old command name and the new command name can have "::" namespace sl@0: * qualifiers. If the new command has a different namespace context, sl@0: * the command will be moved to that namespace and will execute in sl@0: * the context of that new namespace. sl@0: * sl@0: * If the new command name is NULL or the null string, the command is sl@0: * deleted. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * If anything goes wrong, an error message is returned in the sl@0: * interpreter's result object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclRenameCommand(interp, oldName, newName) sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: char *oldName; /* Existing command name. */ sl@0: char *newName; /* New command name. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: CONST char *newTail; sl@0: Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2; sl@0: Tcl_Command cmd; sl@0: Command *cmdPtr; sl@0: Tcl_HashEntry *hPtr, *oldHPtr; sl@0: int new, result; sl@0: Tcl_Obj* oldFullName; sl@0: Tcl_DString newFullName; sl@0: sl@0: /* sl@0: * Find the existing command. An error is returned if cmdName can't sl@0: * be found. sl@0: */ sl@0: sl@0: cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL, sl@0: /*flags*/ 0); sl@0: cmdPtr = (Command *) cmd; sl@0: if (cmdPtr == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ", sl@0: ((newName == NULL)||(*newName == '\0'))? "delete":"rename", sl@0: " \"", oldName, "\": command doesn't exist", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: cmdNsPtr = cmdPtr->nsPtr; sl@0: oldFullName = Tcl_NewObj(); sl@0: Tcl_IncrRefCount( oldFullName ); sl@0: Tcl_GetCommandFullName( interp, cmd, oldFullName ); sl@0: sl@0: /* sl@0: * If the new command name is NULL or empty, delete the command. Do this sl@0: * with Tcl_DeleteCommandFromToken, since we already have the command. sl@0: */ sl@0: sl@0: if ((newName == NULL) || (*newName == '\0')) { sl@0: Tcl_DeleteCommandFromToken(interp, cmd); sl@0: result = TCL_OK; sl@0: goto done; sl@0: } sl@0: sl@0: /* sl@0: * Make sure that the destination command does not already exist. sl@0: * The rename operation is like creating a command, so we should sl@0: * automatically create the containing namespaces just like sl@0: * Tcl_CreateCommand would. sl@0: */ sl@0: sl@0: TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL, sl@0: CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); sl@0: sl@0: if ((newNsPtr == NULL) || (newTail == NULL)) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "can't rename to \"", newName, "\": bad command name", sl@0: (char *) NULL); sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "can't rename to \"", newName, sl@0: "\": command already exists", (char *) NULL); sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: sl@0: /* sl@0: * Warning: any changes done in the code here are likely sl@0: * to be needed in Tcl_HideCommand() code too. sl@0: * (until the common parts are extracted out) --dl sl@0: */ sl@0: sl@0: /* sl@0: * Put the command in the new namespace so we can check for an alias sl@0: * loop. Since we are adding a new command to a namespace, we must sl@0: * handle any shadowing of the global commands that this might create. sl@0: */ sl@0: sl@0: oldHPtr = cmdPtr->hPtr; sl@0: hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new); sl@0: Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); sl@0: cmdPtr->hPtr = hPtr; sl@0: cmdPtr->nsPtr = newNsPtr; sl@0: TclResetShadowedCmdRefs(interp, cmdPtr); sl@0: sl@0: /* sl@0: * Now check for an alias loop. If we detect one, put everything back sl@0: * the way it was and report the error. sl@0: */ sl@0: sl@0: result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr); sl@0: if (result != TCL_OK) { sl@0: Tcl_DeleteHashEntry(cmdPtr->hPtr); sl@0: cmdPtr->hPtr = oldHPtr; sl@0: cmdPtr->nsPtr = cmdNsPtr; sl@0: goto done; sl@0: } sl@0: sl@0: /* sl@0: * Script for rename traces can delete the command "oldName". sl@0: * Therefore increment the reference count for cmdPtr so that sl@0: * it's Command structure is freed only towards the end of this sl@0: * function by calling TclCleanupCommand. sl@0: * sl@0: * The trace procedure needs to get a fully qualified name for sl@0: * old and new commands [Tcl bug #651271], or else there's no way sl@0: * for the trace procedure to get the namespace from which the old sl@0: * command is being renamed! sl@0: */ sl@0: sl@0: Tcl_DStringInit( &newFullName ); sl@0: Tcl_DStringAppend( &newFullName, newNsPtr->fullName, -1 ); sl@0: if ( newNsPtr != iPtr->globalNsPtr ) { sl@0: Tcl_DStringAppend( &newFullName, "::", 2 ); sl@0: } sl@0: Tcl_DStringAppend( &newFullName, newTail, -1 ); sl@0: cmdPtr->refCount++; sl@0: CallCommandTraces( iPtr, cmdPtr, sl@0: Tcl_GetString( oldFullName ), sl@0: Tcl_DStringValue( &newFullName ), sl@0: TCL_TRACE_RENAME); sl@0: Tcl_DStringFree( &newFullName ); sl@0: sl@0: /* sl@0: * The new command name is okay, so remove the command from its sl@0: * current namespace. This is like deleting the command, so bump sl@0: * the cmdEpoch to invalidate any cached references to the command. sl@0: */ sl@0: sl@0: Tcl_DeleteHashEntry(oldHPtr); sl@0: cmdPtr->cmdEpoch++; sl@0: sl@0: /* sl@0: * If the command being renamed has a compile procedure, increment the sl@0: * interpreter's compileEpoch to invalidate its compiled code. This sl@0: * makes sure that we don't later try to execute old code compiled for sl@0: * the now-renamed command. sl@0: */ sl@0: sl@0: if (cmdPtr->compileProc != NULL) { sl@0: iPtr->compileEpoch++; sl@0: } sl@0: sl@0: /* sl@0: * Now free the Command structure, if the "oldName" command has sl@0: * been deleted by invocation of rename traces. sl@0: */ sl@0: TclCleanupCommand(cmdPtr); sl@0: result = TCL_OK; sl@0: sl@0: done: sl@0: TclDecrRefCount( oldFullName ); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetCommandInfo -- sl@0: * sl@0: * Modifies various information about a Tcl command. Note that sl@0: * this procedure will not change a command's namespace; use sl@0: * Tcl_RenameCommand to do that. Also, the isNativeObjectProc sl@0: * member of *infoPtr is ignored. sl@0: * sl@0: * Results: sl@0: * If cmdName exists in interp, then the information at *infoPtr sl@0: * is stored with the command in place of the current information sl@0: * and 1 is returned. If the command doesn't exist then 0 is sl@0: * returned. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_SetCommandInfo(interp, cmdName, infoPtr) sl@0: Tcl_Interp *interp; /* Interpreter in which to look sl@0: * for command. */ sl@0: CONST char *cmdName; /* Name of desired command. */ sl@0: CONST Tcl_CmdInfo *infoPtr; /* Where to find information sl@0: * to store in the command. */ sl@0: { sl@0: Tcl_Command cmd; sl@0: sl@0: cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, sl@0: /*flags*/ 0); sl@0: sl@0: return Tcl_SetCommandInfoFromToken( cmd, infoPtr ); sl@0: sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetCommandInfoFromToken -- sl@0: * sl@0: * Modifies various information about a Tcl command. Note that sl@0: * this procedure will not change a command's namespace; use sl@0: * Tcl_RenameCommand to do that. Also, the isNativeObjectProc sl@0: * member of *infoPtr is ignored. sl@0: * sl@0: * Results: sl@0: * If cmdName exists in interp, then the information at *infoPtr sl@0: * is stored with the command in place of the current information sl@0: * and 1 is returned. If the command doesn't exist then 0 is sl@0: * returned. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_SetCommandInfoFromToken( cmd, infoPtr ) sl@0: Tcl_Command cmd; sl@0: CONST Tcl_CmdInfo* infoPtr; sl@0: { sl@0: Command* cmdPtr; /* Internal representation of the command */ sl@0: sl@0: if (cmd == (Tcl_Command) NULL) { sl@0: return 0; sl@0: } sl@0: sl@0: /* sl@0: * The isNativeObjectProc and nsPtr members of *infoPtr are ignored. sl@0: */ sl@0: sl@0: cmdPtr = (Command *) cmd; sl@0: cmdPtr->proc = infoPtr->proc; sl@0: cmdPtr->clientData = infoPtr->clientData; sl@0: if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { sl@0: cmdPtr->objProc = TclInvokeStringCommand; sl@0: cmdPtr->objClientData = (ClientData) cmdPtr; sl@0: } else { sl@0: cmdPtr->objProc = infoPtr->objProc; sl@0: cmdPtr->objClientData = infoPtr->objClientData; sl@0: } sl@0: cmdPtr->deleteProc = infoPtr->deleteProc; sl@0: cmdPtr->deleteData = infoPtr->deleteData; sl@0: return 1; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetCommandInfo -- sl@0: * sl@0: * Returns various information about a Tcl command. sl@0: * sl@0: * Results: sl@0: * If cmdName exists in interp, then *infoPtr is modified to sl@0: * hold information about cmdName and 1 is returned. If the sl@0: * command doesn't exist then 0 is returned and *infoPtr isn't sl@0: * modified. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_GetCommandInfo(interp, cmdName, infoPtr) sl@0: Tcl_Interp *interp; /* Interpreter in which to look sl@0: * for command. */ sl@0: CONST char *cmdName; /* Name of desired command. */ sl@0: Tcl_CmdInfo *infoPtr; /* Where to store information about sl@0: * command. */ sl@0: { sl@0: Tcl_Command cmd; sl@0: sl@0: cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, sl@0: /*flags*/ 0); sl@0: sl@0: return Tcl_GetCommandInfoFromToken( cmd, infoPtr ); sl@0: sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetCommandInfoFromToken -- sl@0: * sl@0: * Returns various information about a Tcl command. sl@0: * sl@0: * Results: sl@0: * Copies information from the command identified by 'cmd' into sl@0: * a caller-supplied structure and returns 1. If the 'cmd' is sl@0: * NULL, leaves the structure untouched and returns 0. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_GetCommandInfoFromToken( cmd, infoPtr ) sl@0: Tcl_Command cmd; sl@0: Tcl_CmdInfo* infoPtr; sl@0: { sl@0: sl@0: Command* cmdPtr; /* Internal representation of the command */ sl@0: sl@0: if ( cmd == (Tcl_Command) NULL ) { sl@0: return 0; sl@0: } sl@0: sl@0: /* sl@0: * Set isNativeObjectProc 1 if objProc was registered by a call to sl@0: * Tcl_CreateObjCommand. Otherwise set it to 0. sl@0: */ sl@0: sl@0: cmdPtr = (Command *) cmd; sl@0: infoPtr->isNativeObjectProc = sl@0: (cmdPtr->objProc != TclInvokeStringCommand); sl@0: infoPtr->objProc = cmdPtr->objProc; sl@0: infoPtr->objClientData = cmdPtr->objClientData; sl@0: infoPtr->proc = cmdPtr->proc; sl@0: infoPtr->clientData = cmdPtr->clientData; sl@0: infoPtr->deleteProc = cmdPtr->deleteProc; sl@0: infoPtr->deleteData = cmdPtr->deleteData; sl@0: infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; sl@0: sl@0: return 1; sl@0: sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetCommandName -- sl@0: * sl@0: * Given a token returned by Tcl_CreateCommand, this procedure sl@0: * returns the current name of the command (which may have changed sl@0: * due to renaming). sl@0: * sl@0: * Results: sl@0: * The return value is the name of the given command. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C CONST char * sl@0: Tcl_GetCommandName(interp, command) sl@0: Tcl_Interp *interp; /* Interpreter containing the command. */ sl@0: Tcl_Command command; /* Token for command returned by a previous sl@0: * call to Tcl_CreateCommand. The command sl@0: * must not have been deleted. */ sl@0: { sl@0: Command *cmdPtr = (Command *) command; sl@0: sl@0: if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) { sl@0: sl@0: /* sl@0: * This should only happen if command was "created" after the sl@0: * interpreter began to be deleted, so there isn't really any sl@0: * command. Just return an empty string. sl@0: */ sl@0: sl@0: return ""; sl@0: } sl@0: return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetCommandFullName -- sl@0: * sl@0: * Given a token returned by, e.g., Tcl_CreateCommand or sl@0: * Tcl_FindCommand, this procedure appends to an object the command's sl@0: * full name, qualified by a sequence of parent namespace names. The sl@0: * command's fully-qualified name may have changed due to renaming. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The command's fully-qualified name is appended to the string sl@0: * representation of objPtr. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: Tcl_GetCommandFullName(interp, command, objPtr) sl@0: Tcl_Interp *interp; /* Interpreter containing the command. */ sl@0: Tcl_Command command; /* Token for command returned by a previous sl@0: * call to Tcl_CreateCommand. The command sl@0: * must not have been deleted. */ sl@0: Tcl_Obj *objPtr; /* Points to the object onto which the sl@0: * command's full name is appended. */ sl@0: sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: register Command *cmdPtr = (Command *) command; sl@0: char *name; sl@0: sl@0: /* sl@0: * Add the full name of the containing namespace, followed by the "::" sl@0: * separator, and the command name. sl@0: */ sl@0: sl@0: if (cmdPtr != NULL) { sl@0: if (cmdPtr->nsPtr != NULL) { sl@0: Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1); sl@0: if (cmdPtr->nsPtr != iPtr->globalNsPtr) { sl@0: Tcl_AppendToObj(objPtr, "::", 2); sl@0: } sl@0: } sl@0: if (cmdPtr->hPtr != NULL) { sl@0: name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); sl@0: Tcl_AppendToObj(objPtr, name, -1); sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DeleteCommand -- sl@0: * sl@0: * Remove the given command from the given interpreter. sl@0: * sl@0: * Results: sl@0: * 0 is returned if the command was deleted successfully. sl@0: * -1 is returned if there didn't exist a command by that name. sl@0: * sl@0: * Side effects: sl@0: * cmdName will no longer be recognized as a valid command for sl@0: * interp. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_DeleteCommand(interp, cmdName) sl@0: Tcl_Interp *interp; /* Token for command interpreter (returned sl@0: * by a previous Tcl_CreateInterp call). */ sl@0: CONST char *cmdName; /* Name of command to remove. */ sl@0: { sl@0: Tcl_Command cmd; sl@0: sl@0: /* sl@0: * Find the desired command and delete it. sl@0: */ sl@0: sl@0: cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, sl@0: /*flags*/ 0); sl@0: if (cmd == (Tcl_Command) NULL) { sl@0: return -1; sl@0: } sl@0: return Tcl_DeleteCommandFromToken(interp, cmd); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DeleteCommandFromToken -- sl@0: * sl@0: * Removes the given command from the given interpreter. This procedure sl@0: * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead sl@0: * of a command name for efficiency. sl@0: * sl@0: * Results: sl@0: * 0 is returned if the command was deleted successfully. sl@0: * -1 is returned if there didn't exist a command by that name. sl@0: * sl@0: * Side effects: sl@0: * The command specified by "cmd" will no longer be recognized as a sl@0: * valid command for "interp". sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_DeleteCommandFromToken(interp, cmd) sl@0: Tcl_Interp *interp; /* Token for command interpreter returned by sl@0: * a previous call to Tcl_CreateInterp. */ sl@0: Tcl_Command cmd; /* Token for command to delete. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Command *cmdPtr = (Command *) cmd; sl@0: ImportRef *refPtr, *nextRefPtr; sl@0: Tcl_Command importCmd; sl@0: sl@0: /* sl@0: * The code here is tricky. We can't delete the hash table entry sl@0: * before invoking the deletion callback because there are cases sl@0: * where the deletion callback needs to invoke the command (e.g. sl@0: * object systems such as OTcl). However, this means that the sl@0: * callback could try to delete or rename the command. The deleted sl@0: * flag allows us to detect these cases and skip nested deletes. sl@0: */ sl@0: sl@0: if (cmdPtr->flags & CMD_IS_DELETED) { sl@0: /* sl@0: * Another deletion is already in progress. Remove the hash sl@0: * table entry now, but don't invoke a callback or free the sl@0: * command structure. sl@0: */ sl@0: sl@0: Tcl_DeleteHashEntry(cmdPtr->hPtr); sl@0: cmdPtr->hPtr = NULL; sl@0: return 0; sl@0: } sl@0: sl@0: /* sl@0: * We must delete this command, even though both traces and sl@0: * delete procs may try to avoid this (renaming the command etc). sl@0: * Also traces and delete procs may try to delete the command sl@0: * themsevles. This flag declares that a delete is in progress sl@0: * and that recursive deletes should be ignored. sl@0: */ sl@0: cmdPtr->flags |= CMD_IS_DELETED; sl@0: sl@0: /* sl@0: * Bump the command epoch counter. This will invalidate all cached sl@0: * references that point to this command. sl@0: */ sl@0: sl@0: cmdPtr->cmdEpoch++; sl@0: sl@0: /* sl@0: * Call trace procedures for the command being deleted. Then delete sl@0: * its traces. sl@0: */ sl@0: sl@0: if (cmdPtr->tracePtr != NULL) { sl@0: CommandTrace *tracePtr; sl@0: CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); sl@0: /* Now delete these traces */ sl@0: tracePtr = cmdPtr->tracePtr; sl@0: while (tracePtr != NULL) { sl@0: CommandTrace *nextPtr = tracePtr->nextPtr; sl@0: if ((--tracePtr->refCount) <= 0) { sl@0: ckfree((char*)tracePtr); sl@0: } sl@0: tracePtr = nextPtr; sl@0: } sl@0: cmdPtr->tracePtr = NULL; sl@0: } sl@0: sl@0: /* sl@0: * If the command being deleted has a compile procedure, increment the sl@0: * interpreter's compileEpoch to invalidate its compiled code. This sl@0: * makes sure that we don't later try to execute old code compiled with sl@0: * command-specific (i.e., inline) bytecodes for the now-deleted sl@0: * command. This field is checked in Tcl_EvalObj and ObjInterpProc, and sl@0: * code whose compilation epoch doesn't match is recompiled. sl@0: */ sl@0: sl@0: if (cmdPtr->compileProc != NULL) { sl@0: iPtr->compileEpoch++; sl@0: } sl@0: sl@0: if (cmdPtr->deleteProc != NULL) { sl@0: /* sl@0: * Delete the command's client data. If this was an imported command sl@0: * created when a command was imported into a namespace, this client sl@0: * data will be a pointer to a ImportedCmdData structure describing sl@0: * the "real" command that this imported command refers to. sl@0: */ sl@0: sl@0: /* sl@0: * If you are getting a crash during the call to deleteProc and sl@0: * cmdPtr->deleteProc is a pointer to the function free(), the sl@0: * most likely cause is that your extension allocated memory sl@0: * for the clientData argument to Tcl_CreateObjCommand() with sl@0: * the ckalloc() macro and you are now trying to deallocate sl@0: * this memory with free() instead of ckfree(). You should sl@0: * pass a pointer to your own method that calls ckfree(). sl@0: */ sl@0: sl@0: (*cmdPtr->deleteProc)(cmdPtr->deleteData); sl@0: } sl@0: sl@0: /* sl@0: * If this command was imported into other namespaces, then imported sl@0: * commands were created that refer back to this command. Delete these sl@0: * imported commands now. sl@0: */ sl@0: sl@0: for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; sl@0: refPtr = nextRefPtr) { sl@0: nextRefPtr = refPtr->nextPtr; sl@0: importCmd = (Tcl_Command) refPtr->importedCmdPtr; sl@0: Tcl_DeleteCommandFromToken(interp, importCmd); sl@0: } sl@0: sl@0: /* sl@0: * Don't use hPtr to delete the hash entry here, because it's sl@0: * possible that the deletion callback renamed the command. sl@0: * Instead, use cmdPtr->hptr, and make sure that no-one else sl@0: * has already deleted the hash entry. sl@0: */ sl@0: sl@0: if (cmdPtr->hPtr != NULL) { sl@0: Tcl_DeleteHashEntry(cmdPtr->hPtr); sl@0: } sl@0: sl@0: /* sl@0: * Mark the Command structure as no longer valid. This allows sl@0: * TclExecuteByteCode to recognize when a Command has logically been sl@0: * deleted and a pointer to this Command structure cached in a CmdName sl@0: * object is invalid. TclExecuteByteCode will look up the command again sl@0: * in the interpreter's command hashtable. sl@0: */ sl@0: sl@0: cmdPtr->objProc = NULL; sl@0: sl@0: /* sl@0: * Now free the Command structure, unless there is another reference to sl@0: * it from a CmdName Tcl object in some ByteCode code sequence. In that sl@0: * case, delay the cleanup until all references are either discarded sl@0: * (when a ByteCode is freed) or replaced by a new reference (when a sl@0: * cached CmdName Command reference is found to be invalid and sl@0: * TclExecuteByteCode looks up the command in the command hashtable). sl@0: */ sl@0: sl@0: TclCleanupCommand(cmdPtr); sl@0: return 0; sl@0: } sl@0: sl@0: static char * sl@0: CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) sl@0: Interp *iPtr; /* Interpreter containing command. */ sl@0: Command *cmdPtr; /* Command whose traces are to be sl@0: * invoked. */ sl@0: CONST char *oldName; /* Command's old name, or NULL if we sl@0: * must get the name from cmdPtr */ sl@0: CONST char *newName; /* Command's new name, or NULL if sl@0: * the command is not being renamed */ sl@0: int flags; /* Flags indicating the type of traces sl@0: * to trigger, either TCL_TRACE_DELETE sl@0: * or TCL_TRACE_RENAME. */ sl@0: { sl@0: register CommandTrace *tracePtr; sl@0: ActiveCommandTrace active; sl@0: char *result; sl@0: Tcl_Obj *oldNamePtr = NULL; sl@0: int mask = (TCL_TRACE_DELETE | TCL_TRACE_RENAME); /* Safety */ sl@0: sl@0: flags &= mask; sl@0: sl@0: if (cmdPtr->flags & CMD_TRACE_ACTIVE) { sl@0: /* sl@0: * While a rename trace is active, we will not process any more sl@0: * rename traces; while a delete trace is active we will never sl@0: * reach here -- because Tcl_DeleteCommandFromToken checks for the sl@0: * condition (cmdPtr->flags & CMD_IS_DELETED) and returns immediately sl@0: * when a command deletion is in progress. For all other traces, sl@0: * delete traces will not be invoked but a call to TraceCommandProc sl@0: * will ensure that tracePtr->clientData is freed whenever the sl@0: * command "oldName" is deleted. sl@0: */ sl@0: if (cmdPtr->flags & TCL_TRACE_RENAME) { sl@0: flags &= ~TCL_TRACE_RENAME; sl@0: } sl@0: if (flags == 0) { sl@0: return NULL; sl@0: } sl@0: } sl@0: cmdPtr->flags |= CMD_TRACE_ACTIVE; sl@0: cmdPtr->refCount++; sl@0: sl@0: result = NULL; sl@0: active.nextPtr = iPtr->activeCmdTracePtr; sl@0: active.reverseScan = 0; sl@0: iPtr->activeCmdTracePtr = &active; sl@0: sl@0: if (flags & TCL_TRACE_DELETE) { sl@0: flags |= TCL_TRACE_DESTROYED; sl@0: } sl@0: active.cmdPtr = cmdPtr; sl@0: sl@0: Tcl_Preserve((ClientData) iPtr); sl@0: sl@0: for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL; sl@0: tracePtr = active.nextTracePtr) { sl@0: int traceFlags = (tracePtr->flags & mask); sl@0: sl@0: active.nextTracePtr = tracePtr->nextPtr; sl@0: if (!(traceFlags & flags)) { sl@0: continue; sl@0: } sl@0: cmdPtr->flags |= traceFlags; sl@0: if (oldName == NULL) { sl@0: TclNewObj(oldNamePtr); sl@0: Tcl_IncrRefCount(oldNamePtr); sl@0: Tcl_GetCommandFullName((Tcl_Interp *) iPtr, sl@0: (Tcl_Command) cmdPtr, oldNamePtr); sl@0: oldName = TclGetString(oldNamePtr); sl@0: } sl@0: tracePtr->refCount++; sl@0: (*tracePtr->traceProc)(tracePtr->clientData, sl@0: (Tcl_Interp *) iPtr, oldName, newName, flags); sl@0: cmdPtr->flags &= ~traceFlags; sl@0: if ((--tracePtr->refCount) <= 0) { sl@0: ckfree((char*)tracePtr); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * If a new object was created to hold the full oldName, sl@0: * free it now. sl@0: */ sl@0: sl@0: if (oldNamePtr != NULL) { sl@0: TclDecrRefCount(oldNamePtr); sl@0: } sl@0: sl@0: /* sl@0: * Restore the variable's flags, remove the record of our active sl@0: * traces, and then return. sl@0: */ sl@0: sl@0: cmdPtr->flags &= ~CMD_TRACE_ACTIVE; sl@0: cmdPtr->refCount--; sl@0: iPtr->activeCmdTracePtr = active.nextPtr; sl@0: Tcl_Release((ClientData) iPtr); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclCleanupCommand -- sl@0: * sl@0: * This procedure frees up a Command structure unless it is still sl@0: * referenced from an interpreter's command hashtable or from a CmdName sl@0: * Tcl object representing the name of a command in a ByteCode sl@0: * instruction sequence. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Memory gets freed unless a reference to the Command structure still sl@0: * exists. In that case the cleanup is delayed until the command is sl@0: * deleted or when the last ByteCode referring to it is freed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclCleanupCommand(cmdPtr) sl@0: register Command *cmdPtr; /* Points to the Command structure to sl@0: * be freed. */ sl@0: { sl@0: cmdPtr->refCount--; sl@0: if (cmdPtr->refCount <= 0) { sl@0: ckfree((char *) cmdPtr); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_CreateMathFunc -- sl@0: * sl@0: * Creates a new math function for expressions in a given sl@0: * interpreter. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The function defined by "name" is created or redefined. If the sl@0: * function already exists then its definition is replaced; this sl@0: * includes the builtin functions. Redefining a builtin function forces sl@0: * all existing code to be invalidated since that code may be compiled sl@0: * using an instruction specific to the replaced function. In addition, sl@0: * redefioning a non-builtin function will force existing code to be sl@0: * invalidated if the number of arguments has changed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) sl@0: Tcl_Interp *interp; /* Interpreter in which function is sl@0: * to be available. */ sl@0: CONST char *name; /* Name of function (e.g. "sin"). */ sl@0: int numArgs; /* Nnumber of arguments required by sl@0: * function. */ sl@0: Tcl_ValueType *argTypes; /* Array of types acceptable for sl@0: * each argument. */ sl@0: Tcl_MathProc *proc; /* Procedure that implements the sl@0: * math function. */ sl@0: ClientData clientData; /* Additional value to pass to the sl@0: * function. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Tcl_HashEntry *hPtr; sl@0: MathFunc *mathFuncPtr; sl@0: int new, i; sl@0: sl@0: hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); sl@0: if (new) { sl@0: Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); sl@0: } sl@0: mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); sl@0: sl@0: if (!new) { sl@0: if (mathFuncPtr->builtinFuncIndex >= 0) { sl@0: /* sl@0: * We are redefining a builtin math function. Invalidate the sl@0: * interpreter's existing code by incrementing its sl@0: * compileEpoch member. This field is checked in Tcl_EvalObj sl@0: * and ObjInterpProc, and code whose compilation epoch doesn't sl@0: * match is recompiled. Newly compiled code will no longer sl@0: * treat the function as builtin. sl@0: */ sl@0: sl@0: iPtr->compileEpoch++; sl@0: } else { sl@0: /* sl@0: * A non-builtin function is being redefined. We must invalidate sl@0: * existing code if the number of arguments has changed. This sl@0: * is because existing code was compiled assuming that number. sl@0: */ sl@0: sl@0: if (numArgs != mathFuncPtr->numArgs) { sl@0: iPtr->compileEpoch++; sl@0: } sl@0: } sl@0: } sl@0: sl@0: mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */ sl@0: if (numArgs > MAX_MATH_ARGS) { sl@0: numArgs = MAX_MATH_ARGS; sl@0: } sl@0: mathFuncPtr->numArgs = numArgs; sl@0: for (i = 0; i < numArgs; i++) { sl@0: mathFuncPtr->argTypes[i] = argTypes[i]; sl@0: } sl@0: mathFuncPtr->proc = proc; sl@0: mathFuncPtr->clientData = clientData; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetMathFuncInfo -- sl@0: * sl@0: * Discovers how a particular math function was created in a given sl@0: * interpreter. sl@0: * sl@0: * Results: sl@0: * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message sl@0: * in the interpreter result if that happens.) sl@0: * sl@0: * Side effects: sl@0: * If this function succeeds, the variables pointed to by the sl@0: * numArgsPtr and argTypePtr arguments will be updated to detail the sl@0: * arguments allowed by the function. The variable pointed to by the sl@0: * procPtr argument will be set to NULL if the function is a builtin sl@0: * function, and will be set to the address of the C function used to sl@0: * implement the math function otherwise (in which case the variable sl@0: * pointed to by the clientDataPtr argument will also be updated.) sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr, sl@0: clientDataPtr) sl@0: Tcl_Interp *interp; sl@0: CONST char *name; sl@0: int *numArgsPtr; sl@0: Tcl_ValueType **argTypesPtr; sl@0: Tcl_MathProc **procPtr; sl@0: ClientData *clientDataPtr; sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Tcl_HashEntry *hPtr; sl@0: MathFunc *mathFuncPtr; sl@0: Tcl_ValueType *argTypes; sl@0: int i,numArgs; sl@0: sl@0: hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, name); sl@0: if (hPtr == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "math function \"", name, "\" not known in this interpreter", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); sl@0: sl@0: *numArgsPtr = numArgs = mathFuncPtr->numArgs; sl@0: if (numArgs == 0) { sl@0: /* Avoid doing zero-sized allocs... */ sl@0: numArgs = 1; sl@0: } sl@0: *argTypesPtr = argTypes = sl@0: (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType)); sl@0: for (i = 0; i < mathFuncPtr->numArgs; i++) { sl@0: argTypes[i] = mathFuncPtr->argTypes[i]; sl@0: } sl@0: sl@0: if (mathFuncPtr->builtinFuncIndex == -1) { sl@0: *procPtr = (Tcl_MathProc *) NULL; sl@0: } else { sl@0: *procPtr = mathFuncPtr->proc; sl@0: *clientDataPtr = mathFuncPtr->clientData; sl@0: } sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ListMathFuncs -- sl@0: * sl@0: * Produces a list of all the math functions defined in a given sl@0: * interpreter. sl@0: * sl@0: * Results: sl@0: * A pointer to a Tcl_Obj structure with a reference count of zero, sl@0: * or NULL in the case of an error (in which case a suitable error sl@0: * message will be left in the interpreter result.) sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_ListMathFuncs(interp, pattern) sl@0: Tcl_Interp *interp; sl@0: CONST char *pattern; sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Tcl_Obj *resultList = Tcl_NewObj(); sl@0: register Tcl_HashEntry *hPtr; sl@0: Tcl_HashSearch hSearch; sl@0: CONST char *name; sl@0: sl@0: for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &hSearch); sl@0: hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { sl@0: name = Tcl_GetHashKey(&iPtr->mathFuncTable, hPtr); sl@0: if ((pattern == NULL || Tcl_StringMatch(name, pattern)) && sl@0: /* I don't expect this to fail, but... */ sl@0: Tcl_ListObjAppendElement(interp, resultList, sl@0: Tcl_NewStringObj(name,-1)) != TCL_OK) { sl@0: Tcl_DecrRefCount(resultList); sl@0: return NULL; sl@0: } sl@0: } sl@0: return resultList; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclInterpReady -- sl@0: * sl@0: * Check if an interpreter is ready to eval commands or scripts, sl@0: * i.e., if it was not deleted and if the nesting level is not sl@0: * too high. sl@0: * sl@0: * Results: sl@0: * The return value is TCL_OK if it the interpreter is ready, sl@0: * TCL_ERROR otherwise. sl@0: * sl@0: * Side effects: sl@0: * The interpreters object and string results are cleared. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclInterpReady(interp) sl@0: Tcl_Interp *interp; sl@0: { sl@0: register Interp *iPtr = (Interp *) interp; sl@0: sl@0: /* sl@0: * Reset both the interpreter's string and object results and clear sl@0: * out any previous error information. sl@0: */ sl@0: sl@0: Tcl_ResetResult(interp); sl@0: sl@0: /* sl@0: * If the interpreter has been deleted, return an error. sl@0: */ sl@0: sl@0: if (iPtr->flags & DELETED) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), sl@0: "attempt to call eval in deleted interpreter", -1); sl@0: Tcl_SetErrorCode(interp, "CORE", "IDELETE", sl@0: "attempt to call eval in deleted interpreter", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Check depth of nested calls to Tcl_Eval: if this gets too large, sl@0: * it's probably because of an infinite loop somewhere. sl@0: */ sl@0: sl@0: if (((iPtr->numLevels) > iPtr->maxNestingDepth) sl@0: || (TclpCheckStackSpace() == 0)) { sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), sl@0: "too many nested evaluations (infinite loop?)", -1); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclEvalObjvInternal -- sl@0: * sl@0: * This procedure evaluates a Tcl command that has already been sl@0: * parsed into words, with one Tcl_Obj holding each word. The caller sl@0: * is responsible for managing the iPtr->numLevels. sl@0: * sl@0: * Results: sl@0: * The return value is a standard Tcl completion code such as sl@0: * TCL_OK or TCL_ERROR. A result or error message is left in sl@0: * interp's result. If an error occurs, this procedure does sl@0: * NOT add any information to the errorInfo variable. sl@0: * sl@0: * Side effects: sl@0: * Depends on the command. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclEvalObjvInternal(interp, objc, objv, command, length, flags) sl@0: Tcl_Interp *interp; /* Interpreter in which to evaluate the sl@0: * command. Also used for error sl@0: * reporting. */ sl@0: int objc; /* Number of words in command. */ sl@0: Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are sl@0: * the words that make up the command. */ sl@0: CONST char *command; /* Points to the beginning of the string sl@0: * representation of the command; this sl@0: * is used for traces. If the string sl@0: * representation of the command is sl@0: * unknown, an empty string should be sl@0: * supplied. If it is NULL, no traces will sl@0: * be called. */ sl@0: int length; /* Number of bytes in command; if -1, all sl@0: * characters up to the first null byte are sl@0: * used. */ sl@0: int flags; /* Collection of OR-ed bits that control sl@0: * the evaluation of the script. Only sl@0: * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are sl@0: * currently supported. */ sl@0: sl@0: { sl@0: Command *cmdPtr; sl@0: Interp *iPtr = (Interp *) interp; sl@0: Tcl_Obj **newObjv; sl@0: int i; sl@0: CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr sl@0: * in case TCL_EVAL_GLOBAL was set. */ sl@0: int code = TCL_OK; sl@0: int traceCode = TCL_OK; sl@0: int checkTraces = 1; sl@0: Namespace *savedNsPtr = NULL; sl@0: sl@0: if (TclInterpReady(interp) == TCL_ERROR) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (objc == 0) { sl@0: return TCL_OK; sl@0: } sl@0: sl@0: sl@0: /* sl@0: * If any execution traces rename or delete the current command, sl@0: * we may need (at most) two passes here. sl@0: */ sl@0: sl@0: savedVarFramePtr = iPtr->varFramePtr; sl@0: while (1) { sl@0: sl@0: /* Configure evaluation context to match the requested flags */ sl@0: if (flags & TCL_EVAL_GLOBAL) { sl@0: iPtr->varFramePtr = NULL; sl@0: } else if ((flags & TCL_EVAL_INVOKE) && iPtr->varFramePtr) { sl@0: savedNsPtr = iPtr->varFramePtr->nsPtr; sl@0: iPtr->varFramePtr->nsPtr = iPtr->globalNsPtr; sl@0: } sl@0: sl@0: /* sl@0: * Find the procedure to execute this command. If there isn't one, sl@0: * then see if there is a command "unknown". If so, create a new sl@0: * word array with "unknown" as the first word and the original sl@0: * command words as arguments. Then call ourselves recursively sl@0: * to execute it. sl@0: */ sl@0: cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); sl@0: if (cmdPtr == NULL) { sl@0: newObjv = (Tcl_Obj **) ckalloc((unsigned) sl@0: ((objc + 1) * sizeof (Tcl_Obj *))); sl@0: for (i = objc-1; i >= 0; i--) { sl@0: newObjv[i+1] = objv[i]; sl@0: } sl@0: newObjv[0] = Tcl_NewStringObj("::unknown", -1); sl@0: Tcl_IncrRefCount(newObjv[0]); sl@0: cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); sl@0: if (cmdPtr == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "invalid command name \"", Tcl_GetString(objv[0]), "\"", sl@0: (char *) NULL); sl@0: code = TCL_ERROR; sl@0: } else { sl@0: iPtr->numLevels++; sl@0: code = TclEvalObjvInternal(interp, objc+1, newObjv, sl@0: command, length, 0); sl@0: iPtr->numLevels--; sl@0: } sl@0: Tcl_DecrRefCount(newObjv[0]); sl@0: ckfree((char *) newObjv); sl@0: if (savedNsPtr) { sl@0: iPtr->varFramePtr->nsPtr = savedNsPtr; sl@0: } sl@0: goto done; sl@0: } sl@0: if (savedNsPtr) { sl@0: iPtr->varFramePtr->nsPtr = savedNsPtr; sl@0: } sl@0: sl@0: /* sl@0: * Call trace procedures if needed. sl@0: */ sl@0: if ((checkTraces) && (command != NULL)) { sl@0: int cmdEpoch = cmdPtr->cmdEpoch; sl@0: int newEpoch; sl@0: sl@0: cmdPtr->refCount++; sl@0: /* sl@0: * If the first set of traces modifies/deletes the command or sl@0: * any existing traces, then the set checkTraces to 0 and sl@0: * go through this while loop one more time. sl@0: */ sl@0: if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { sl@0: traceCode = TclCheckInterpTraces(interp, command, length, sl@0: cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); sl@0: } sl@0: if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) sl@0: && (traceCode == TCL_OK)) { sl@0: traceCode = TclCheckExecutionTraces(interp, command, length, sl@0: cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); sl@0: } sl@0: newEpoch = cmdPtr->cmdEpoch; sl@0: TclCleanupCommand(cmdPtr); sl@0: if (cmdEpoch != newEpoch) { sl@0: /* The command has been modified in some way */ sl@0: checkTraces = 0; sl@0: continue; sl@0: } sl@0: } sl@0: break; sl@0: } sl@0: sl@0: /* sl@0: * Finally, invoke the command's Tcl_ObjCmdProc. sl@0: */ sl@0: cmdPtr->refCount++; sl@0: iPtr->cmdCount++; sl@0: if ( code == TCL_OK && traceCode == TCL_OK) { sl@0: code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); sl@0: } sl@0: if (Tcl_AsyncReady()) { sl@0: code = Tcl_AsyncInvoke(interp, code); sl@0: } sl@0: sl@0: /* sl@0: * Call 'leave' command traces sl@0: */ sl@0: if (!(cmdPtr->flags & CMD_IS_DELETED)) { sl@0: int saveErrFlags = iPtr->flags sl@0: & (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET); sl@0: if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { sl@0: traceCode = TclCheckExecutionTraces (interp, command, length, sl@0: cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); sl@0: } sl@0: if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { sl@0: traceCode = TclCheckInterpTraces(interp, command, length, sl@0: cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); sl@0: } sl@0: if (traceCode == TCL_OK) { sl@0: iPtr->flags |= saveErrFlags; sl@0: } sl@0: } sl@0: TclCleanupCommand(cmdPtr); sl@0: sl@0: /* sl@0: * If one of the trace invocation resulted in error, then sl@0: * change the result code accordingly. Note, that the sl@0: * interp->result should already be set correctly by the sl@0: * call to TraceExecutionProc. sl@0: */ sl@0: sl@0: if (traceCode != TCL_OK) { sl@0: code = traceCode; sl@0: } sl@0: sl@0: /* sl@0: * If the interpreter has a non-empty string result, the result sl@0: * object is either empty or stale because some procedure set sl@0: * interp->result directly. If so, move the string result to the sl@0: * result object, then reset the string result. sl@0: */ sl@0: sl@0: if (*(iPtr->result) != 0) { sl@0: (void) Tcl_GetObjResult(interp); sl@0: } sl@0: sl@0: done: sl@0: iPtr->varFramePtr = savedVarFramePtr; sl@0: return code; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_EvalObjv -- sl@0: * sl@0: * This procedure evaluates a Tcl command that has already been sl@0: * parsed into words, with one Tcl_Obj holding each word. sl@0: * sl@0: * Results: sl@0: * The return value is a standard Tcl completion code such as sl@0: * TCL_OK or TCL_ERROR. A result or error message is left in sl@0: * interp's result. sl@0: * sl@0: * Side effects: sl@0: * Depends on the command. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_EvalObjv(interp, objc, objv, flags) sl@0: Tcl_Interp *interp; /* Interpreter in which to evaluate the sl@0: * command. Also used for error sl@0: * reporting. */ sl@0: int objc; /* Number of words in command. */ sl@0: Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are sl@0: * the words that make up the command. */ sl@0: int flags; /* Collection of OR-ed bits that control sl@0: * the evaluation of the script. Only sl@0: * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE sl@0: * are currently supported. */ sl@0: { sl@0: Interp *iPtr = (Interp *)interp; sl@0: Trace *tracePtr; sl@0: Tcl_DString cmdBuf; sl@0: char *cmdString = ""; /* A command string is only necessary for sl@0: * command traces or error logs; it will be sl@0: * generated to replace this default value if sl@0: * necessary. */ sl@0: int cmdLen = 0; /* a non-zero value indicates that a command sl@0: * string was generated. */ sl@0: int code = TCL_OK; sl@0: int i; sl@0: int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); sl@0: sl@0: for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) { sl@0: if ((tracePtr->level == 0) || (iPtr->numLevels <= tracePtr->level)) { sl@0: /* sl@0: * The command may be needed for an execution trace. Generate a sl@0: * command string. sl@0: */ sl@0: sl@0: Tcl_DStringInit(&cmdBuf); sl@0: for (i = 0; i < objc; i++) { sl@0: Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); sl@0: } sl@0: cmdString = Tcl_DStringValue(&cmdBuf); sl@0: cmdLen = Tcl_DStringLength(&cmdBuf); sl@0: break; sl@0: } sl@0: } sl@0: sl@0: iPtr->numLevels++; sl@0: code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags); sl@0: iPtr->numLevels--; sl@0: sl@0: /* sl@0: * If we are again at the top level, process any unusual sl@0: * return code returned by the evaluated code. sl@0: */ sl@0: sl@0: if (iPtr->numLevels == 0) { sl@0: if (code == TCL_RETURN) { sl@0: code = TclUpdateReturnInfo(iPtr); sl@0: } sl@0: if ((code != TCL_OK) && (code != TCL_ERROR) sl@0: && !allowExceptions) { sl@0: ProcessUnexpectedResult(interp, code); sl@0: code = TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) { sl@0: sl@0: /* sl@0: * If there was an error, a command string will be needed for the sl@0: * error log: generate it now if it was not done previously. sl@0: */ sl@0: sl@0: if (cmdLen == 0) { sl@0: Tcl_DStringInit(&cmdBuf); sl@0: for (i = 0; i < objc; i++) { sl@0: Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); sl@0: } sl@0: cmdString = Tcl_DStringValue(&cmdBuf); sl@0: cmdLen = Tcl_DStringLength(&cmdBuf); sl@0: } sl@0: Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); sl@0: } sl@0: sl@0: if (cmdLen != 0) { sl@0: Tcl_DStringFree(&cmdBuf); sl@0: } sl@0: return code; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_LogCommandInfo -- sl@0: * sl@0: * This procedure is invoked after an error occurs in an interpreter. sl@0: * It adds information to the "errorInfo" variable to describe the sl@0: * command that was being executed when the error occurred. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Information about the command is added to errorInfo and the sl@0: * line number stored internally in the interpreter is set. If this sl@0: * is the first call to this procedure or Tcl_AddObjErrorInfo since sl@0: * an error occurred, then old information in errorInfo is sl@0: * deleted. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_LogCommandInfo(interp, script, command, length) sl@0: Tcl_Interp *interp; /* Interpreter in which to log information. */ sl@0: CONST char *script; /* First character in script containing sl@0: * command (must be <= command). */ sl@0: CONST char *command; /* First character in command that sl@0: * generated the error. */ sl@0: int length; /* Number of bytes in command (-1 means sl@0: * use all bytes up to first null byte). */ sl@0: { sl@0: char buffer[200]; sl@0: register CONST char *p; sl@0: char *ellipsis = ""; sl@0: Interp *iPtr = (Interp *) interp; sl@0: sl@0: if (iPtr->flags & ERR_ALREADY_LOGGED) { sl@0: /* sl@0: * Someone else has already logged error information for this sl@0: * command; we shouldn't add anything more. sl@0: */ sl@0: sl@0: return; sl@0: } sl@0: sl@0: /* sl@0: * Compute the line number where the error occurred. sl@0: */ sl@0: sl@0: iPtr->errorLine = 1; sl@0: for (p = script; p != command; p++) { sl@0: if (*p == '\n') { sl@0: iPtr->errorLine++; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Create an error message to add to errorInfo, including up to a sl@0: * maximum number of characters of the command. sl@0: */ sl@0: sl@0: if (length < 0) { sl@0: length = strlen(command); sl@0: } sl@0: if (length > 150) { sl@0: length = 150; sl@0: ellipsis = "..."; sl@0: } sl@0: while ( (command[length] & 0xC0) == 0x80 ) { sl@0: /* sl@0: * Back up truncation point so that we don't truncate in the sl@0: * middle of a multi-byte character (in UTF-8) sl@0: */ sl@0: length--; sl@0: ellipsis = "..."; sl@0: } sl@0: if (!(iPtr->flags & ERR_IN_PROGRESS)) { sl@0: sprintf(buffer, "\n while executing\n\"%.*s%s\"", sl@0: length, command, ellipsis); sl@0: } else { sl@0: sprintf(buffer, "\n invoked from within\n\"%.*s%s\"", sl@0: length, command, ellipsis); sl@0: } sl@0: Tcl_AddObjErrorInfo(interp, buffer, -1); sl@0: iPtr->flags &= ~ERR_ALREADY_LOGGED; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_EvalTokensStandard, EvalTokensStandard -- sl@0: * sl@0: * Given an array of tokens parsed from a Tcl command (e.g., the sl@0: * tokens that make up a word or the index for an array variable) sl@0: * this procedure evaluates the tokens and concatenates their sl@0: * values to form a single result value. sl@0: * sl@0: * Results: sl@0: * The return value is a standard Tcl completion code such as sl@0: * TCL_OK or TCL_ERROR. A result or error message is left in sl@0: * interp's result. sl@0: * sl@0: * Side effects: sl@0: * Depends on the array of tokens being evaled. sl@0: * sl@0: * TIP #280 : Keep public API, internally extended API. sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_EvalTokensStandard(interp, tokenPtr, count) sl@0: Tcl_Interp *interp; /* Interpreter in which to lookup sl@0: * variables, execute nested commands, sl@0: * and report errors. */ sl@0: Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens sl@0: * to evaluate and concatenate. */ sl@0: int count; /* Number of tokens to consider at tokenPtr. sl@0: * Must be at least 1. */ sl@0: { sl@0: #ifdef TCL_TIP280 sl@0: return EvalTokensStandard (interp, tokenPtr, count, 1); sl@0: } sl@0: sl@0: static int sl@0: EvalTokensStandard(interp, tokenPtr, count, line) sl@0: Tcl_Interp *interp; /* Interpreter in which to lookup sl@0: * variables, execute nested commands, sl@0: * and report errors. */ sl@0: Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens sl@0: * to evaluate and concatenate. */ sl@0: int count; /* Number of tokens to consider at tokenPtr. sl@0: * Must be at least 1. */ sl@0: int line; /* The line the script starts on. */ sl@0: { sl@0: #endif sl@0: Tcl_Obj *resultPtr, *indexPtr, *valuePtr; sl@0: char buffer[TCL_UTF_MAX]; sl@0: #ifdef TCL_MEM_DEBUG sl@0: # define MAX_VAR_CHARS 5 sl@0: #else sl@0: # define MAX_VAR_CHARS 30 sl@0: #endif sl@0: char nameBuffer[MAX_VAR_CHARS+1]; sl@0: char *varName, *index; sl@0: CONST char *p = NULL; /* Initialized to avoid compiler warning. */ sl@0: int length, code; sl@0: sl@0: /* sl@0: * The only tricky thing about this procedure is that it attempts to sl@0: * avoid object creation and string copying whenever possible. For sl@0: * example, if the value is just a nested command, then use the sl@0: * command's result object directly. sl@0: */ sl@0: sl@0: code = TCL_OK; sl@0: resultPtr = NULL; sl@0: Tcl_ResetResult(interp); sl@0: for ( ; count > 0; count--, tokenPtr++) { sl@0: valuePtr = NULL; sl@0: sl@0: /* sl@0: * The switch statement below computes the next value to be sl@0: * concat to the result, as either a range of text or an sl@0: * object. sl@0: */ sl@0: sl@0: switch (tokenPtr->type) { sl@0: case TCL_TOKEN_TEXT: sl@0: p = tokenPtr->start; sl@0: length = tokenPtr->size; sl@0: break; sl@0: sl@0: case TCL_TOKEN_BS: sl@0: length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, sl@0: buffer); sl@0: p = buffer; sl@0: break; sl@0: sl@0: case TCL_TOKEN_COMMAND: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: iPtr->numLevels++; sl@0: code = TclInterpReady(interp); sl@0: if (code == TCL_OK) { sl@0: #ifndef TCL_TIP280 sl@0: code = Tcl_EvalEx(interp, sl@0: tokenPtr->start+1, tokenPtr->size-2, 0); sl@0: #else sl@0: /* TIP #280: Transfer line information to nested command */ sl@0: code = EvalEx(interp, sl@0: tokenPtr->start+1, tokenPtr->size-2, 0, line); sl@0: #endif sl@0: } sl@0: iPtr->numLevels--; sl@0: if (code != TCL_OK) { sl@0: goto done; sl@0: } sl@0: valuePtr = Tcl_GetObjResult(interp); sl@0: break; sl@0: } sl@0: sl@0: case TCL_TOKEN_VARIABLE: sl@0: if (tokenPtr->numComponents == 1) { sl@0: indexPtr = NULL; sl@0: index = NULL; sl@0: } else { sl@0: #ifndef TCL_TIP280 sl@0: code = Tcl_EvalTokensStandard(interp, tokenPtr+2, sl@0: tokenPtr->numComponents - 1); sl@0: #else sl@0: /* TIP #280: Transfer line information to nested command */ sl@0: code = EvalTokensStandard(interp, tokenPtr+2, sl@0: tokenPtr->numComponents - 1, line); sl@0: #endif sl@0: if (code != TCL_OK) { sl@0: goto done; sl@0: } sl@0: indexPtr = Tcl_GetObjResult(interp); sl@0: Tcl_IncrRefCount(indexPtr); sl@0: index = Tcl_GetString(indexPtr); sl@0: } sl@0: sl@0: /* sl@0: * We have to make a copy of the variable name in order sl@0: * to have a null-terminated string. We can't make a sl@0: * temporary modification to the script to null-terminate sl@0: * the name, because a trace callback might potentially sl@0: * reuse the script and be affected by the null character. sl@0: */ sl@0: sl@0: if (tokenPtr[1].size <= MAX_VAR_CHARS) { sl@0: varName = nameBuffer; sl@0: } else { sl@0: varName = ckalloc((unsigned) (tokenPtr[1].size + 1)); sl@0: } sl@0: strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size); sl@0: varName[tokenPtr[1].size] = 0; sl@0: valuePtr = Tcl_GetVar2Ex(interp, varName, index, sl@0: TCL_LEAVE_ERR_MSG); sl@0: if (varName != nameBuffer) { sl@0: ckfree(varName); sl@0: } sl@0: if (indexPtr != NULL) { sl@0: Tcl_DecrRefCount(indexPtr); sl@0: } sl@0: if (valuePtr == NULL) { sl@0: code = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: count -= tokenPtr->numComponents; sl@0: tokenPtr += tokenPtr->numComponents; sl@0: break; sl@0: sl@0: default: sl@0: panic("unexpected token type in Tcl_EvalTokensStandard"); sl@0: } sl@0: sl@0: /* sl@0: * If valuePtr isn't NULL, the next piece of text comes from that sl@0: * object; otherwise, take length bytes starting at p. sl@0: */ sl@0: sl@0: if (resultPtr == NULL) { sl@0: if (valuePtr != NULL) { sl@0: resultPtr = valuePtr; sl@0: } else { sl@0: resultPtr = Tcl_NewStringObj(p, length); sl@0: } sl@0: Tcl_IncrRefCount(resultPtr); sl@0: } else { sl@0: if (Tcl_IsShared(resultPtr)) { sl@0: Tcl_DecrRefCount(resultPtr); sl@0: resultPtr = Tcl_DuplicateObj(resultPtr); sl@0: Tcl_IncrRefCount(resultPtr); sl@0: } sl@0: if (valuePtr != NULL) { sl@0: p = Tcl_GetStringFromObj(valuePtr, &length); sl@0: } sl@0: Tcl_AppendToObj(resultPtr, p, length); sl@0: } sl@0: } sl@0: if (resultPtr != NULL) { sl@0: Tcl_SetObjResult(interp, resultPtr); sl@0: } else { sl@0: code = TCL_ERROR; sl@0: } sl@0: sl@0: done: sl@0: if (resultPtr != NULL) { sl@0: Tcl_DecrRefCount(resultPtr); sl@0: } sl@0: return code; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_EvalTokens -- sl@0: * sl@0: * Given an array of tokens parsed from a Tcl command (e.g., the sl@0: * tokens that make up a word or the index for an array variable) sl@0: * this procedure evaluates the tokens and concatenates their sl@0: * values to form a single result value. sl@0: * sl@0: * Results: sl@0: * The return value is a pointer to a newly allocated Tcl_Obj sl@0: * containing the value of the array of tokens. The reference sl@0: * count of the returned object has been incremented. If an error sl@0: * occurs in evaluating the tokens then a NULL value is returned sl@0: * and an error message is left in interp's result. sl@0: * sl@0: * Side effects: sl@0: * A new object is allocated to hold the result. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * This uses a non-standard return convention; its use is now deprecated. sl@0: * It is a wrapper for the new function Tcl_EvalTokensStandard, and is not sl@0: * used in the core any longer. It is only kept for backward compatibility. sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_EvalTokens(interp, tokenPtr, count) sl@0: Tcl_Interp *interp; /* Interpreter in which to lookup sl@0: * variables, execute nested commands, sl@0: * and report errors. */ sl@0: Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens sl@0: * to evaluate and concatenate. */ sl@0: int count; /* Number of tokens to consider at tokenPtr. sl@0: * Must be at least 1. */ sl@0: { sl@0: int code; sl@0: Tcl_Obj *resPtr; sl@0: sl@0: code = Tcl_EvalTokensStandard(interp, tokenPtr, count); sl@0: if (code == TCL_OK) { sl@0: resPtr = Tcl_GetObjResult(interp); sl@0: Tcl_IncrRefCount(resPtr); sl@0: Tcl_ResetResult(interp); sl@0: return resPtr; sl@0: } else { sl@0: return NULL; sl@0: } sl@0: } sl@0: sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_EvalEx, EvalEx -- sl@0: * sl@0: * This procedure evaluates a Tcl script without using the compiler sl@0: * or byte-code interpreter. It just parses the script, creates sl@0: * values for each word of each command, then calls EvalObjv sl@0: * to execute each command. sl@0: * sl@0: * Results: sl@0: * The return value is a standard Tcl completion code such as sl@0: * TCL_OK or TCL_ERROR. A result or error message is left in sl@0: * interp's result. sl@0: * sl@0: * Side effects: sl@0: * Depends on the script. sl@0: * sl@0: * TIP #280 : Keep public API, internally extended API. sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_EvalEx(interp, script, numBytes, flags) sl@0: Tcl_Interp *interp; /* Interpreter in which to evaluate the sl@0: * script. Also used for error reporting. */ sl@0: CONST char *script; /* First character of script to evaluate. */ sl@0: int numBytes; /* Number of bytes in script. If < 0, the sl@0: * script consists of all bytes up to the sl@0: * first null character. */ sl@0: int flags; /* Collection of OR-ed bits that control sl@0: * the evaluation of the script. Only sl@0: * TCL_EVAL_GLOBAL is currently sl@0: * supported. */ sl@0: { sl@0: #ifdef TCL_TIP280 sl@0: return EvalEx (interp, script, numBytes, flags, 1); sl@0: } sl@0: sl@0: static int sl@0: EvalEx(interp, script, numBytes, flags, line) sl@0: Tcl_Interp *interp; /* Interpreter in which to evaluate the sl@0: * script. Also used for error reporting. */ sl@0: CONST char *script; /* First character of script to evaluate. */ sl@0: int numBytes; /* Number of bytes in script. If < 0, the sl@0: * script consists of all bytes up to the sl@0: * first null character. */ sl@0: int flags; /* Collection of OR-ed bits that control sl@0: * the evaluation of the script. Only sl@0: * TCL_EVAL_GLOBAL is currently sl@0: * supported. */ sl@0: int line; /* The line the script starts on. */ sl@0: { sl@0: #endif sl@0: Interp *iPtr = (Interp *) interp; sl@0: CONST char *p, *next; sl@0: Tcl_Parse parse; sl@0: #define NUM_STATIC_OBJS 20 sl@0: Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv; sl@0: Tcl_Token *tokenPtr; sl@0: int code = TCL_OK; sl@0: int i, commandLength, bytesLeft, nested; sl@0: CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr sl@0: * in case TCL_EVAL_GLOBAL was set. */ sl@0: int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); sl@0: sl@0: /* sl@0: * The variables below keep track of how much state has been sl@0: * allocated while evaluating the script, so that it can be freed sl@0: * properly if an error occurs. sl@0: */ sl@0: sl@0: int gotParse = 0, objectsUsed = 0; sl@0: sl@0: #ifdef TCL_TIP280 sl@0: /* TIP #280 Structures for tracking of command locations. */ sl@0: CmdFrame eeFrame; sl@0: #endif sl@0: sl@0: if (numBytes < 0) { sl@0: numBytes = strlen(script); sl@0: } sl@0: Tcl_ResetResult(interp); sl@0: sl@0: savedVarFramePtr = iPtr->varFramePtr; sl@0: if (flags & TCL_EVAL_GLOBAL) { sl@0: iPtr->varFramePtr = NULL; sl@0: } sl@0: sl@0: /* sl@0: * Each iteration through the following loop parses the next sl@0: * command from the script and then executes it. sl@0: */ sl@0: sl@0: objv = staticObjArray; sl@0: p = script; sl@0: bytesLeft = numBytes; sl@0: if (iPtr->evalFlags & TCL_BRACKET_TERM) { sl@0: nested = 1; sl@0: } else { sl@0: nested = 0; sl@0: } sl@0: sl@0: #ifdef TCL_TIP280 sl@0: /* TIP #280 Initialize tracking. Do not push on the frame stack yet. */ sl@0: /* sl@0: * We may cont. counting based on a specific context (CTX), or open a new sl@0: * context, either for a sourced script, or 'eval'. For sourced files we sl@0: * always have a path object, even if nothing was specified in the interp sl@0: * itself. That makes code using it simpler as NULL checks can be left sl@0: * out. Sourced file without path in the 'scriptFile' is possible during sl@0: * Tcl initialization. sl@0: */ sl@0: sl@0: if (iPtr->evalFlags & TCL_EVAL_CTX) { sl@0: /* Path information comes out of the context. */ sl@0: sl@0: eeFrame.type = TCL_LOCATION_SOURCE; sl@0: eeFrame.data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path; sl@0: Tcl_IncrRefCount (eeFrame.data.eval.path); sl@0: } else if (iPtr->evalFlags & TCL_EVAL_FILE) { sl@0: /* Set up for a sourced file */ sl@0: sl@0: eeFrame.type = TCL_LOCATION_SOURCE; sl@0: sl@0: if (iPtr->scriptFile) { sl@0: /* Normalization here, to have the correct pwd. Should have sl@0: * negligible impact on performance, as the norm should have been sl@0: * done already by the 'source' invoking us, and it caches the sl@0: * result sl@0: */ sl@0: sl@0: Tcl_Obj* norm = Tcl_FSGetNormalizedPath (interp, iPtr->scriptFile); sl@0: if (!norm) { sl@0: /* Error message in the interp result */ sl@0: return TCL_ERROR; sl@0: } sl@0: eeFrame.data.eval.path = norm; sl@0: Tcl_IncrRefCount (eeFrame.data.eval.path); sl@0: } else { sl@0: eeFrame.data.eval.path = Tcl_NewStringObj ("",-1); sl@0: } sl@0: } else { sl@0: /* Set up for plain eval */ sl@0: sl@0: eeFrame.type = TCL_LOCATION_EVAL; sl@0: eeFrame.data.eval.path = NULL; sl@0: } sl@0: sl@0: eeFrame.level = (iPtr->cmdFramePtr == NULL sl@0: ? 1 sl@0: : iPtr->cmdFramePtr->level + 1); sl@0: eeFrame.framePtr = iPtr->framePtr; sl@0: eeFrame.nextPtr = iPtr->cmdFramePtr; sl@0: eeFrame.nline = 0; sl@0: eeFrame.line = NULL; sl@0: #endif sl@0: sl@0: iPtr->evalFlags = 0; sl@0: do { sl@0: if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) sl@0: != TCL_OK) { sl@0: code = TCL_ERROR; sl@0: goto error; sl@0: } sl@0: gotParse = 1; sl@0: sl@0: if (nested && parse.term == (script + numBytes)) { sl@0: /* sl@0: * A nested script can only terminate in ']'. If sl@0: * the parsing got terminated at the end of the script, sl@0: * there was no closing ']'. Report the syntax error. sl@0: */ sl@0: sl@0: code = TCL_ERROR; sl@0: goto error; sl@0: } sl@0: sl@0: #ifdef TCL_TIP280 sl@0: /* sl@0: * TIP #280 Track lines. The parser may have skipped text till it sl@0: * found the command we are now at. We have count the lines in this sl@0: * block. sl@0: */ sl@0: sl@0: TclAdvanceLines (&line, p, parse.commandStart); sl@0: #endif sl@0: sl@0: if (parse.numWords > 0) { sl@0: #ifdef TCL_TIP280 sl@0: /* sl@0: * TIP #280. Track lines within the words of the current sl@0: * command. sl@0: */ sl@0: sl@0: int wordLine = line; sl@0: CONST char* wordStart = parse.commandStart; sl@0: #endif sl@0: sl@0: /* sl@0: * Generate an array of objects for the words of the command. sl@0: */ sl@0: sl@0: if (parse.numWords <= NUM_STATIC_OBJS) { sl@0: objv = staticObjArray; sl@0: } else { sl@0: objv = (Tcl_Obj **) ckalloc((unsigned) sl@0: (parse.numWords * sizeof (Tcl_Obj *))); sl@0: } sl@0: sl@0: #ifdef TCL_TIP280 sl@0: eeFrame.nline = parse.numWords; sl@0: eeFrame.line = (int*) ckalloc((unsigned) sl@0: (parse.numWords * sizeof (int))); sl@0: #endif sl@0: sl@0: for (objectsUsed = 0, tokenPtr = parse.tokenPtr; sl@0: objectsUsed < parse.numWords; sl@0: objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { sl@0: #ifndef TCL_TIP280 sl@0: code = Tcl_EvalTokensStandard(interp, tokenPtr+1, sl@0: tokenPtr->numComponents); sl@0: #else sl@0: /* sl@0: * TIP #280. Track lines to current word. Save the sl@0: * information on a per-word basis, signaling dynamic words as sl@0: * needed. Make the information available to the recursively sl@0: * called evaluator as well, including the type of context sl@0: * (source vs. eval). sl@0: */ sl@0: sl@0: TclAdvanceLines (&wordLine, wordStart, tokenPtr->start); sl@0: wordStart = tokenPtr->start; sl@0: sl@0: eeFrame.line [objectsUsed] = (TclWordKnownAtCompileTime (tokenPtr) sl@0: ? wordLine sl@0: : -1); sl@0: sl@0: if (eeFrame.type == TCL_LOCATION_SOURCE) { sl@0: iPtr->evalFlags |= TCL_EVAL_FILE; sl@0: } sl@0: sl@0: code = EvalTokensStandard(interp, tokenPtr+1, sl@0: tokenPtr->numComponents, wordLine); sl@0: sl@0: iPtr->evalFlags = 0; sl@0: #endif sl@0: sl@0: if (code == TCL_OK) { sl@0: objv[objectsUsed] = Tcl_GetObjResult(interp); sl@0: Tcl_IncrRefCount(objv[objectsUsed]); sl@0: } else { sl@0: goto error; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Execute the command and free the objects for its words. sl@0: * sl@0: * TIP #280: Remember the command itself for 'info frame'. We sl@0: * shorten the visible command by one char to exclude the sl@0: * termination character, if necessary. Here is where we put our sl@0: * frame on the stack of frames too. _After_ the nested commands sl@0: * have been executed. sl@0: */ sl@0: sl@0: #ifdef TCL_TIP280 sl@0: eeFrame.cmd.str.cmd = parse.commandStart; sl@0: eeFrame.cmd.str.len = parse.commandSize; sl@0: sl@0: if (parse.term == parse.commandStart + parse.commandSize - 1) { sl@0: eeFrame.cmd.str.len --; sl@0: } sl@0: sl@0: iPtr->cmdFramePtr = &eeFrame; sl@0: #endif sl@0: iPtr->numLevels++; sl@0: code = TclEvalObjvInternal(interp, objectsUsed, objv, sl@0: parse.commandStart, parse.commandSize, 0); sl@0: iPtr->numLevels--; sl@0: #ifdef TCL_TIP280 sl@0: iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; sl@0: sl@0: ckfree ((char*) eeFrame.line); sl@0: eeFrame.line = NULL; sl@0: eeFrame.nline = 0; sl@0: #endif sl@0: sl@0: if (code != TCL_OK) { sl@0: goto error; sl@0: } sl@0: for (i = 0; i < objectsUsed; i++) { sl@0: Tcl_DecrRefCount(objv[i]); sl@0: } sl@0: objectsUsed = 0; sl@0: if (objv != staticObjArray) { sl@0: ckfree((char *) objv); sl@0: objv = staticObjArray; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Advance to the next command in the script. sl@0: * sl@0: * TIP #280 Track Lines. Now we track how many lines were in the sl@0: * executed command. sl@0: */ sl@0: sl@0: next = parse.commandStart + parse.commandSize; sl@0: bytesLeft -= next - p; sl@0: p = next; sl@0: #ifdef TCL_TIP280 sl@0: TclAdvanceLines (&line, parse.commandStart, p); sl@0: #endif sl@0: Tcl_FreeParse(&parse); sl@0: gotParse = 0; sl@0: if (nested && (*parse.term == ']')) { sl@0: /* sl@0: * We get here in the special case where the TCL_BRACKET_TERM sl@0: * flag was set in the interpreter and the latest parsed command sl@0: * was terminated by the matching close-bracket we seek. sl@0: * Return immediately. sl@0: */ sl@0: sl@0: iPtr->termOffset = (p - 1) - script; sl@0: iPtr->varFramePtr = savedVarFramePtr; sl@0: #ifndef TCL_TIP280 sl@0: return TCL_OK; sl@0: #else sl@0: code = TCL_OK; sl@0: goto cleanup_return; sl@0: #endif sl@0: } sl@0: } while (bytesLeft > 0); sl@0: sl@0: if (nested) { sl@0: /* sl@0: * This nested script did not terminate in ']', it is an error. sl@0: */ sl@0: sl@0: code = TCL_ERROR; sl@0: goto error; sl@0: } sl@0: sl@0: iPtr->termOffset = p - script; sl@0: iPtr->varFramePtr = savedVarFramePtr; sl@0: #ifndef TCL_TIP280 sl@0: return TCL_OK; sl@0: #else sl@0: code = TCL_OK; sl@0: goto cleanup_return; sl@0: #endif sl@0: sl@0: error: sl@0: /* sl@0: * Generate various pieces of error information, such as the line sl@0: * number where the error occurred and information to add to the sl@0: * errorInfo variable. Then free resources that had been allocated sl@0: * to the command. sl@0: */ sl@0: sl@0: if (iPtr->numLevels == 0) { sl@0: if (code == TCL_RETURN) { sl@0: code = TclUpdateReturnInfo(iPtr); sl@0: } sl@0: if ((code != TCL_OK) && (code != TCL_ERROR) sl@0: && !allowExceptions) { sl@0: ProcessUnexpectedResult(interp, code); sl@0: code = TCL_ERROR; sl@0: } sl@0: } sl@0: if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { sl@0: commandLength = parse.commandSize; sl@0: if (parse.term == parse.commandStart + commandLength - 1) { sl@0: /* sl@0: * The terminator character (such as ; or ]) of the command where sl@0: * the error occurred is the last character in the parsed command. sl@0: * Reduce the length by one so that the error message doesn't sl@0: * include the terminator character. sl@0: */ sl@0: sl@0: commandLength -= 1; sl@0: } sl@0: Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength); sl@0: } sl@0: sl@0: for (i = 0; i < objectsUsed; i++) { sl@0: Tcl_DecrRefCount(objv[i]); sl@0: } sl@0: if (gotParse) { sl@0: Tcl_FreeParse(&parse); sl@0: } sl@0: if (objv != staticObjArray) { sl@0: ckfree((char *) objv); sl@0: } sl@0: iPtr->varFramePtr = savedVarFramePtr; sl@0: sl@0: /* sl@0: * All that's left to do before returning is to set iPtr->termOffset sl@0: * to point past the end of the script we just evaluated. sl@0: */ sl@0: sl@0: next = parse.commandStart + parse.commandSize; sl@0: bytesLeft -= next - p; sl@0: p = next; sl@0: sl@0: if (!nested) { sl@0: iPtr->termOffset = p - script; sl@0: #ifndef TCL_TIP280 sl@0: return code; sl@0: #else sl@0: goto cleanup_return; sl@0: #endif sl@0: } sl@0: sl@0: /* sl@0: * When we are nested (the TCL_BRACKET_TERM flag was set in the sl@0: * interpreter), we must find the matching close-bracket to sl@0: * end the script we are evaluating. sl@0: * sl@0: * When our return code is TCL_CONTINUE or TCL_RETURN, we want sl@0: * to correctly set iPtr->termOffset to point to that matching sl@0: * close-bracket so our caller can move to the part of the sl@0: * string beyond the script we were asked to evaluate. sl@0: * So we try to parse past the rest of the commands. sl@0: */ sl@0: sl@0: next = NULL; sl@0: while (bytesLeft && (*parse.term != ']')) { sl@0: if (TCL_OK != Tcl_ParseCommand(NULL, p, bytesLeft, 1, &parse)) { sl@0: /* sl@0: * Syntax error. Set the termOffset to the beginning of sl@0: * the last command parsed. sl@0: */ sl@0: sl@0: if (next == NULL) { sl@0: iPtr->termOffset = (parse.commandStart - 1) - script; sl@0: } else { sl@0: iPtr->termOffset = (next - 1) - script; sl@0: } sl@0: #ifndef TCL_TIP280 sl@0: return code; sl@0: #else sl@0: goto cleanup_return; sl@0: #endif sl@0: } sl@0: next = parse.commandStart + parse.commandSize; sl@0: bytesLeft -= next - p; sl@0: p = next; sl@0: next = parse.commandStart; sl@0: Tcl_FreeParse(&parse); sl@0: } sl@0: sl@0: if (bytesLeft) { sl@0: /* sl@0: * parse.term points to the close-bracket. sl@0: */ sl@0: sl@0: iPtr->termOffset = parse.term - script; sl@0: } else if (parse.term == script + numBytes) { sl@0: /* sl@0: * There was no close-bracket. Syntax error. sl@0: */ sl@0: sl@0: iPtr->termOffset = parse.term - script; sl@0: Tcl_SetObjResult(interp, sl@0: Tcl_NewStringObj("missing close-bracket", -1)); sl@0: #ifndef TCL_TIP280 sl@0: return TCL_ERROR; sl@0: #else sl@0: code = TCL_ERROR; sl@0: goto cleanup_return; sl@0: #endif sl@0: } else if (*parse.term != ']') { sl@0: /* sl@0: * There was no close-bracket. Syntax error. sl@0: */ sl@0: sl@0: iPtr->termOffset = (parse.term + 1) - script; sl@0: Tcl_SetObjResult(interp, sl@0: Tcl_NewStringObj("missing close-bracket", -1)); sl@0: #ifndef TCL_TIP280 sl@0: return TCL_ERROR; sl@0: #else sl@0: code = TCL_ERROR; sl@0: goto cleanup_return; sl@0: #endif sl@0: } else { sl@0: /* sl@0: * parse.term points to the close-bracket. sl@0: */ sl@0: iPtr->termOffset = parse.term - script; sl@0: } sl@0: sl@0: #ifdef TCL_TIP280 sl@0: cleanup_return: sl@0: /* TIP #280. Release the local CmdFrame, and its contents. */ sl@0: sl@0: if (eeFrame.line != NULL) { sl@0: ckfree ((char*) eeFrame.line); sl@0: } sl@0: if (eeFrame.type == TCL_LOCATION_SOURCE) { sl@0: Tcl_DecrRefCount (eeFrame.data.eval.path); sl@0: } sl@0: #endif sl@0: return code; sl@0: } sl@0: sl@0: #ifdef TCL_TIP280 sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclAdvanceLines -- sl@0: * sl@0: * This procedure is a helper which counts the number of lines sl@0: * in a block of text and advances an external counter. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The specified counter is advanced per the number of lines found. sl@0: * sl@0: * TIP #280 sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclAdvanceLines (line,start,end) sl@0: int* line; sl@0: CONST char* start; sl@0: CONST char* end; sl@0: { sl@0: CONST char* p; sl@0: for (p = start; p < end; p++) { sl@0: if (*p == '\n') { sl@0: (*line) ++; sl@0: } sl@0: } sl@0: } sl@0: #endif sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_Eval -- sl@0: * sl@0: * Execute a Tcl command in a string. This procedure executes the sl@0: * script directly, rather than compiling it to bytecodes. Before sl@0: * the arrival of the bytecode compiler in Tcl 8.0 Tcl_Eval was sl@0: * the main procedure used for executing Tcl commands, but nowadays sl@0: * it isn't used much. sl@0: * sl@0: * Results: sl@0: * The return value is one of the return codes defined in tcl.h sl@0: * (such as TCL_OK), and interp's result contains a value sl@0: * to supplement the return code. The value of the result sl@0: * will persist only until the next call to Tcl_Eval or Tcl_EvalObj: sl@0: * you must copy it or lose it! sl@0: * sl@0: * Side effects: sl@0: * Can be almost arbitrary, depending on the commands in the script. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_Eval(interp, string) sl@0: Tcl_Interp *interp; /* Token for command interpreter (returned sl@0: * by previous call to Tcl_CreateInterp). */ sl@0: CONST char *string; /* Pointer to TCL command to execute. */ sl@0: { sl@0: int code = Tcl_EvalEx(interp, string, -1, 0); sl@0: sl@0: /* sl@0: * For backwards compatibility with old C code that predates the sl@0: * object system in Tcl 8.0, we have to mirror the object result sl@0: * back into the string result (some callers may expect it there). sl@0: */ sl@0: sl@0: Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), sl@0: TCL_VOLATILE); sl@0: return code; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_EvalObj, Tcl_GlobalEvalObj -- sl@0: * sl@0: * These functions are deprecated but we keep them around for backwards sl@0: * compatibility reasons. sl@0: * sl@0: * Results: sl@0: * See the functions they call. sl@0: * sl@0: * Side effects: sl@0: * See the functions they call. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #undef Tcl_EvalObj sl@0: EXPORT_C int sl@0: Tcl_EvalObj(interp, objPtr) sl@0: Tcl_Interp * interp; sl@0: Tcl_Obj * objPtr; sl@0: { sl@0: return Tcl_EvalObjEx(interp, objPtr, 0); sl@0: } sl@0: sl@0: #undef Tcl_GlobalEvalObj sl@0: EXPORT_C int sl@0: Tcl_GlobalEvalObj(interp, objPtr) sl@0: Tcl_Interp * interp; sl@0: Tcl_Obj * objPtr; sl@0: { sl@0: return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_EvalObjEx, TclEvalObjEx -- sl@0: * sl@0: * Execute Tcl commands stored in a Tcl object. These commands are sl@0: * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT sl@0: * is specified. sl@0: * sl@0: * Results: sl@0: * The return value is one of the return codes defined in tcl.h sl@0: * (such as TCL_OK), and the interpreter's result contains a value sl@0: * to supplement the return code. sl@0: * sl@0: * Side effects: sl@0: * The object is converted, if necessary, to a ByteCode object that sl@0: * holds the bytecode instructions for the commands. Executing the sl@0: * commands will almost certainly have side effects that depend sl@0: * on those commands. sl@0: * sl@0: * Just as in Tcl_Eval, interp->termOffset is set to the offset of the sl@0: * last character executed in the objPtr's string. sl@0: * sl@0: * TIP #280 : Keep public API, internally extended API. sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_EvalObjEx(interp, objPtr, flags) sl@0: Tcl_Interp *interp; /* Token for command interpreter sl@0: * (returned by a previous call to sl@0: * Tcl_CreateInterp). */ sl@0: register Tcl_Obj *objPtr; /* Pointer to object containing sl@0: * commands to execute. */ sl@0: int flags; /* Collection of OR-ed bits that sl@0: * control the evaluation of the sl@0: * script. Supported values are sl@0: * TCL_EVAL_GLOBAL and sl@0: * TCL_EVAL_DIRECT. */ sl@0: { sl@0: #ifdef TCL_TIP280 sl@0: return TclEvalObjEx (interp, objPtr, flags, NULL, 0); sl@0: } sl@0: sl@0: int sl@0: TclEvalObjEx(interp, objPtr, flags, invoker, word) sl@0: Tcl_Interp *interp; /* Token for command interpreter sl@0: * (returned by a previous call to sl@0: * Tcl_CreateInterp). */ sl@0: register Tcl_Obj *objPtr; /* Pointer to object containing sl@0: * commands to execute. */ sl@0: int flags; /* Collection of OR-ed bits that sl@0: * control the evaluation of the sl@0: * script. Supported values are sl@0: * TCL_EVAL_GLOBAL and sl@0: * TCL_EVAL_DIRECT. */ sl@0: CONST CmdFrame* invoker; /* Frame of the command doing the eval */ sl@0: int word; /* Index of the word which is in objPtr */ sl@0: { sl@0: #endif sl@0: register Interp *iPtr = (Interp *) interp; sl@0: char *script; sl@0: int numSrcBytes; sl@0: int result; sl@0: CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr sl@0: * in case TCL_EVAL_GLOBAL was set. */ sl@0: int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); sl@0: sl@0: Tcl_IncrRefCount(objPtr); sl@0: sl@0: if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) { sl@0: /* sl@0: * We're not supposed to use the compiler or byte-code interpreter. sl@0: * Let Tcl_EvalEx evaluate the command directly (and probably sl@0: * more slowly). sl@0: * sl@0: * Pure List Optimization (no string representation). In this sl@0: * case, we can safely use Tcl_EvalObjv instead and get an sl@0: * appreciable improvement in execution speed. This is because it sl@0: * allows us to avoid a setFromAny step that would just pack sl@0: * everything into a string and back out again. sl@0: * sl@0: * USE_EVAL_DIRECT is a special flag used for testing purpose only sl@0: * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt) sl@0: */ sl@0: if (!(iPtr->flags & USE_EVAL_DIRECT) && sl@0: (objPtr->typePtr == &tclListType) && /* is a list... */ sl@0: (objPtr->bytes == NULL) /* ...without a string rep */) { sl@0: register List *listRepPtr = sl@0: (List *) objPtr->internalRep.twoPtrValue.ptr1; sl@0: int i, objc = listRepPtr->elemCount; sl@0: sl@0: #define TEOE_PREALLOC 10 sl@0: Tcl_Obj *staticObjv[TEOE_PREALLOC], **objv = staticObjv; sl@0: sl@0: #ifdef TCL_TIP280 sl@0: /* TIP #280 Structures for tracking lines. sl@0: * As we know that this is dynamic execution we ignore the sl@0: * invoker, even if known. sl@0: */ sl@0: int line; sl@0: CmdFrame eoFrame; sl@0: sl@0: eoFrame.type = TCL_LOCATION_EVAL_LIST; sl@0: eoFrame.level = (iPtr->cmdFramePtr == NULL ? sl@0: 1 : sl@0: iPtr->cmdFramePtr->level + 1); sl@0: eoFrame.framePtr = iPtr->framePtr; sl@0: eoFrame.nextPtr = iPtr->cmdFramePtr; sl@0: eoFrame.nline = objc; sl@0: eoFrame.line = (int*) ckalloc (objc * sizeof (int)); sl@0: sl@0: /* NOTE: Getting the string rep of the list to eval to fill the sl@0: * command information required by 'info frame' implies that sl@0: * further calls for the same list would not be optimized, as it sl@0: * would not be 'pure' anymore. It would also be a waste of time sl@0: * as most of the time this information is not needed at all. What sl@0: * we do instead is to keep the list obj itself around and have sl@0: * 'info frame' sort it out. sl@0: */ sl@0: sl@0: eoFrame.cmd.listPtr = objPtr; sl@0: Tcl_IncrRefCount (eoFrame.cmd.listPtr); sl@0: eoFrame.data.eval.path = NULL; sl@0: #endif sl@0: if (objc > TEOE_PREALLOC) { sl@0: objv = (Tcl_Obj **) ckalloc(objc*sizeof(Tcl_Obj *)); sl@0: } sl@0: #undef TEOE_PREALLOC sl@0: /* sl@0: * Copy the list elements here, to avoid a segfault if sl@0: * objPtr loses its List internal rep [Bug 1119369]. sl@0: * sl@0: * TIP #280 Computes all the line numbers for the sl@0: * words in the command. sl@0: */ sl@0: sl@0: #ifdef TCL_TIP280 sl@0: line = 1; sl@0: #endif sl@0: for (i=0; i < objc; i++) { sl@0: objv[i] = listRepPtr->elements[i]; sl@0: Tcl_IncrRefCount(objv[i]); sl@0: #ifdef TCL_TIP280 sl@0: eoFrame.line [i] = line; sl@0: { sl@0: char* w = Tcl_GetString (objv [i]); sl@0: TclAdvanceLines (&line, w, w+ strlen(w)); sl@0: } sl@0: #endif sl@0: } sl@0: sl@0: #ifdef TCL_TIP280 sl@0: iPtr->cmdFramePtr = &eoFrame; sl@0: #endif sl@0: result = Tcl_EvalObjv(interp, objc, objv, flags); sl@0: #ifdef TCL_TIP280 sl@0: iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; sl@0: Tcl_DecrRefCount (eoFrame.cmd.listPtr); sl@0: #endif sl@0: sl@0: for (i=0; i < objc; i++) { sl@0: TclDecrRefCount(objv[i]); sl@0: } sl@0: if (objv != staticObjv) { sl@0: ckfree((char *) objv); sl@0: } sl@0: #ifdef TCL_TIP280 sl@0: ckfree ((char*) eoFrame.line); sl@0: eoFrame.line = NULL; sl@0: eoFrame.nline = 0; sl@0: #endif sl@0: } else { sl@0: #ifndef TCL_TIP280 sl@0: script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); sl@0: result = Tcl_EvalEx(interp, script, numSrcBytes, flags); sl@0: #else sl@0: /* sl@0: * TIP #280. Propagate context as much as we can. Especially if sl@0: * the script to evaluate is a single literal it makes sense to sl@0: * look if our context is one with absolute line numbers we can sl@0: * then track into the literal itself too. sl@0: * sl@0: * See also tclCompile.c, TclInitCompileEnv, for the equivalent sl@0: * code in the bytecode compiler. sl@0: */ sl@0: sl@0: if (invoker == NULL) { sl@0: /* No context, force opening of our own */ sl@0: script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); sl@0: result = Tcl_EvalEx(interp, script, numSrcBytes, flags); sl@0: } else { sl@0: /* We have an invoker, describing the command asking for the sl@0: * evaluation of a subordinate script. This script may sl@0: * originate in a literal word, or from a variable, etc. Using sl@0: * the line array we now check if we have good line sl@0: * information for the relevant word. The type of context is sl@0: * relevant as well. In a non-'source' context we don't have sl@0: * to try tracking lines. sl@0: * sl@0: * First see if the word exists and is a literal. If not we go sl@0: * through the easy dynamic branch. No need to perform more sl@0: * complex invokations. sl@0: */ sl@0: sl@0: if ((invoker->nline <= word) || (invoker->line[word] < 0)) { sl@0: /* Dynamic script, or dynamic context, force our own sl@0: * context */ sl@0: sl@0: script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); sl@0: result = Tcl_EvalEx(interp, script, numSrcBytes, flags); sl@0: sl@0: } else { sl@0: /* Try to get an absolute context for the evaluation sl@0: */ sl@0: sl@0: CmdFrame ctx = *invoker; sl@0: int pc = 0; sl@0: sl@0: if (invoker->type == TCL_LOCATION_BC) { sl@0: /* Note: Type BC => ctx.data.eval.path is not used. sl@0: * ctx.data.tebc.codePtr is used instead. sl@0: */ sl@0: TclGetSrcInfoForPc (&ctx); sl@0: pc = 1; sl@0: } sl@0: sl@0: if (ctx.type == TCL_LOCATION_SOURCE) { sl@0: /* Absolute context to reuse. */ sl@0: sl@0: iPtr->invokeCmdFramePtr = &ctx; sl@0: iPtr->evalFlags |= TCL_EVAL_CTX; sl@0: sl@0: script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); sl@0: result = EvalEx(interp, script, numSrcBytes, flags, ctx.line [word]); sl@0: sl@0: if (pc) { sl@0: /* Death of SrcInfo reference */ sl@0: Tcl_DecrRefCount (ctx.data.eval.path); sl@0: } sl@0: } else { sl@0: /* Dynamic context or script, easier to make our own as sl@0: * well */ sl@0: script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); sl@0: result = Tcl_EvalEx(interp, script, numSrcBytes, flags); sl@0: } sl@0: } sl@0: } sl@0: #endif sl@0: } sl@0: } else { sl@0: /* sl@0: * Let the compiler/engine subsystem do the evaluation. sl@0: * sl@0: * TIP #280 The invoker provides us with the context for the sl@0: * script. We transfer this to the byte code compiler. sl@0: */ sl@0: sl@0: savedVarFramePtr = iPtr->varFramePtr; sl@0: if (flags & TCL_EVAL_GLOBAL) { sl@0: iPtr->varFramePtr = NULL; sl@0: } sl@0: sl@0: #ifndef TCL_TIP280 sl@0: result = TclCompEvalObj(interp, objPtr); sl@0: #else sl@0: result = TclCompEvalObj(interp, objPtr, invoker, word); sl@0: #endif sl@0: sl@0: /* sl@0: * If we are again at the top level, process any unusual sl@0: * return code returned by the evaluated code. sl@0: */ sl@0: sl@0: if (iPtr->numLevels == 0) { sl@0: if (result == TCL_RETURN) { sl@0: result = TclUpdateReturnInfo(iPtr); sl@0: } sl@0: if ((result != TCL_OK) && (result != TCL_ERROR) sl@0: && !allowExceptions) { sl@0: ProcessUnexpectedResult(interp, result); sl@0: result = TCL_ERROR; sl@0: sl@0: /* sl@0: * If an error was created here, record information about sl@0: * what was being executed when the error occurred. Remove sl@0: * the extra \n added by tclMain.c in the command sent to sl@0: * Tcl_LogCommandInfo [Bug 833150]. sl@0: */ sl@0: sl@0: if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { sl@0: script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); sl@0: Tcl_LogCommandInfo(interp, script, script, --numSrcBytes); sl@0: iPtr->flags &= ~ERR_ALREADY_LOGGED; sl@0: } sl@0: } sl@0: } sl@0: iPtr->evalFlags = 0; sl@0: iPtr->varFramePtr = savedVarFramePtr; sl@0: } sl@0: sl@0: TclDecrRefCount(objPtr); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * ProcessUnexpectedResult -- sl@0: * sl@0: * Procedure called by Tcl_EvalObj to set the interpreter's result sl@0: * value to an appropriate error message when the code it evaluates sl@0: * returns an unexpected result code (not TCL_OK and not TCL_ERROR) to sl@0: * the topmost evaluation level. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The interpreter result is set to an error message appropriate to sl@0: * the result code. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: ProcessUnexpectedResult(interp, returnCode) sl@0: Tcl_Interp *interp; /* The interpreter in which the unexpected sl@0: * result code was returned. */ sl@0: int returnCode; /* The unexpected result code. */ sl@0: { sl@0: Tcl_ResetResult(interp); sl@0: if (returnCode == TCL_BREAK) { sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), sl@0: "invoked \"break\" outside of a loop", -1); sl@0: } else if (returnCode == TCL_CONTINUE) { sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), sl@0: "invoked \"continue\" outside of a loop", -1); sl@0: } else { sl@0: char buf[30 + TCL_INTEGER_SPACE]; sl@0: sl@0: sprintf(buf, "command returned bad code: %d", returnCode); sl@0: Tcl_SetResult(interp, buf, TCL_VOLATILE); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- sl@0: * sl@0: * Procedures to evaluate an expression and return its value in a sl@0: * particular form. sl@0: * sl@0: * Results: sl@0: * Each of the procedures below returns a standard Tcl result. If an sl@0: * error occurs then an error message is left in the interp's result. sl@0: * Otherwise the value of the expression, in the appropriate form, sl@0: * is stored at *ptr. If the expression had a result that was sl@0: * incompatible with the desired form then an error is returned. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_ExprLong(interp, string, ptr) sl@0: Tcl_Interp *interp; /* Context in which to evaluate the sl@0: * expression. */ sl@0: CONST char *string; /* Expression to evaluate. */ sl@0: long *ptr; /* Where to store result. */ sl@0: { sl@0: register Tcl_Obj *exprPtr; sl@0: Tcl_Obj *resultPtr; sl@0: int length = strlen(string); sl@0: int result = TCL_OK; sl@0: sl@0: if (length > 0) { sl@0: exprPtr = Tcl_NewStringObj(string, length); sl@0: Tcl_IncrRefCount(exprPtr); sl@0: result = Tcl_ExprObj(interp, exprPtr, &resultPtr); sl@0: if (result == TCL_OK) { sl@0: /* sl@0: * Store an integer based on the expression result. sl@0: */ sl@0: sl@0: if (resultPtr->typePtr == &tclIntType) { sl@0: *ptr = resultPtr->internalRep.longValue; sl@0: } else if (resultPtr->typePtr == &tclDoubleType) { sl@0: *ptr = (long) resultPtr->internalRep.doubleValue; sl@0: } else if (resultPtr->typePtr == &tclWideIntType) { sl@0: #ifndef TCL_WIDE_INT_IS_LONG sl@0: /* sl@0: * See Tcl_GetIntFromObj for conversion comments. sl@0: */ sl@0: Tcl_WideInt w = resultPtr->internalRep.wideValue; sl@0: if ((w >= -(Tcl_WideInt)(ULONG_MAX)) sl@0: && (w <= (Tcl_WideInt)(ULONG_MAX))) { sl@0: *ptr = Tcl_WideAsLong(w); sl@0: } else { sl@0: Tcl_SetResult(interp, sl@0: "integer value too large to represent as non-long integer", sl@0: TCL_STATIC); sl@0: result = TCL_ERROR; sl@0: } sl@0: #else sl@0: *ptr = resultPtr->internalRep.longValue; sl@0: #endif sl@0: } else { sl@0: Tcl_SetResult(interp, sl@0: "expression didn't have numeric value", TCL_STATIC); sl@0: result = TCL_ERROR; sl@0: } sl@0: Tcl_DecrRefCount(resultPtr); /* discard the result object */ sl@0: } else { sl@0: /* sl@0: * Move the interpreter's object result to the string result, sl@0: * then reset the object result. sl@0: */ sl@0: sl@0: Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), sl@0: TCL_VOLATILE); sl@0: } sl@0: Tcl_DecrRefCount(exprPtr); /* discard the expression object */ sl@0: } else { sl@0: /* sl@0: * An empty string. Just set the result integer to 0. sl@0: */ sl@0: sl@0: *ptr = 0; sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: EXPORT_C int sl@0: Tcl_ExprDouble(interp, string, ptr) sl@0: Tcl_Interp *interp; /* Context in which to evaluate the sl@0: * expression. */ sl@0: CONST char *string; /* Expression to evaluate. */ sl@0: double *ptr; /* Where to store result. */ sl@0: { sl@0: register Tcl_Obj *exprPtr; sl@0: Tcl_Obj *resultPtr; sl@0: int length = strlen(string); sl@0: int result = TCL_OK; sl@0: sl@0: if (length > 0) { sl@0: exprPtr = Tcl_NewStringObj(string, length); sl@0: Tcl_IncrRefCount(exprPtr); sl@0: result = Tcl_ExprObj(interp, exprPtr, &resultPtr); sl@0: if (result == TCL_OK) { sl@0: /* sl@0: * Store a double based on the expression result. sl@0: */ sl@0: sl@0: if (resultPtr->typePtr == &tclIntType) { sl@0: *ptr = (double) resultPtr->internalRep.longValue; sl@0: } else if (resultPtr->typePtr == &tclDoubleType) { sl@0: *ptr = resultPtr->internalRep.doubleValue; sl@0: } else if (resultPtr->typePtr == &tclWideIntType) { sl@0: #ifndef TCL_WIDE_INT_IS_LONG sl@0: /* sl@0: * See Tcl_GetIntFromObj for conversion comments. sl@0: */ sl@0: Tcl_WideInt w = resultPtr->internalRep.wideValue; sl@0: if ((w >= -(Tcl_WideInt)(ULONG_MAX)) sl@0: && (w <= (Tcl_WideInt)(ULONG_MAX))) { sl@0: *ptr = (double) Tcl_WideAsLong(w); sl@0: } else { sl@0: Tcl_SetResult(interp, sl@0: "integer value too large to represent as non-long integer", sl@0: TCL_STATIC); sl@0: result = TCL_ERROR; sl@0: } sl@0: #else sl@0: *ptr = (double) resultPtr->internalRep.longValue; sl@0: #endif sl@0: } else { sl@0: Tcl_SetResult(interp, sl@0: "expression didn't have numeric value", TCL_STATIC); sl@0: result = TCL_ERROR; sl@0: } sl@0: Tcl_DecrRefCount(resultPtr); /* discard the result object */ sl@0: } else { sl@0: /* sl@0: * Move the interpreter's object result to the string result, sl@0: * then reset the object result. sl@0: */ sl@0: sl@0: Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), sl@0: TCL_VOLATILE); sl@0: } sl@0: Tcl_DecrRefCount(exprPtr); /* discard the expression object */ sl@0: } else { sl@0: /* sl@0: * An empty string. Just set the result double to 0.0. sl@0: */ sl@0: sl@0: *ptr = 0.0; sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: EXPORT_C int sl@0: Tcl_ExprBoolean(interp, string, ptr) sl@0: Tcl_Interp *interp; /* Context in which to evaluate the sl@0: * expression. */ sl@0: CONST char *string; /* Expression to evaluate. */ sl@0: int *ptr; /* Where to store 0/1 result. */ sl@0: { sl@0: register Tcl_Obj *exprPtr; sl@0: Tcl_Obj *resultPtr; sl@0: int length = strlen(string); sl@0: int result = TCL_OK; sl@0: sl@0: if (length > 0) { sl@0: exprPtr = Tcl_NewStringObj(string, length); sl@0: Tcl_IncrRefCount(exprPtr); sl@0: result = Tcl_ExprObj(interp, exprPtr, &resultPtr); sl@0: if (result == TCL_OK) { sl@0: /* sl@0: * Store a boolean based on the expression result. sl@0: */ sl@0: sl@0: if (resultPtr->typePtr == &tclIntType) { sl@0: *ptr = (resultPtr->internalRep.longValue != 0); sl@0: } else if (resultPtr->typePtr == &tclDoubleType) { sl@0: *ptr = (resultPtr->internalRep.doubleValue != 0.0); sl@0: } else if (resultPtr->typePtr == &tclWideIntType) { sl@0: #ifndef TCL_WIDE_INT_IS_LONG sl@0: *ptr = (resultPtr->internalRep.wideValue != 0); sl@0: #else sl@0: *ptr = (resultPtr->internalRep.longValue != 0); sl@0: #endif sl@0: } else { sl@0: result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); sl@0: } sl@0: Tcl_DecrRefCount(resultPtr); /* discard the result object */ sl@0: } sl@0: if (result != TCL_OK) { sl@0: /* sl@0: * Move the interpreter's object result to the string result, sl@0: * then reset the object result. sl@0: */ sl@0: sl@0: Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), sl@0: TCL_VOLATILE); sl@0: } sl@0: Tcl_DecrRefCount(exprPtr); /* discard the expression object */ sl@0: } else { sl@0: /* sl@0: * An empty string. Just set the result boolean to 0 (false). sl@0: */ sl@0: sl@0: *ptr = 0; sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *-------------------------------------------------------------- sl@0: * sl@0: * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj -- sl@0: * sl@0: * Procedures to evaluate an expression in an object and return its sl@0: * value in a particular form. sl@0: * sl@0: * Results: sl@0: * Each of the procedures below returns a standard Tcl result sl@0: * object. If an error occurs then an error message is left in the sl@0: * interpreter's result. Otherwise the value of the expression, in the sl@0: * appropriate form, is stored at *ptr. If the expression had a result sl@0: * that was incompatible with the desired form then an error is sl@0: * returned. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *-------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_ExprLongObj(interp, objPtr, ptr) sl@0: Tcl_Interp *interp; /* Context in which to evaluate the sl@0: * expression. */ sl@0: register Tcl_Obj *objPtr; /* Expression to evaluate. */ sl@0: long *ptr; /* Where to store long result. */ sl@0: { sl@0: Tcl_Obj *resultPtr; sl@0: int result; sl@0: sl@0: result = Tcl_ExprObj(interp, objPtr, &resultPtr); sl@0: if (result == TCL_OK) { sl@0: if (resultPtr->typePtr == &tclIntType) { sl@0: *ptr = resultPtr->internalRep.longValue; sl@0: } else if (resultPtr->typePtr == &tclDoubleType) { sl@0: *ptr = (long) resultPtr->internalRep.doubleValue; sl@0: } else { sl@0: result = Tcl_GetLongFromObj(interp, resultPtr, ptr); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: } sl@0: Tcl_DecrRefCount(resultPtr); /* discard the result object */ sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: EXPORT_C int sl@0: Tcl_ExprDoubleObj(interp, objPtr, ptr) sl@0: Tcl_Interp *interp; /* Context in which to evaluate the sl@0: * expression. */ sl@0: register Tcl_Obj *objPtr; /* Expression to evaluate. */ sl@0: double *ptr; /* Where to store double result. */ sl@0: { sl@0: Tcl_Obj *resultPtr; sl@0: int result; sl@0: sl@0: result = Tcl_ExprObj(interp, objPtr, &resultPtr); sl@0: if (result == TCL_OK) { sl@0: if (resultPtr->typePtr == &tclIntType) { sl@0: *ptr = (double) resultPtr->internalRep.longValue; sl@0: } else if (resultPtr->typePtr == &tclDoubleType) { sl@0: *ptr = resultPtr->internalRep.doubleValue; sl@0: } else { sl@0: result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: } sl@0: Tcl_DecrRefCount(resultPtr); /* discard the result object */ sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: EXPORT_C int sl@0: Tcl_ExprBooleanObj(interp, objPtr, ptr) sl@0: Tcl_Interp *interp; /* Context in which to evaluate the sl@0: * expression. */ sl@0: register Tcl_Obj *objPtr; /* Expression to evaluate. */ sl@0: int *ptr; /* Where to store 0/1 result. */ sl@0: { sl@0: Tcl_Obj *resultPtr; sl@0: int result; sl@0: sl@0: result = Tcl_ExprObj(interp, objPtr, &resultPtr); sl@0: if (result == TCL_OK) { sl@0: if (resultPtr->typePtr == &tclIntType) { sl@0: *ptr = (resultPtr->internalRep.longValue != 0); sl@0: } else if (resultPtr->typePtr == &tclDoubleType) { sl@0: *ptr = (resultPtr->internalRep.doubleValue != 0.0); sl@0: } else { sl@0: result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); sl@0: } sl@0: Tcl_DecrRefCount(resultPtr); /* discard the result object */ sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclInvoke -- sl@0: * sl@0: * Invokes a Tcl command, given an argv/argc, from either the sl@0: * exposed or the hidden sets of commands in the given interpreter. sl@0: * NOTE: The command is invoked in the current stack frame of sl@0: * the interpreter, thus it can modify local variables. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Whatever the command does. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclInvoke(interp, argc, argv, flags) sl@0: Tcl_Interp *interp; /* Where to invoke the command. */ sl@0: int argc; /* Count of args. */ sl@0: register CONST char **argv; /* The arg strings; argv[0] is the name of sl@0: * the command to invoke. */ sl@0: int flags; /* Combination of flags controlling the sl@0: * call: TCL_INVOKE_HIDDEN and sl@0: * TCL_INVOKE_NO_UNKNOWN. */ sl@0: { sl@0: register Tcl_Obj *objPtr; sl@0: register int i; sl@0: int length, result; sl@0: sl@0: /* sl@0: * This procedure generates an objv array for object arguments that hold sl@0: * the argv strings. It starts out with stack-allocated space but uses sl@0: * dynamically-allocated storage if needed. sl@0: */ sl@0: sl@0: #define NUM_ARGS 20 sl@0: Tcl_Obj *(objStorage[NUM_ARGS]); sl@0: register Tcl_Obj **objv = objStorage; sl@0: sl@0: /* sl@0: * Create the object argument array "objv". Make sure objv is large sl@0: * enough to hold the objc arguments plus 1 extra for the zero sl@0: * end-of-objv word. sl@0: */ sl@0: sl@0: if ((argc + 1) > NUM_ARGS) { sl@0: objv = (Tcl_Obj **) sl@0: ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); sl@0: } sl@0: sl@0: for (i = 0; i < argc; i++) { sl@0: length = strlen(argv[i]); sl@0: objv[i] = Tcl_NewStringObj(argv[i], length); sl@0: Tcl_IncrRefCount(objv[i]); sl@0: } sl@0: objv[argc] = 0; sl@0: sl@0: /* sl@0: * Use TclObjInterpProc to actually invoke the command. sl@0: */ sl@0: sl@0: result = TclObjInvoke(interp, argc, objv, flags); sl@0: sl@0: /* sl@0: * Move the interpreter's object result to the string result, sl@0: * then reset the object result. sl@0: */ sl@0: sl@0: Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), sl@0: TCL_VOLATILE); sl@0: sl@0: /* sl@0: * Decrement the ref counts on the objv elements since we are done sl@0: * with them. sl@0: */ sl@0: sl@0: for (i = 0; i < argc; i++) { sl@0: objPtr = objv[i]; sl@0: Tcl_DecrRefCount(objPtr); sl@0: } sl@0: sl@0: /* sl@0: * Free the objv array if malloc'ed storage was used. sl@0: */ sl@0: sl@0: if (objv != objStorage) { sl@0: ckfree((char *) objv); sl@0: } sl@0: return result; sl@0: #undef NUM_ARGS sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclGlobalInvoke -- sl@0: * sl@0: * Invokes a Tcl command, given an argv/argc, from either the sl@0: * exposed or hidden sets of commands in the given interpreter. sl@0: * NOTE: The command is invoked in the global stack frame of sl@0: * the interpreter, thus it cannot see any current state on sl@0: * the stack for that interpreter. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Whatever the command does. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclGlobalInvoke(interp, argc, argv, flags) sl@0: Tcl_Interp *interp; /* Where to invoke the command. */ sl@0: int argc; /* Count of args. */ sl@0: register CONST char **argv; /* The arg strings; argv[0] is the name of sl@0: * the command to invoke. */ sl@0: int flags; /* Combination of flags controlling the sl@0: * call: TCL_INVOKE_HIDDEN and sl@0: * TCL_INVOKE_NO_UNKNOWN. */ sl@0: { sl@0: register Interp *iPtr = (Interp *) interp; sl@0: int result; sl@0: CallFrame *savedVarFramePtr; sl@0: sl@0: savedVarFramePtr = iPtr->varFramePtr; sl@0: iPtr->varFramePtr = NULL; sl@0: result = TclInvoke(interp, argc, argv, flags); sl@0: iPtr->varFramePtr = savedVarFramePtr; sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclObjInvokeGlobal -- sl@0: * sl@0: * Object version: Invokes a Tcl command, given an objv/objc, from sl@0: * either the exposed or hidden set of commands in the given sl@0: * interpreter. sl@0: * NOTE: The command is invoked in the global stack frame of the sl@0: * interpreter, thus it cannot see any current state on the sl@0: * stack of that interpreter. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Whatever the command does. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclObjInvokeGlobal(interp, objc, objv, flags) sl@0: Tcl_Interp *interp; /* Interpreter in which command is to be sl@0: * invoked. */ sl@0: int objc; /* Count of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the sl@0: * name of the command to invoke. */ sl@0: int flags; /* Combination of flags controlling the sl@0: * call: TCL_INVOKE_HIDDEN, sl@0: * TCL_INVOKE_NO_UNKNOWN, or sl@0: * TCL_INVOKE_NO_TRACEBACK. */ sl@0: { sl@0: register Interp *iPtr = (Interp *) interp; sl@0: int result; sl@0: CallFrame *savedVarFramePtr; sl@0: sl@0: savedVarFramePtr = iPtr->varFramePtr; sl@0: iPtr->varFramePtr = NULL; sl@0: result = TclObjInvoke(interp, objc, objv, flags); sl@0: iPtr->varFramePtr = savedVarFramePtr; sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclObjInvoke -- sl@0: * sl@0: * Invokes a Tcl command, given an objv/objc, from either the sl@0: * exposed or the hidden sets of commands in the given interpreter. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result. sl@0: * sl@0: * Side effects: sl@0: * Whatever the command does. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclObjInvoke(interp, objc, objv, flags) sl@0: Tcl_Interp *interp; /* Interpreter in which command is to be sl@0: * invoked. */ sl@0: int objc; /* Count of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the sl@0: * name of the command to invoke. */ sl@0: int flags; /* Combination of flags controlling the sl@0: * call: TCL_INVOKE_HIDDEN, sl@0: * TCL_INVOKE_NO_UNKNOWN, or sl@0: * TCL_INVOKE_NO_TRACEBACK. */ sl@0: { sl@0: register Interp *iPtr = (Interp *) interp; sl@0: Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ sl@0: char *cmdName; /* Name of the command from objv[0]. */ sl@0: register Tcl_HashEntry *hPtr; sl@0: Tcl_Command cmd; sl@0: Command *cmdPtr; sl@0: int localObjc; /* Used to invoke "unknown" if the */ sl@0: Tcl_Obj **localObjv = NULL; /* command is not found. */ sl@0: register int i; sl@0: int result; sl@0: sl@0: if (interp == (Tcl_Interp *) NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) { sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), sl@0: "illegal argument vector", -1); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: cmdName = Tcl_GetString(objv[0]); sl@0: if (flags & TCL_INVOKE_HIDDEN) { sl@0: /* sl@0: * We never invoke "unknown" for hidden commands. sl@0: */ sl@0: sl@0: hPtr = NULL; sl@0: hTblPtr = ((Interp *) interp)->hiddenCmdTablePtr; sl@0: if (hTblPtr != NULL) { sl@0: hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); sl@0: } sl@0: if (hPtr == NULL) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "invalid hidden command name \"", cmdName, "\"", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: cmdPtr = (Command *) Tcl_GetHashValue(hPtr); sl@0: } else { sl@0: cmdPtr = NULL; sl@0: cmd = Tcl_FindCommand(interp, cmdName, sl@0: (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); sl@0: if (cmd != (Tcl_Command) NULL) { sl@0: cmdPtr = (Command *) cmd; sl@0: } sl@0: if (cmdPtr == NULL) { sl@0: if (!(flags & TCL_INVOKE_NO_UNKNOWN)) { sl@0: cmd = Tcl_FindCommand(interp, "unknown", sl@0: (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); sl@0: if (cmd != (Tcl_Command) NULL) { sl@0: cmdPtr = (Command *) cmd; sl@0: } sl@0: if (cmdPtr != NULL) { sl@0: localObjc = (objc + 1); sl@0: localObjv = (Tcl_Obj **) sl@0: ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc)); sl@0: localObjv[0] = Tcl_NewStringObj("unknown", -1); sl@0: Tcl_IncrRefCount(localObjv[0]); sl@0: for (i = 0; i < objc; i++) { sl@0: localObjv[i+1] = objv[i]; sl@0: } sl@0: objc = localObjc; sl@0: objv = localObjv; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Check again if we found the command. If not, "unknown" is sl@0: * not present and we cannot help, or the caller said not to sl@0: * call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN). sl@0: */ sl@0: sl@0: if (cmdPtr == NULL) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "invalid command name \"", cmdName, "\"", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Invoke the command procedure. First reset the interpreter's string sl@0: * and object results to their default empty values since they could sl@0: * have gotten changed by earlier invocations. sl@0: */ sl@0: sl@0: Tcl_ResetResult(interp); sl@0: iPtr->cmdCount++; sl@0: result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); sl@0: sl@0: /* sl@0: * If an error occurred, record information about what was being sl@0: * executed when the error occurred. sl@0: */ sl@0: sl@0: if ((result == TCL_ERROR) sl@0: && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) sl@0: && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { sl@0: Tcl_Obj *msg; sl@0: sl@0: if (!(iPtr->flags & ERR_IN_PROGRESS)) { sl@0: msg = Tcl_NewStringObj("\n while invoking\n\"", -1); sl@0: } else { sl@0: msg = Tcl_NewStringObj("\n invoked from within\n\"", -1); sl@0: } sl@0: Tcl_IncrRefCount(msg); sl@0: for (i = 0; i < objc; i++) { sl@0: CONST char *bytes; sl@0: int length; sl@0: sl@0: Tcl_AppendObjToObj(msg, objv[i]); sl@0: bytes = Tcl_GetStringFromObj(msg, &length); sl@0: if (length > 100) { sl@0: /* sl@0: * Back up truncation point so that we don't truncate sl@0: * in the middle of a multi-byte character. sl@0: */ sl@0: length = 100; sl@0: while ( (bytes[length] & 0xC0) == 0x80 ) { sl@0: length--; sl@0: } sl@0: Tcl_SetObjLength(msg, length); sl@0: Tcl_AppendToObj(msg, "...", -1); sl@0: break; sl@0: } sl@0: if (i != (objc - 1)) { sl@0: Tcl_AppendToObj(msg, " ", -1); sl@0: } sl@0: } sl@0: sl@0: Tcl_AppendToObj(msg, "\"", -1); sl@0: Tcl_AddObjErrorInfo(interp, Tcl_GetString(msg), -1); sl@0: Tcl_DecrRefCount(msg); sl@0: iPtr->flags &= ~ERR_ALREADY_LOGGED; sl@0: } sl@0: sl@0: /* sl@0: * Free any locally allocated storage used to call "unknown". sl@0: */ sl@0: sl@0: if (localObjv != (Tcl_Obj **) NULL) { sl@0: Tcl_DecrRefCount(localObjv[0]); sl@0: ckfree((char *) localObjv); sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ExprString -- sl@0: * sl@0: * Evaluate an expression in a string and return its value in string sl@0: * form. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. If the result is TCL_OK, then the interp's sl@0: * result is set to the string value of the expression. If the result sl@0: * is TCL_ERROR, then the interp's result contains an error message. sl@0: * sl@0: * Side effects: sl@0: * A Tcl object is allocated to hold a copy of the expression string. sl@0: * This expression object is passed to Tcl_ExprObj and then sl@0: * deallocated. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_ExprString(interp, string) sl@0: Tcl_Interp *interp; /* Context in which to evaluate the sl@0: * expression. */ sl@0: CONST char *string; /* Expression to evaluate. */ sl@0: { sl@0: register Tcl_Obj *exprPtr; sl@0: Tcl_Obj *resultPtr; sl@0: int length = strlen(string); sl@0: char buf[TCL_DOUBLE_SPACE]; sl@0: int result = TCL_OK; sl@0: sl@0: if (length > 0) { sl@0: TclNewObj(exprPtr); sl@0: TclInitStringRep(exprPtr, string, length); sl@0: Tcl_IncrRefCount(exprPtr); sl@0: sl@0: result = Tcl_ExprObj(interp, exprPtr, &resultPtr); sl@0: if (result == TCL_OK) { sl@0: /* sl@0: * Set the interpreter's string result from the result object. sl@0: */ sl@0: sl@0: if (resultPtr->typePtr == &tclIntType) { sl@0: sprintf(buf, "%ld", resultPtr->internalRep.longValue); sl@0: Tcl_SetResult(interp, buf, TCL_VOLATILE); sl@0: } else if (resultPtr->typePtr == &tclDoubleType) { sl@0: Tcl_PrintDouble((Tcl_Interp *) NULL, sl@0: resultPtr->internalRep.doubleValue, buf); sl@0: Tcl_SetResult(interp, buf, TCL_VOLATILE); sl@0: } else { sl@0: /* sl@0: * Set interpreter's string result from the result object. sl@0: */ sl@0: sl@0: Tcl_SetResult(interp, TclGetString(resultPtr), sl@0: TCL_VOLATILE); sl@0: } sl@0: Tcl_DecrRefCount(resultPtr); /* discard the result object */ sl@0: } else { sl@0: /* sl@0: * Move the interpreter's object result to the string result, sl@0: * then reset the object result. sl@0: */ sl@0: sl@0: Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), sl@0: TCL_VOLATILE); sl@0: } sl@0: Tcl_DecrRefCount(exprPtr); /* discard the expression object */ sl@0: } else { sl@0: /* sl@0: * An empty string. Just set the interpreter's result to 0. sl@0: */ sl@0: sl@0: Tcl_SetResult(interp, "0", TCL_VOLATILE); sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_CreateObjTrace -- sl@0: * sl@0: * Arrange for a procedure to be called to trace command execution. sl@0: * sl@0: * Results: sl@0: * The return value is a token for the trace, which may be passed sl@0: * to Tcl_DeleteTrace to eliminate the trace. sl@0: * sl@0: * Side effects: sl@0: * From now on, proc will be called just before a command procedure sl@0: * is called to execute a Tcl command. Calls to proc will have the sl@0: * following form: sl@0: * sl@0: * void proc( ClientData clientData, sl@0: * Tcl_Interp* interp, sl@0: * int level, sl@0: * CONST char* command, sl@0: * Tcl_Command commandInfo, sl@0: * int objc, sl@0: * Tcl_Obj *CONST objv[] ); sl@0: * sl@0: * The 'clientData' and 'interp' arguments to 'proc' will be the sl@0: * same as the arguments to Tcl_CreateObjTrace. The 'level' sl@0: * argument gives the nesting depth of command interpretation within sl@0: * the interpreter. The 'command' argument is the ASCII text of sl@0: * the command being evaluated -- before any substitutions are sl@0: * performed. The 'commandInfo' argument gives a handle to the sl@0: * command procedure that will be evaluated. The 'objc' and 'objv' sl@0: * parameters give the parameter vector that will be passed to the sl@0: * command procedure. proc does not return a value. sl@0: * sl@0: * It is permissible for 'proc' to call Tcl_SetCommandTokenInfo sl@0: * to change the command procedure or client data for the command sl@0: * being evaluated, and these changes will take effect with the sl@0: * current evaluation. sl@0: * sl@0: * The 'level' argument specifies the maximum nesting level of calls sl@0: * to be traced. If the execution depth of the interpreter exceeds sl@0: * 'level', the trace callback is not executed. sl@0: * sl@0: * The 'flags' argument is either zero or the value, sl@0: * TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION sl@0: * flag is not present, the bytecode compiler will not generate inline sl@0: * code for Tcl's built-in commands. This behavior will have a significant sl@0: * impact on performance, but will ensure that all command evaluations are sl@0: * traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the sl@0: * bytecode compiler will have its normal behavior of compiling in-line sl@0: * code for some of Tcl's built-in commands. In this case, the tracing sl@0: * will be imprecise -- in-line code will not be traced -- but run-time sl@0: * performance will be improved. The latter behavior is desired for sl@0: * many applications such as profiling of run time. sl@0: * sl@0: * When the trace is deleted, the 'delProc' procedure will be invoked, sl@0: * passing it the original client data. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Trace sl@0: Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc ) sl@0: Tcl_Interp* interp; /* Tcl interpreter */ sl@0: int level; /* Maximum nesting level */ sl@0: int flags; /* Flags, see above */ sl@0: Tcl_CmdObjTraceProc* proc; /* Trace callback */ sl@0: ClientData clientData; /* Client data for the callback */ sl@0: Tcl_CmdObjTraceDeleteProc* delProc; sl@0: /* Procedure to call when trace is deleted */ sl@0: { sl@0: register Trace *tracePtr; sl@0: register Interp *iPtr = (Interp *) interp; sl@0: sl@0: /* Test if this trace allows inline compilation of commands */ sl@0: sl@0: if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) { sl@0: if (iPtr->tracesForbiddingInline == 0) { sl@0: sl@0: /* sl@0: * When the first trace forbidding inline compilation is sl@0: * created, invalidate existing compiled code for this sl@0: * interpreter and arrange (by setting the sl@0: * DONT_COMPILE_CMDS_INLINE flag) that when compiling new sl@0: * code, no commands will be compiled inline (i.e., into sl@0: * an inline sequence of instructions). We do this because sl@0: * commands that were compiled inline will never result in sl@0: * a command trace being called. sl@0: */ sl@0: sl@0: iPtr->compileEpoch++; sl@0: iPtr->flags |= DONT_COMPILE_CMDS_INLINE; sl@0: } sl@0: iPtr->tracesForbiddingInline++; sl@0: } sl@0: sl@0: tracePtr = (Trace *) ckalloc(sizeof(Trace)); sl@0: tracePtr->level = level; sl@0: tracePtr->proc = proc; sl@0: tracePtr->clientData = clientData; sl@0: tracePtr->delProc = delProc; sl@0: tracePtr->nextPtr = iPtr->tracePtr; sl@0: tracePtr->flags = flags; sl@0: iPtr->tracePtr = tracePtr; sl@0: sl@0: return (Tcl_Trace) tracePtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_CreateTrace -- sl@0: * sl@0: * Arrange for a procedure to be called to trace command execution. sl@0: * sl@0: * Results: sl@0: * The return value is a token for the trace, which may be passed sl@0: * to Tcl_DeleteTrace to eliminate the trace. sl@0: * sl@0: * Side effects: sl@0: * From now on, proc will be called just before a command procedure sl@0: * is called to execute a Tcl command. Calls to proc will have the sl@0: * following form: sl@0: * sl@0: * void sl@0: * proc(clientData, interp, level, command, cmdProc, cmdClientData, sl@0: * argc, argv) sl@0: * ClientData clientData; sl@0: * Tcl_Interp *interp; sl@0: * int level; sl@0: * char *command; sl@0: * int (*cmdProc)(); sl@0: * ClientData cmdClientData; sl@0: * int argc; sl@0: * char **argv; sl@0: * { sl@0: * } sl@0: * sl@0: * The clientData and interp arguments to proc will be the same sl@0: * as the corresponding arguments to this procedure. Level gives sl@0: * the nesting level of command interpretation for this interpreter sl@0: * (0 corresponds to top level). Command gives the ASCII text of sl@0: * the raw command, cmdProc and cmdClientData give the procedure that sl@0: * will be called to process the command and the ClientData value it sl@0: * will receive, and argc and argv give the arguments to the sl@0: * command, after any argument parsing and substitution. Proc sl@0: * does not return a value. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Trace sl@0: Tcl_CreateTrace(interp, level, proc, clientData) sl@0: Tcl_Interp *interp; /* Interpreter in which to create trace. */ sl@0: int level; /* Only call proc for commands at nesting sl@0: * level<=argument level (1=>top level). */ sl@0: Tcl_CmdTraceProc *proc; /* Procedure to call before executing each sl@0: * command. */ sl@0: ClientData clientData; /* Arbitrary value word to pass to proc. */ sl@0: { sl@0: StringTraceData* data; sl@0: data = (StringTraceData*) ckalloc( sizeof( *data )); sl@0: data->clientData = clientData; sl@0: data->proc = proc; sl@0: return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc, sl@0: (ClientData) data, StringTraceDeleteProc ); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * StringTraceProc -- sl@0: * sl@0: * Invoke a string-based trace procedure from an object-based sl@0: * callback. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Whatever the string-based trace procedure does. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv ) sl@0: ClientData clientData; sl@0: Tcl_Interp* interp; sl@0: int level; sl@0: CONST char* command; sl@0: Tcl_Command commandInfo; sl@0: int objc; sl@0: Tcl_Obj *CONST *objv; sl@0: { sl@0: StringTraceData* data = (StringTraceData*) clientData; sl@0: Command* cmdPtr = (Command*) commandInfo; sl@0: sl@0: CONST char** argv; /* Args to pass to string trace proc */ sl@0: sl@0: int i; sl@0: sl@0: /* sl@0: * This is a bit messy because we have to emulate the old trace sl@0: * interface, which uses strings for everything. sl@0: */ sl@0: sl@0: argv = (CONST char **) ckalloc((unsigned) ( (objc + 1) sl@0: * sizeof(CONST char *) )); sl@0: for (i = 0; i < objc; i++) { sl@0: argv[i] = Tcl_GetString(objv[i]); sl@0: } sl@0: argv[objc] = 0; sl@0: sl@0: /* sl@0: * Invoke the command procedure. Note that we cast away const-ness sl@0: * on two parameters for compatibility with legacy code; the code sl@0: * MUST NOT modify either command or argv. sl@0: */ sl@0: sl@0: ( data->proc )( data->clientData, interp, level, sl@0: (char*) command, cmdPtr->proc, cmdPtr->clientData, sl@0: objc, argv ); sl@0: ckfree( (char*) argv ); sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * StringTraceDeleteProc -- sl@0: * sl@0: * Clean up memory when a string-based trace is deleted. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Allocated memory is returned to the system. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: StringTraceDeleteProc( clientData ) sl@0: ClientData clientData; sl@0: { sl@0: ckfree( (char*) clientData ); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DeleteTrace -- sl@0: * sl@0: * Remove a trace. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * From now on there will be no more calls to the procedure given sl@0: * in trace. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_DeleteTrace(interp, trace) sl@0: Tcl_Interp *interp; /* Interpreter that contains trace. */ sl@0: Tcl_Trace trace; /* Token for trace (returned previously by sl@0: * Tcl_CreateTrace). */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Trace *prevPtr, *tracePtr = (Trace *) trace; sl@0: register Trace **tracePtr2 = &(iPtr->tracePtr); sl@0: ActiveInterpTrace *activePtr; sl@0: sl@0: /* sl@0: * Locate the trace entry in the interpreter's trace list, sl@0: * and remove it from the list. sl@0: */ sl@0: sl@0: prevPtr = NULL; sl@0: while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) { sl@0: prevPtr = *tracePtr2; sl@0: tracePtr2 = &((*tracePtr2)->nextPtr); sl@0: } sl@0: if (*tracePtr2 == NULL) { sl@0: return; sl@0: } sl@0: (*tracePtr2) = (*tracePtr2)->nextPtr; sl@0: sl@0: /* sl@0: * The code below makes it possible to delete traces while traces sl@0: * are active: it makes sure that the deleted trace won't be sl@0: * processed by TclCheckInterpTraces. sl@0: */ sl@0: sl@0: for (activePtr = iPtr->activeInterpTracePtr; activePtr != NULL; sl@0: activePtr = activePtr->nextPtr) { sl@0: if (activePtr->nextTracePtr == tracePtr) { sl@0: if (activePtr->reverseScan) { sl@0: activePtr->nextTracePtr = prevPtr; sl@0: } else { sl@0: activePtr->nextTracePtr = tracePtr->nextPtr; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * If the trace forbids bytecode compilation, change the interpreter's sl@0: * state. If bytecode compilation is now permitted, flag the fact and sl@0: * advance the compilation epoch so that procs will be recompiled to sl@0: * take advantage of it. sl@0: */ sl@0: sl@0: if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) { sl@0: iPtr->tracesForbiddingInline--; sl@0: if (iPtr->tracesForbiddingInline == 0) { sl@0: iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; sl@0: iPtr->compileEpoch++; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Execute any delete callback. sl@0: */ sl@0: sl@0: if (tracePtr->delProc != NULL) { sl@0: (tracePtr->delProc)(tracePtr->clientData); sl@0: } sl@0: sl@0: /* Delete the trace object */ sl@0: sl@0: Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_AddErrorInfo -- sl@0: * sl@0: * Add information to the "errorInfo" variable that describes the sl@0: * current error. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The contents of message are added to the "errorInfo" variable. sl@0: * If Tcl_Eval has been called since the current value of errorInfo sl@0: * was set, errorInfo is cleared before adding the new message. sl@0: * If we are just starting to log an error, errorInfo is initialized sl@0: * from the error message in the interpreter's result. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_AddErrorInfo(interp, message) sl@0: Tcl_Interp *interp; /* Interpreter to which error information sl@0: * pertains. */ sl@0: CONST char *message; /* Message to record. */ sl@0: { sl@0: Tcl_AddObjErrorInfo(interp, message, -1); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_AddObjErrorInfo -- sl@0: * sl@0: * Add information to the "errorInfo" variable that describes the sl@0: * current error. This routine differs from Tcl_AddErrorInfo by sl@0: * taking a byte pointer and length. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * "length" bytes from "message" are added to the "errorInfo" variable. sl@0: * If "length" is negative, use bytes up to the first NULL byte. sl@0: * If Tcl_EvalObj has been called since the current value of errorInfo sl@0: * was set, errorInfo is cleared before adding the new message. sl@0: * If we are just starting to log an error, errorInfo is initialized sl@0: * from the error message in the interpreter's result. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_AddObjErrorInfo(interp, message, length) sl@0: Tcl_Interp *interp; /* Interpreter to which error information sl@0: * pertains. */ sl@0: CONST char *message; /* Points to the first byte of an array of sl@0: * bytes of the message. */ sl@0: int length; /* The number of bytes in the message. sl@0: * If < 0, then append all bytes up to a sl@0: * NULL byte. */ sl@0: { sl@0: register Interp *iPtr = (Interp *) interp; sl@0: Tcl_Obj *objPtr; sl@0: sl@0: /* sl@0: * If we are just starting to log an error, errorInfo is initialized sl@0: * from the error message in the interpreter's result. sl@0: */ sl@0: sl@0: if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */ sl@0: iPtr->flags |= ERR_IN_PROGRESS; sl@0: sl@0: if (iPtr->result[0] == 0) { sl@0: Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, sl@0: iPtr->objResultPtr, TCL_GLOBAL_ONLY); sl@0: } else { /* use the string result */ sl@0: objPtr = Tcl_NewStringObj(interp->result, -1); sl@0: Tcl_IncrRefCount(objPtr); sl@0: Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, sl@0: objPtr, TCL_GLOBAL_ONLY); sl@0: Tcl_DecrRefCount(objPtr); sl@0: } sl@0: sl@0: /* sl@0: * If the errorCode variable wasn't set by the code that generated sl@0: * the error, set it to "NONE". sl@0: */ sl@0: sl@0: if (!(iPtr->flags & ERROR_CODE_SET)) { sl@0: objPtr = Tcl_NewStringObj("NONE", -1); sl@0: Tcl_IncrRefCount(objPtr); sl@0: Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL, sl@0: objPtr, TCL_GLOBAL_ONLY); sl@0: Tcl_DecrRefCount(objPtr); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Now append "message" to the end of errorInfo. sl@0: */ sl@0: sl@0: if (length != 0) { sl@0: objPtr = Tcl_NewStringObj(message, length); sl@0: Tcl_IncrRefCount(objPtr); sl@0: Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, sl@0: objPtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); sl@0: Tcl_DecrRefCount(objPtr); /* free msg object appended above */ sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_VarEvalVA -- sl@0: * sl@0: * Given a variable number of string arguments, concatenate them sl@0: * all together and execute the result as a Tcl command. sl@0: * sl@0: * Results: sl@0: * A standard Tcl return result. An error message or other result may sl@0: * be left in the interp's result. sl@0: * sl@0: * Side effects: sl@0: * Depends on what was done by the command. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_VarEvalVA (interp, argList) sl@0: Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ sl@0: va_list argList; /* Variable argument list. */ sl@0: { sl@0: Tcl_DString buf; sl@0: char *string; sl@0: int result; sl@0: sl@0: /* sl@0: * Copy the strings one after the other into a single larger sl@0: * string. Use stack-allocated space for small commands, but if sl@0: * the command gets too large than call ckalloc to create the sl@0: * space. sl@0: */ sl@0: sl@0: Tcl_DStringInit(&buf); sl@0: while (1) { sl@0: string = va_arg(argList, char *); sl@0: if (string == NULL) { sl@0: break; sl@0: } sl@0: Tcl_DStringAppend(&buf, string, -1); sl@0: } sl@0: sl@0: result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); sl@0: Tcl_DStringFree(&buf); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_VarEval -- sl@0: * sl@0: * Given a variable number of string arguments, concatenate them sl@0: * all together and execute the result as a Tcl command. sl@0: * sl@0: * Results: sl@0: * A standard Tcl return result. An error message or other sl@0: * result may be left in interp->result. sl@0: * sl@0: * Side effects: sl@0: * Depends on what was done by the command. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: /* VARARGS2 */ /* ARGSUSED */ sl@0: EXPORT_C int sl@0: Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) sl@0: { sl@0: Tcl_Interp *interp; sl@0: va_list argList; sl@0: int result; sl@0: sl@0: interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); sl@0: result = Tcl_VarEvalVA(interp, argList); sl@0: va_end(argList); sl@0: sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GlobalEval -- sl@0: * sl@0: * Evaluate a command at global level in an interpreter. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result is returned, and the interp's result is sl@0: * modified accordingly. sl@0: * sl@0: * Side effects: sl@0: * The command string is executed in interp, and the execution sl@0: * is carried out in the variable context of global level (no sl@0: * procedures active), just as if an "uplevel #0" command were sl@0: * being executed. sl@0: * sl@0: --------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_GlobalEval(interp, command) sl@0: Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ sl@0: CONST char *command; /* Command to evaluate. */ sl@0: { sl@0: register Interp *iPtr = (Interp *) interp; sl@0: int result; sl@0: CallFrame *savedVarFramePtr; sl@0: sl@0: savedVarFramePtr = iPtr->varFramePtr; sl@0: iPtr->varFramePtr = NULL; sl@0: result = Tcl_Eval(interp, command); sl@0: iPtr->varFramePtr = savedVarFramePtr; sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetRecursionLimit -- sl@0: * sl@0: * Set the maximum number of recursive calls that may be active sl@0: * for an interpreter at once. sl@0: * sl@0: * Results: sl@0: * The return value is the old limit on nesting for interp. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_SetRecursionLimit(interp, depth) sl@0: Tcl_Interp *interp; /* Interpreter whose nesting limit sl@0: * is to be set. */ sl@0: int depth; /* New value for maximimum depth. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: int old; sl@0: sl@0: old = iPtr->maxNestingDepth; sl@0: if (depth > 0) { sl@0: iPtr->maxNestingDepth = depth; sl@0: } sl@0: return old; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_AllowExceptions -- sl@0: * sl@0: * Sets a flag in an interpreter so that exceptions can occur sl@0: * in the next call to Tcl_Eval without them being turned into sl@0: * errors. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's sl@0: * evalFlags structure. See the reference documentation for sl@0: * more details. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_AllowExceptions(interp) sl@0: Tcl_Interp *interp; /* Interpreter in which to set flag. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: sl@0: iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; sl@0: } sl@0: sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetVersion sl@0: * sl@0: * Get the Tcl major, minor, and patchlevel version numbers and sl@0: * the release type. A patch is a release type TCL_FINAL_RELEASE sl@0: * with a patchLevel > 0. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_GetVersion(majorV, minorV, patchLevelV, type) sl@0: int *majorV; sl@0: int *minorV; sl@0: int *patchLevelV; sl@0: int *type; sl@0: { sl@0: if (majorV != NULL) { sl@0: *majorV = TCL_MAJOR_VERSION; sl@0: } sl@0: if (minorV != NULL) { sl@0: *minorV = TCL_MINOR_VERSION; sl@0: } sl@0: if (patchLevelV != NULL) { sl@0: *patchLevelV = TCL_RELEASE_SERIAL; sl@0: } sl@0: if (type != NULL) { sl@0: *type = TCL_RELEASE_LEVEL; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Local Variables: sl@0: * mode: c sl@0: * c-basic-offset: 4 sl@0: * fill-column: 78 sl@0: * End: sl@0: */ sl@0: