Parent Directory
| 
Revision Log
| 
Patch
| projs/trunk/shared_source/tcl_base/tclbasic.c revision 42 by dashley, Fri Oct 14 01:50:00 2016 UTC | projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclbasic.c revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC | |
|---|---|---|
| # | Line 1 | Line 1 |
| /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclbasic.c,v 1.1.1.1 2001/06/13 04:33:43 dtashley Exp $ */ | ||
| /* | ||
| * tclBasic.c -- | ||
| * | ||
| * Contains the basic facilities for TCL command interpretation, | ||
| * including interpreter creation and deletion, command creation | ||
| * and deletion, and command parsing and execution. | ||
| * | ||
| * Copyright (c) 1987-1994 The Regents of the University of California. | ||
| * Copyright (c) 1994-1997 Sun Microsystems, Inc. | ||
| * Copyright (c) 1998-1999 by Scriptics Corporation. | ||
| * | ||
| * See the file "license.terms" for information on usage and redistribution | ||
| * of this file, and for a DISCLAIMER OF ALL WARRANTIES. | ||
| * | ||
| * RCS: @(#) $Id: tclbasic.c,v 1.1.1.1 2001/06/13 04:33:43 dtashley Exp $ | ||
| */ | ||
| #include "tclInt.h" | ||
| #include "tclCompile.h" | ||
| #ifndef TCL_GENERIC_ONLY | ||
| # include "tclPort.h" | ||
| #endif | ||
| /* | ||
| * Static procedures in this file: | ||
| */ | ||
| static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); | ||
| static void ProcessUnexpectedResult _ANSI_ARGS_(( | ||
| Tcl_Interp *interp, int returnCode)); | ||
| static void RecordTracebackInfo _ANSI_ARGS_(( | ||
| Tcl_Interp *interp, Tcl_Obj *objPtr, | ||
| int numSrcBytes)); | ||
| extern TclStubs tclStubs; | ||
| /* | ||
| * The following structure defines the commands in the Tcl core. | ||
| */ | ||
| typedef struct { | ||
| char *name; /* Name of object-based command. */ | ||
| Tcl_CmdProc *proc; /* String-based procedure for command. */ | ||
| Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */ | ||
| CompileProc *compileProc; /* Procedure called to compile command. */ | ||
| int isSafe; /* If non-zero, command will be present | ||
| * in safe interpreter. Otherwise it will | ||
| * be hidden. */ | ||
| } CmdInfo; | ||
| /* | ||
| * The built-in commands, and the procedures that implement them: | ||
| */ | ||
| static CmdInfo builtInCmds[] = { | ||
| /* | ||
| * Commands in the generic core. Note that at least one of the proc or | ||
| * objProc members should be non-NULL. This avoids infinitely recursive | ||
| * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a | ||
| * command name is computed at runtime and results in the name of a | ||
| * compiled command. | ||
| */ | ||
| {"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"break", (Tcl_CmdProc *) NULL, Tcl_BreakObjCmd, | ||
| TclCompileBreakCmd, 1}, | ||
| {"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd, | ||
| TclCompileCatchCmd, 1}, | ||
| {"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"continue", (Tcl_CmdProc *) NULL, Tcl_ContinueObjCmd, | ||
| TclCompileContinueCmd, 1}, | ||
| {"encoding", (Tcl_CmdProc *) NULL, Tcl_EncodingObjCmd, | ||
| (CompileProc *) NULL, 0}, | ||
| {"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd, | ||
| (CompileProc *) NULL, 0}, | ||
| {"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd, | ||
| TclCompileExprCmd, 1}, | ||
| {"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"fileevent", (Tcl_CmdProc *) NULL, Tcl_FileEventObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"for", (Tcl_CmdProc *) NULL, Tcl_ForObjCmd, | ||
| TclCompileForCmd, 1}, | ||
| {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd, | ||
| TclCompileForeachCmd, 1}, | ||
| {"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"if", (Tcl_CmdProc *) NULL, Tcl_IfObjCmd, | ||
| TclCompileIfCmd, 1}, | ||
| {"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd, | ||
| TclCompileIncrCmd, 1}, | ||
| {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd, | ||
| (CompileProc *) NULL, 0}, | ||
| {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"package", (Tcl_CmdProc *) NULL, Tcl_PackageObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd, | ||
| TclCompileSetCmd, 1}, | ||
| {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"while", (Tcl_CmdProc *) NULL, Tcl_WhileObjCmd, | ||
| TclCompileWhileCmd, 1}, | ||
| /* | ||
| * Commands in the UNIX core: | ||
| */ | ||
| #ifndef TCL_GENERIC_ONLY | ||
| {"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd, | ||
| (CompileProc *) NULL, 0}, | ||
| {"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"fconfigure", (Tcl_CmdProc *) NULL, Tcl_FconfigureObjCmd, | ||
| (CompileProc *) NULL, 0}, | ||
| {"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd, | ||
| (CompileProc *) NULL, 0}, | ||
| {"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"glob", (Tcl_CmdProc *) NULL, Tcl_GlobObjCmd, | ||
| (CompileProc *) NULL, 0}, | ||
| {"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd, | ||
| (CompileProc *) NULL, 0}, | ||
| {"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"pwd", (Tcl_CmdProc *) NULL, Tcl_PwdObjCmd, | ||
| (CompileProc *) NULL, 0}, | ||
| {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"seek", (Tcl_CmdProc *) NULL, Tcl_SeekObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"socket", (Tcl_CmdProc *) NULL, Tcl_SocketObjCmd, | ||
| (CompileProc *) NULL, 0}, | ||
| {"tell", (Tcl_CmdProc *) NULL, Tcl_TellObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"update", (Tcl_CmdProc *) NULL, Tcl_UpdateObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"vwait", (Tcl_CmdProc *) NULL, Tcl_VwaitObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| #ifdef MAC_TCL | ||
| {"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd, | ||
| (CompileProc *) NULL, 0}, | ||
| {"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL, | ||
| (CompileProc *) NULL, 0}, | ||
| {"ls", (Tcl_CmdProc *) NULL, Tcl_LsObjCmd, | ||
| (CompileProc *) NULL, 0}, | ||
| {"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd, | ||
| (CompileProc *) NULL, 1}, | ||
| {"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd, | ||
| (CompileProc *) NULL, 0}, | ||
| #else | ||
| {"exec", (Tcl_CmdProc *) NULL, Tcl_ExecObjCmd, | ||
| (CompileProc *) NULL, 0}, | ||
| {"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd, | ||
| (CompileProc *) NULL, 0}, | ||
| #endif /* MAC_TCL */ | ||
| #endif /* TCL_GENERIC_ONLY */ | ||
| {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL, | ||
| (CompileProc *) NULL, 0} | ||
| }; | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_CreateInterp -- | ||
| * | ||
| * Create a new TCL command interpreter. | ||
| * | ||
| * Results: | ||
| * The return value is a token for the interpreter, which may be | ||
| * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or | ||
| * Tcl_DeleteInterp. | ||
| * | ||
| * Side effects: | ||
| * The command interpreter is initialized with an empty variable | ||
| * table and the built-in commands. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| Tcl_Interp * | ||
| Tcl_CreateInterp() | ||
| { | ||
| Interp *iPtr; | ||
| Tcl_Interp *interp; | ||
| Command *cmdPtr; | ||
| BuiltinFunc *builtinFuncPtr; | ||
| MathFunc *mathFuncPtr; | ||
| Tcl_HashEntry *hPtr; | ||
| CmdInfo *cmdInfoPtr; | ||
| int i; | ||
| union { | ||
| char c[sizeof(short)]; | ||
| short s; | ||
| } order; | ||
| #ifdef TCL_COMPILE_STATS | ||
| ByteCodeStats *statsPtr; | ||
| #endif /* TCL_COMPILE_STATS */ | ||
| TclInitSubsystems(NULL); | ||
| /* | ||
| * Panic if someone updated the CallFrame structure without | ||
| * also updating the Tcl_CallFrame structure (or vice versa). | ||
| */ | ||
| if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) { | ||
| /*NOTREACHED*/ | ||
| panic("Tcl_CallFrame and CallFrame are not the same size"); | ||
| } | ||
| /* | ||
| * Initialize support for namespaces and create the global namespace | ||
| * (whose name is ""; an alias is "::"). This also initializes the | ||
| * Tcl object type table and other object management code. | ||
| */ | ||
| iPtr = (Interp *) ckalloc(sizeof(Interp)); | ||
| interp = (Tcl_Interp *) iPtr; | ||
| iPtr->result = iPtr->resultSpace; | ||
| iPtr->freeProc = NULL; | ||
| iPtr->errorLine = 0; | ||
| iPtr->objResultPtr = Tcl_NewObj(); | ||
| Tcl_IncrRefCount(iPtr->objResultPtr); | ||
| iPtr->handle = TclHandleCreate(iPtr); | ||
| iPtr->globalNsPtr = NULL; | ||
| iPtr->hiddenCmdTablePtr = NULL; | ||
| iPtr->interpInfo = NULL; | ||
| Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); | ||
| iPtr->numLevels = 0; | ||
| iPtr->maxNestingDepth = 1000; | ||
| iPtr->framePtr = NULL; | ||
| iPtr->varFramePtr = NULL; | ||
| iPtr->activeTracePtr = NULL; | ||
| iPtr->returnCode = TCL_OK; | ||
| iPtr->errorInfo = NULL; | ||
| iPtr->errorCode = NULL; | ||
| iPtr->appendResult = NULL; | ||
| iPtr->appendAvl = 0; | ||
| iPtr->appendUsed = 0; | ||
| Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); | ||
| iPtr->packageUnknown = NULL; | ||
| iPtr->cmdCount = 0; | ||
| iPtr->termOffset = 0; | ||
| TclInitLiteralTable(&(iPtr->literalTable)); | ||
| iPtr->compileEpoch = 0; | ||
| iPtr->compiledProcPtr = NULL; | ||
| iPtr->resolverPtr = NULL; | ||
| iPtr->evalFlags = 0; | ||
| iPtr->scriptFile = NULL; | ||
| iPtr->flags = 0; | ||
| iPtr->tracePtr = NULL; | ||
| iPtr->assocData = (Tcl_HashTable *) NULL; | ||
| iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ | ||
| iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ | ||
| Tcl_IncrRefCount(iPtr->emptyObjPtr); | ||
| iPtr->resultSpace[0] = 0; | ||
| iPtr->globalNsPtr = NULL; /* force creation of global ns below */ | ||
| iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "", | ||
| (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); | ||
| if (iPtr->globalNsPtr == NULL) { | ||
| panic("Tcl_CreateInterp: can't create global namespace"); | ||
| } | ||
| /* | ||
| * Initialize support for code compilation and execution. We call | ||
| * TclCreateExecEnv after initializing namespaces since it tries to | ||
| * reference a Tcl variable (it links to the Tcl "tcl_traceExec" | ||
| * variable). | ||
| */ | ||
| iPtr->execEnvPtr = TclCreateExecEnv(interp); | ||
| /* | ||
| * Initialize the compilation and execution statistics kept for this | ||
| * interpreter. | ||
| */ | ||
| #ifdef TCL_COMPILE_STATS | ||
| statsPtr = &(iPtr->stats); | ||
| statsPtr->numExecutions = 0; | ||
| statsPtr->numCompilations = 0; | ||
| statsPtr->numByteCodesFreed = 0; | ||
| (VOID *) memset(statsPtr->instructionCount, 0, | ||
| sizeof(statsPtr->instructionCount)); | ||
| statsPtr->totalSrcBytes = 0.0; | ||
| statsPtr->totalByteCodeBytes = 0.0; | ||
| statsPtr->currentSrcBytes = 0.0; | ||
| statsPtr->currentByteCodeBytes = 0.0; | ||
| (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); | ||
| (VOID *) memset(statsPtr->byteCodeCount, 0, | ||
| sizeof(statsPtr->byteCodeCount)); | ||
| (VOID *) memset(statsPtr->lifetimeCount, 0, | ||
| sizeof(statsPtr->lifetimeCount)); | ||
| statsPtr->currentInstBytes = 0.0; | ||
| statsPtr->currentLitBytes = 0.0; | ||
| statsPtr->currentExceptBytes = 0.0; | ||
| statsPtr->currentAuxBytes = 0.0; | ||
| statsPtr->currentCmdMapBytes = 0.0; | ||
| statsPtr->numLiteralsCreated = 0; | ||
| statsPtr->totalLitStringBytes = 0.0; | ||
| statsPtr->currentLitStringBytes = 0.0; | ||
| (VOID *) memset(statsPtr->literalCount, 0, | ||
| sizeof(statsPtr->literalCount)); | ||
| #endif /* TCL_COMPILE_STATS */ | ||
| /* | ||
| * Initialise the stub table pointer. | ||
| */ | ||
| iPtr->stubTable = &tclStubs; | ||
| /* | ||
| * Create the core commands. Do it here, rather than calling | ||
| * Tcl_CreateCommand, because it's faster (there's no need to check for | ||
| * a pre-existing command by the same name). If a command has a | ||
| * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to | ||
| * TclInvokeStringCommand. This is an object-based wrapper procedure | ||
| * that extracts strings, calls the string procedure, and creates an | ||
| * object for the result. Similarly, if a command has a Tcl_ObjCmdProc | ||
| * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. | ||
| */ | ||
| for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; | ||
| cmdInfoPtr++) { | ||
| int new; | ||
| Tcl_HashEntry *hPtr; | ||
| if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) | ||
| && (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) | ||
| && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) { | ||
| panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n"); | ||
| } | ||
| hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, | ||
| cmdInfoPtr->name, &new); | ||
| if (new) { | ||
| cmdPtr = (Command *) ckalloc(sizeof(Command)); | ||
| cmdPtr->hPtr = hPtr; | ||
| cmdPtr->nsPtr = iPtr->globalNsPtr; | ||
| cmdPtr->refCount = 1; | ||
| cmdPtr->cmdEpoch = 0; | ||
| cmdPtr->compileProc = cmdInfoPtr->compileProc; | ||
| if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) { | ||
| cmdPtr->proc = TclInvokeObjectCommand; | ||
| cmdPtr->clientData = (ClientData) cmdPtr; | ||
| } else { | ||
| cmdPtr->proc = cmdInfoPtr->proc; | ||
| cmdPtr->clientData = (ClientData) NULL; | ||
| } | ||
| if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { | ||
| cmdPtr->objProc = TclInvokeStringCommand; | ||
| cmdPtr->objClientData = (ClientData) cmdPtr; | ||
| } else { | ||
| cmdPtr->objProc = cmdInfoPtr->objProc; | ||
| cmdPtr->objClientData = (ClientData) NULL; | ||
| } | ||
| cmdPtr->deleteProc = NULL; | ||
| cmdPtr->deleteData = (ClientData) NULL; | ||
| cmdPtr->deleted = 0; | ||
| cmdPtr->importRefPtr = NULL; | ||
| Tcl_SetHashValue(hPtr, cmdPtr); | ||
| } | ||
| } | ||
| /* | ||
| * Register the builtin math functions. | ||
| */ | ||
| i = 0; | ||
| for (builtinFuncPtr = builtinFuncTable; builtinFuncPtr->name != NULL; | ||
| builtinFuncPtr++) { | ||
| Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name, | ||
| builtinFuncPtr->numArgs, builtinFuncPtr->argTypes, | ||
| (Tcl_MathProc *) NULL, (ClientData) 0); | ||
| hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, | ||
| builtinFuncPtr->name); | ||
| if (hPtr == NULL) { | ||
| panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name); | ||
| return NULL; | ||
| } | ||
| mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); | ||
| mathFuncPtr->builtinFuncIndex = i; | ||
| i++; | ||
| } | ||
| iPtr->flags |= EXPR_INITIALIZED; | ||
| /* | ||
| * Do Multiple/Safe Interps Tcl init stuff | ||
| */ | ||
| TclInterpInit(interp); | ||
| /* | ||
| * We used to create the "errorInfo" and "errorCode" global vars at this | ||
| * point because so much of the Tcl implementation assumes they already | ||
| * exist. This is not quite enough, however, since they can be unset | ||
| * at any time. | ||
| * | ||
| * There are 2 choices: | ||
| * + Check every place where a GetVar of those is used | ||
| * and the NULL result is not checked (like in tclLoad.c) | ||
| * + Make SetVar,... NULL friendly | ||
| * We choose the second option because : | ||
| * + It is easy and low cost to check for NULL pointer before | ||
| * calling strlen() | ||
| * + It can be helpfull to other people using those API | ||
| * + Passing a NULL value to those closest 'meaning' is empty string | ||
| * (specially with the new objects where 0 bytes strings are ok) | ||
| * So the following init is commented out: -- dl | ||
| * | ||
| * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, | ||
| * "", TCL_GLOBAL_ONLY); | ||
| * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, | ||
| * "NONE", TCL_GLOBAL_ONLY); | ||
| */ | ||
| #ifndef TCL_GENERIC_ONLY | ||
| TclSetupEnv(interp); | ||
| #endif | ||
| /* | ||
| * Compute the byte order of this machine. | ||
| */ | ||
| order.s = 1; | ||
| Tcl_SetVar2(interp, "tcl_platform", "byteOrder", | ||
| ((order.c[0] == 1) ? "littleEndian" : "bigEndian"), | ||
| TCL_GLOBAL_ONLY); | ||
| /* | ||
| * Set up other variables such as tcl_version and tcl_library | ||
| */ | ||
| Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); | ||
| Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); | ||
| Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL, | ||
| TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, | ||
| TclPrecTraceProc, (ClientData) NULL); | ||
| TclpSetVariables(interp); | ||
| #ifdef TCL_THREADS | ||
| /* | ||
| * The existence of the "threaded" element of the tcl_platform array indicates | ||
| * that this particular Tcl shell has been compiled with threads turned on. | ||
| * Using "info exists tcl_platform(threaded)" a Tcl script can introspect on the | ||
| * interpreter level of thread safety. | ||
| */ | ||
| Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", | ||
| TCL_GLOBAL_ONLY); | ||
| #endif | ||
| /* | ||
| * Register Tcl's version number. | ||
| */ | ||
| Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs); | ||
| #ifdef Tcl_InitStubs | ||
| #undef Tcl_InitStubs | ||
| #endif | ||
| Tcl_InitStubs(interp, TCL_VERSION, 1); | ||
| return interp; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * TclHideUnsafeCommands -- | ||
| * | ||
| * Hides base commands that are not marked as safe from this | ||
| * interpreter. | ||
| * | ||
| * Results: | ||
| * TCL_OK if it succeeds, TCL_ERROR else. | ||
| * | ||
| * Side effects: | ||
| * Hides functionality in an interpreter. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| TclHideUnsafeCommands(interp) | ||
| Tcl_Interp *interp; /* Hide commands in this interpreter. */ | ||
| { | ||
| register CmdInfo *cmdInfoPtr; | ||
| if (interp == (Tcl_Interp *) NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { | ||
| if (!cmdInfoPtr->isSafe) { | ||
| Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); | ||
| } | ||
| } | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| *-------------------------------------------------------------- | ||
| * | ||
| * Tcl_CallWhenDeleted -- | ||
| * | ||
| * Arrange for a procedure to be called before a given | ||
| * interpreter is deleted. The procedure is called as soon | ||
| * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is | ||
| * called on an interpreter that has already been deleted, | ||
| * the procedure will be called when the last Tcl_Release is | ||
| * done on the interpreter. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * When Tcl_DeleteInterp is invoked to delete interp, | ||
| * proc will be invoked. See the manual entry for | ||
| * details. | ||
| * | ||
| *-------------------------------------------------------------- | ||
| */ | ||
| void | ||
| Tcl_CallWhenDeleted(interp, proc, clientData) | ||
| Tcl_Interp *interp; /* Interpreter to watch. */ | ||
| Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter | ||
| * is about to be deleted. */ | ||
| ClientData clientData; /* One-word value to pass to proc. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| static int assocDataCounter = 0; | ||
| #ifdef TCL_THREADS | ||
| static Tcl_Mutex assocMutex; | ||
| #endif | ||
| int new; | ||
| char buffer[32 + TCL_INTEGER_SPACE]; | ||
| AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); | ||
| Tcl_HashEntry *hPtr; | ||
| Tcl_MutexLock(&assocMutex); | ||
| sprintf(buffer, "Assoc Data Key #%d", assocDataCounter); | ||
| assocDataCounter++; | ||
| Tcl_MutexUnlock(&assocMutex); | ||
| if (iPtr->assocData == (Tcl_HashTable *) NULL) { | ||
| iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); | ||
| Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); | ||
| } | ||
| hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new); | ||
| dPtr->proc = proc; | ||
| dPtr->clientData = clientData; | ||
| Tcl_SetHashValue(hPtr, dPtr); | ||
| } | ||
| /* | ||
| *-------------------------------------------------------------- | ||
| * | ||
| * Tcl_DontCallWhenDeleted -- | ||
| * | ||
| * Cancel the arrangement for a procedure to be called when | ||
| * a given interpreter is deleted. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * If proc and clientData were previously registered as a | ||
| * callback via Tcl_CallWhenDeleted, they are unregistered. | ||
| * If they weren't previously registered then nothing | ||
| * happens. | ||
| * | ||
| *-------------------------------------------------------------- | ||
| */ | ||
| void | ||
| Tcl_DontCallWhenDeleted(interp, proc, clientData) | ||
| Tcl_Interp *interp; /* Interpreter to watch. */ | ||
| Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter | ||
| * is about to be deleted. */ | ||
| ClientData clientData; /* One-word value to pass to proc. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| Tcl_HashTable *hTablePtr; | ||
| Tcl_HashSearch hSearch; | ||
| Tcl_HashEntry *hPtr; | ||
| AssocData *dPtr; | ||
| hTablePtr = iPtr->assocData; | ||
| if (hTablePtr == (Tcl_HashTable *) NULL) { | ||
| return; | ||
| } | ||
| for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; | ||
| hPtr = Tcl_NextHashEntry(&hSearch)) { | ||
| dPtr = (AssocData *) Tcl_GetHashValue(hPtr); | ||
| if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { | ||
| ckfree((char *) dPtr); | ||
| Tcl_DeleteHashEntry(hPtr); | ||
| return; | ||
| } | ||
| } | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_SetAssocData -- | ||
| * | ||
| * Creates a named association between user-specified data, a delete | ||
| * function and this interpreter. If the association already exists | ||
| * the data is overwritten with the new data. The delete function will | ||
| * be invoked when the interpreter is deleted. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * Sets the associated data, creates the association if needed. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| void | ||
| Tcl_SetAssocData(interp, name, proc, clientData) | ||
| Tcl_Interp *interp; /* Interpreter to associate with. */ | ||
| char *name; /* Name for association. */ | ||
| Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is | ||
| * about to be deleted. */ | ||
| ClientData clientData; /* One-word value to pass to proc. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| AssocData *dPtr; | ||
| Tcl_HashEntry *hPtr; | ||
| int new; | ||
| if (iPtr->assocData == (Tcl_HashTable *) NULL) { | ||
| iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); | ||
| Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); | ||
| } | ||
| hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new); | ||
| if (new == 0) { | ||
| dPtr = (AssocData *) Tcl_GetHashValue(hPtr); | ||
| } else { | ||
| dPtr = (AssocData *) ckalloc(sizeof(AssocData)); | ||
| } | ||
| dPtr->proc = proc; | ||
| dPtr->clientData = clientData; | ||
| Tcl_SetHashValue(hPtr, dPtr); | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_DeleteAssocData -- | ||
| * | ||
| * Deletes a named association of user-specified data with | ||
| * the specified interpreter. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * Deletes the association. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| void | ||
| Tcl_DeleteAssocData(interp, name) | ||
| Tcl_Interp *interp; /* Interpreter to associate with. */ | ||
| char *name; /* Name of association. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| AssocData *dPtr; | ||
| Tcl_HashEntry *hPtr; | ||
| if (iPtr->assocData == (Tcl_HashTable *) NULL) { | ||
| return; | ||
| } | ||
| hPtr = Tcl_FindHashEntry(iPtr->assocData, name); | ||
| if (hPtr == (Tcl_HashEntry *) NULL) { | ||
| return; | ||
| } | ||
| dPtr = (AssocData *) Tcl_GetHashValue(hPtr); | ||
| if (dPtr->proc != NULL) { | ||
| (dPtr->proc) (dPtr->clientData, interp); | ||
| } | ||
| ckfree((char *) dPtr); | ||
| Tcl_DeleteHashEntry(hPtr); | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_GetAssocData -- | ||
| * | ||
| * Returns the client data associated with this name in the | ||
| * specified interpreter. | ||
| * | ||
| * Results: | ||
| * The client data in the AssocData record denoted by the named | ||
| * association, or NULL. | ||
| * | ||
| * Side effects: | ||
| * None. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| ClientData | ||
| Tcl_GetAssocData(interp, name, procPtr) | ||
| Tcl_Interp *interp; /* Interpreter associated with. */ | ||
| char *name; /* Name of association. */ | ||
| Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address | ||
| * of current deletion callback. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| AssocData *dPtr; | ||
| Tcl_HashEntry *hPtr; | ||
| if (iPtr->assocData == (Tcl_HashTable *) NULL) { | ||
| return (ClientData) NULL; | ||
| } | ||
| hPtr = Tcl_FindHashEntry(iPtr->assocData, name); | ||
| if (hPtr == (Tcl_HashEntry *) NULL) { | ||
| return (ClientData) NULL; | ||
| } | ||
| dPtr = (AssocData *) Tcl_GetHashValue(hPtr); | ||
| if (procPtr != (Tcl_InterpDeleteProc **) NULL) { | ||
| *procPtr = dPtr->proc; | ||
| } | ||
| return dPtr->clientData; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_InterpDeleted -- | ||
| * | ||
| * Returns nonzero if the interpreter has been deleted with a call | ||
| * to Tcl_DeleteInterp. | ||
| * | ||
| * Results: | ||
| * Nonzero if the interpreter is deleted, zero otherwise. | ||
| * | ||
| * Side effects: | ||
| * None. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_InterpDeleted(interp) | ||
| Tcl_Interp *interp; | ||
| { | ||
| return (((Interp *) interp)->flags & DELETED) ? 1 : 0; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_DeleteInterp -- | ||
| * | ||
| * Ensures that the interpreter will be deleted eventually. If there | ||
| * are no Tcl_Preserve calls in effect for this interpreter, it is | ||
| * deleted immediately, otherwise the interpreter is deleted when | ||
| * the last Tcl_Preserve is matched by a call to Tcl_Release. In either | ||
| * case, the procedure runs the currently registered deletion callbacks. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * The interpreter is marked as deleted. The caller may still use it | ||
| * safely if there are calls to Tcl_Preserve in effect for the | ||
| * interpreter, but further calls to Tcl_Eval etc in this interpreter | ||
| * will fail. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| void | ||
| Tcl_DeleteInterp(interp) | ||
| Tcl_Interp *interp; /* Token for command interpreter (returned | ||
| * by a previous call to Tcl_CreateInterp). */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| /* | ||
| * If the interpreter has already been marked deleted, just punt. | ||
| */ | ||
| if (iPtr->flags & DELETED) { | ||
| return; | ||
| } | ||
| /* | ||
| * Mark the interpreter as deleted. No further evals will be allowed. | ||
| */ | ||
| iPtr->flags |= DELETED; | ||
| /* | ||
| * Ensure that the interpreter is eventually deleted. | ||
| */ | ||
| Tcl_EventuallyFree((ClientData) interp, | ||
| (Tcl_FreeProc *) DeleteInterpProc); | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * DeleteInterpProc -- | ||
| * | ||
| * Helper procedure to delete an interpreter. This procedure is | ||
| * called when the last call to Tcl_Preserve on this interpreter | ||
| * is matched by a call to Tcl_Release. The procedure cleans up | ||
| * all resources used in the interpreter and calls all currently | ||
| * registered interpreter deletion callbacks. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * Whatever the interpreter deletion callbacks do. Frees resources | ||
| * used by the interpreter. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| static void | ||
| DeleteInterpProc(interp) | ||
| Tcl_Interp *interp; /* Interpreter to delete. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| Tcl_HashEntry *hPtr; | ||
| Tcl_HashSearch search; | ||
| Tcl_HashTable *hTablePtr; | ||
| ResolverScheme *resPtr, *nextResPtr; | ||
| /* | ||
| * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. | ||
| */ | ||
| if (iPtr->numLevels > 0) { | ||
| panic("DeleteInterpProc called with active evals"); | ||
| } | ||
| /* | ||
| * The interpreter should already be marked deleted; otherwise how | ||
| * did we get here? | ||
| */ | ||
| if (!(iPtr->flags & DELETED)) { | ||
| panic("DeleteInterpProc called on interpreter not marked deleted"); | ||
| } | ||
| TclHandleFree(iPtr->handle); | ||
| /* | ||
| * Dismantle everything in the global namespace except for the | ||
| * "errorInfo" and "errorCode" variables. These remain until the | ||
| * namespace is actually destroyed, in case any errors occur. | ||
| * | ||
| * Dismantle the namespace here, before we clear the assocData. If any | ||
| * background errors occur here, they will be deleted below. | ||
| */ | ||
| TclTeardownNamespace(iPtr->globalNsPtr); | ||
| /* | ||
| * Delete all the hidden commands. | ||
| */ | ||
| hTablePtr = iPtr->hiddenCmdTablePtr; | ||
| if (hTablePtr != NULL) { | ||
| /* | ||
| * Non-pernicious deletion. The deletion callbacks will not be | ||
| * allowed to create any new hidden or non-hidden commands. | ||
| * Tcl_DeleteCommandFromToken() will remove the entry from the | ||
| * hiddenCmdTablePtr. | ||
| */ | ||
| hPtr = Tcl_FirstHashEntry(hTablePtr, &search); | ||
| for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { | ||
| Tcl_DeleteCommandFromToken(interp, | ||
| (Tcl_Command) Tcl_GetHashValue(hPtr)); | ||
| } | ||
| Tcl_DeleteHashTable(hTablePtr); | ||
| ckfree((char *) hTablePtr); | ||
| } | ||
| /* | ||
| * Tear down the math function table. | ||
| */ | ||
| for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search); | ||
| hPtr != NULL; | ||
| hPtr = Tcl_NextHashEntry(&search)) { | ||
| ckfree((char *) Tcl_GetHashValue(hPtr)); | ||
| } | ||
| Tcl_DeleteHashTable(&iPtr->mathFuncTable); | ||
| /* | ||
| * Invoke deletion callbacks; note that a callback can create new | ||
| * callbacks, so we iterate. | ||
| */ | ||
| while (iPtr->assocData != (Tcl_HashTable *) NULL) { | ||
| AssocData *dPtr; | ||
| hTablePtr = iPtr->assocData; | ||
| iPtr->assocData = (Tcl_HashTable *) NULL; | ||
| for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); | ||
| hPtr != NULL; | ||
| hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { | ||
| dPtr = (AssocData *) Tcl_GetHashValue(hPtr); | ||
| Tcl_DeleteHashEntry(hPtr); | ||
| if (dPtr->proc != NULL) { | ||
| (*dPtr->proc)(dPtr->clientData, interp); | ||
| } | ||
| ckfree((char *) dPtr); | ||
| } | ||
| Tcl_DeleteHashTable(hTablePtr); | ||
| ckfree((char *) hTablePtr); | ||
| } | ||
| /* | ||
| * Finish deleting the global namespace. | ||
| */ | ||
| Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); | ||
| /* | ||
| * Free up the result *after* deleting variables, since variable | ||
| * deletion could have transferred ownership of the result string | ||
| * to Tcl. | ||
| */ | ||
| Tcl_FreeResult(interp); | ||
| interp->result = NULL; | ||
| Tcl_DecrRefCount(iPtr->objResultPtr); | ||
| iPtr->objResultPtr = NULL; | ||
| if (iPtr->errorInfo != NULL) { | ||
| ckfree(iPtr->errorInfo); | ||
| iPtr->errorInfo = NULL; | ||
| } | ||
| if (iPtr->errorCode != NULL) { | ||
| ckfree(iPtr->errorCode); | ||
| iPtr->errorCode = NULL; | ||
| } | ||
| if (iPtr->appendResult != NULL) { | ||
| ckfree(iPtr->appendResult); | ||
| iPtr->appendResult = NULL; | ||
| } | ||
| TclFreePackageInfo(iPtr); | ||
| while (iPtr->tracePtr != NULL) { | ||
| Trace *nextPtr = iPtr->tracePtr->nextPtr; | ||
| ckfree((char *) iPtr->tracePtr); | ||
| iPtr->tracePtr = nextPtr; | ||
| } | ||
| if (iPtr->execEnvPtr != NULL) { | ||
| TclDeleteExecEnv(iPtr->execEnvPtr); | ||
| } | ||
| Tcl_DecrRefCount(iPtr->emptyObjPtr); | ||
| iPtr->emptyObjPtr = NULL; | ||
| resPtr = iPtr->resolverPtr; | ||
| while (resPtr) { | ||
| nextResPtr = resPtr->nextPtr; | ||
| ckfree(resPtr->name); | ||
| ckfree((char *) resPtr); | ||
| resPtr = nextResPtr; | ||
| } | ||
| /* | ||
| * Free up literal objects created for scripts compiled by the | ||
| * interpreter. | ||
| */ | ||
| TclDeleteLiteralTable(interp, &(iPtr->literalTable)); | ||
| ckfree((char *) iPtr); | ||
| } | ||
| /* | ||
| *--------------------------------------------------------------------------- | ||
| * | ||
| * Tcl_HideCommand -- | ||
| * | ||
| * Makes a command hidden so that it cannot be invoked from within | ||
| * an interpreter, only from within an ancestor. | ||
| * | ||
| * Results: | ||
| * A standard Tcl result; also leaves a message in the interp's result | ||
| * if an error occurs. | ||
| * | ||
| * Side effects: | ||
| * Removes a command from the command table and create an entry | ||
| * into the hidden command table under the specified token name. | ||
| * | ||
| *--------------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_HideCommand(interp, cmdName, hiddenCmdToken) | ||
| Tcl_Interp *interp; /* Interpreter in which to hide command. */ | ||
| char *cmdName; /* Name of command to hide. */ | ||
| char *hiddenCmdToken; /* Token name of the to-be-hidden command. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| Tcl_Command cmd; | ||
| Command *cmdPtr; | ||
| Tcl_HashTable *hiddenCmdTablePtr; | ||
| Tcl_HashEntry *hPtr; | ||
| int new; | ||
| if (iPtr->flags & DELETED) { | ||
| /* | ||
| * The interpreter is being deleted. Do not create any new | ||
| * structures, because it is not safe to modify the interpreter. | ||
| */ | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * Disallow hiding of commands that are currently in a namespace or | ||
| * renaming (as part of hiding) into a namespace. | ||
| * | ||
| * (because the current implementation with a single global table | ||
| * and the needed uniqueness of names cause problems with namespaces) | ||
| * | ||
| * we don't need to check for "::" in cmdName because the real check is | ||
| * on the nsPtr below. | ||
| * | ||
| * hiddenCmdToken is just a string which is not interpreted in any way. | ||
| * It may contain :: but the string is not interpreted as a namespace | ||
| * qualifier command name. Thus, hiding foo::bar to foo::bar and then | ||
| * trying to expose or invoke ::foo::bar will NOT work; but if the | ||
| * application always uses the same strings it will get consistent | ||
| * behaviour. | ||
| * | ||
| * But as we currently limit ourselves to the global namespace only | ||
| * for the source, in order to avoid potential confusion, | ||
| * lets prevent "::" in the token too. --dl | ||
| */ | ||
| if (strstr(hiddenCmdToken, "::") != NULL) { | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | ||
| "cannot use namespace qualifiers as hidden command", | ||
| "token (rename)", (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * Find the command to hide. An error is returned if cmdName can't | ||
| * be found. Look up the command only from the global namespace. | ||
| * Full path of the command must be given if using namespaces. | ||
| */ | ||
| cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, | ||
| /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); | ||
| if (cmd == (Tcl_Command) NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| cmdPtr = (Command *) cmd; | ||
| /* | ||
| * Check that the command is really in global namespace | ||
| */ | ||
| if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | ||
| "can only hide global namespace commands", | ||
| " (use rename then hide)", (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * Initialize the hidden command table if necessary. | ||
| */ | ||
| hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; | ||
| if (hiddenCmdTablePtr == NULL) { | ||
| hiddenCmdTablePtr = (Tcl_HashTable *) | ||
| ckalloc((unsigned) sizeof(Tcl_HashTable)); | ||
| Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); | ||
| iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; | ||
| } | ||
| /* | ||
| * It is an error to move an exposed command to a hidden command with | ||
| * hiddenCmdToken if a hidden command with the name hiddenCmdToken already | ||
| * exists. | ||
| */ | ||
| hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new); | ||
| if (!new) { | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | ||
| "hidden command named \"", hiddenCmdToken, "\" already exists", | ||
| (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * Nb : This code is currently 'like' a rename to a specialy set apart | ||
| * name table. Changes here and in TclRenameCommand must | ||
| * be kept in synch untill the common parts are actually | ||
| * factorized out. | ||
| */ | ||
| /* | ||
| * Remove the hash entry for the command from the interpreter command | ||
| * table. This is like deleting the command, so bump its command epoch; | ||
| * this invalidates any cached references that point to the command. | ||
| */ | ||
| if (cmdPtr->hPtr != NULL) { | ||
| Tcl_DeleteHashEntry(cmdPtr->hPtr); | ||
| cmdPtr->hPtr = (Tcl_HashEntry *) NULL; | ||
| cmdPtr->cmdEpoch++; | ||
| } | ||
| /* | ||
| * Now link the hash table entry with the command structure. | ||
| * We ensured above that the nsPtr was right. | ||
| */ | ||
| cmdPtr->hPtr = hPtr; | ||
| Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); | ||
| /* | ||
| * If the command being hidden has a compile procedure, increment the | ||
| * interpreter's compileEpoch to invalidate its compiled code. This | ||
| * makes sure that we don't later try to execute old code compiled with | ||
| * command-specific (i.e., inline) bytecodes for the now-hidden | ||
| * command. This field is checked in Tcl_EvalObj and ObjInterpProc, | ||
| * and code whose compilation epoch doesn't match is recompiled. | ||
| */ | ||
| if (cmdPtr->compileProc != NULL) { | ||
| iPtr->compileEpoch++; | ||
| } | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_ExposeCommand -- | ||
| * | ||
| * Makes a previously hidden command callable from inside the | ||
| * interpreter instead of only by its ancestors. | ||
| * | ||
| * Results: | ||
| * A standard Tcl result. If an error occurs, a message is left | ||
| * in the interp's result. | ||
| * | ||
| * Side effects: | ||
| * Moves commands from one hash table to another. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) | ||
| Tcl_Interp *interp; /* Interpreter in which to make command | ||
| * callable. */ | ||
| char *hiddenCmdToken; /* Name of hidden command. */ | ||
| char *cmdName; /* Name of to-be-exposed command. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| Command *cmdPtr; | ||
| Namespace *nsPtr; | ||
| Tcl_HashEntry *hPtr; | ||
| Tcl_HashTable *hiddenCmdTablePtr; | ||
| int new; | ||
| if (iPtr->flags & DELETED) { | ||
| /* | ||
| * The interpreter is being deleted. Do not create any new | ||
| * structures, because it is not safe to modify the interpreter. | ||
| */ | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * Check that we have a regular name for the command | ||
| * (that the user is not trying to do an expose and a rename | ||
| * (to another namespace) at the same time) | ||
| */ | ||
| if (strstr(cmdName, "::") != NULL) { | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | ||
| "can not expose to a namespace ", | ||
| "(use expose to toplevel, then rename)", | ||
| (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * Get the command from the hidden command table: | ||
| */ | ||
| hPtr = NULL; | ||
| hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; | ||
| if (hiddenCmdTablePtr != NULL) { | ||
| hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); | ||
| } | ||
| if (hPtr == (Tcl_HashEntry *) NULL) { | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | ||
| "unknown hidden command \"", hiddenCmdToken, | ||
| "\"", (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| cmdPtr = (Command *) Tcl_GetHashValue(hPtr); | ||
| /* | ||
| * Check that we have a true global namespace | ||
| * command (enforced by Tcl_HideCommand() but let's double | ||
| * check. (If it was not, we would not really know how to | ||
| * handle it). | ||
| */ | ||
| if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { | ||
| /* | ||
| * This case is theoritically impossible, | ||
| * we might rather panic() than 'nicely' erroring out ? | ||
| */ | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | ||
| "trying to expose a non global command name space command", | ||
| (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| /* This is the global table */ | ||
| nsPtr = cmdPtr->nsPtr; | ||
| /* | ||
| * It is an error to overwrite an existing exposed command as a result | ||
| * of exposing a previously hidden command. | ||
| */ | ||
| hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new); | ||
| if (!new) { | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | ||
| "exposed command \"", cmdName, | ||
| "\" already exists", (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * Remove the hash entry for the command from the interpreter hidden | ||
| * command table. | ||
| */ | ||
| if (cmdPtr->hPtr != NULL) { | ||
| Tcl_DeleteHashEntry(cmdPtr->hPtr); | ||
| cmdPtr->hPtr = NULL; | ||
| } | ||
| /* | ||
| * Now link the hash table entry with the command structure. | ||
| * This is like creating a new command, so deal with any shadowing | ||
| * of commands in the global namespace. | ||
| */ | ||
| cmdPtr->hPtr = hPtr; | ||
| Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); | ||
| /* | ||
| * Not needed as we are only in the global namespace | ||
| * (but would be needed again if we supported namespace command hiding) | ||
| * | ||
| * TclResetShadowedCmdRefs(interp, cmdPtr); | ||
| */ | ||
| /* | ||
| * If the command being exposed has a compile procedure, increment | ||
| * interpreter's compileEpoch to invalidate its compiled code. This | ||
| * makes sure that we don't later try to execute old code compiled | ||
| * assuming the command is hidden. This field is checked in Tcl_EvalObj | ||
| * and ObjInterpProc, and code whose compilation epoch doesn't match is | ||
| * recompiled. | ||
| */ | ||
| if (cmdPtr->compileProc != NULL) { | ||
| iPtr->compileEpoch++; | ||
| } | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_CreateCommand -- | ||
| * | ||
| * Define a new command in a command table. | ||
| * | ||
| * Results: | ||
| * The return value is a token for the command, which can | ||
| * be used in future calls to Tcl_GetCommandName. | ||
| * | ||
| * Side effects: | ||
| * If a command named cmdName already exists for interp, it is deleted. | ||
| * In the future, when cmdName is seen as the name of a command by | ||
| * Tcl_Eval, proc will be called. To support the bytecode interpreter, | ||
| * the command is created with a wrapper Tcl_ObjCmdProc | ||
| * (TclInvokeStringCommand) that eventially calls proc. When the | ||
| * command is deleted from the table, deleteProc will be called. | ||
| * See the manual entry for details on the calling sequence. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| Tcl_Command | ||
| Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) | ||
| Tcl_Interp *interp; /* Token for command interpreter returned by | ||
| * a previous call to Tcl_CreateInterp. */ | ||
| char *cmdName; /* Name of command. If it contains namespace | ||
| * qualifiers, the new command is put in the | ||
| * specified namespace; otherwise it is put | ||
| * in the global namespace. */ | ||
| Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */ | ||
| ClientData clientData; /* Arbitrary value passed to string proc. */ | ||
| Tcl_CmdDeleteProc *deleteProc; | ||
| /* If not NULL, gives a procedure to call | ||
| * when this command is deleted. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| ImportRef *oldRefPtr = NULL; | ||
| Namespace *nsPtr, *dummy1, *dummy2; | ||
| Command *cmdPtr, *refCmdPtr; | ||
| Tcl_HashEntry *hPtr; | ||
| char *tail; | ||
| int new; | ||
| ImportedCmdData *dataPtr; | ||
| if (iPtr->flags & DELETED) { | ||
| /* | ||
| * The interpreter is being deleted. Don't create any new | ||
| * commands; it's not safe to muck with the interpreter anymore. | ||
| */ | ||
| return (Tcl_Command) NULL; | ||
| } | ||
| /* | ||
| * Determine where the command should reside. If its name contains | ||
| * namespace qualifiers, we put it in the specified namespace; | ||
| * otherwise, we always put it in the global namespace. | ||
| */ | ||
| if (strstr(cmdName, "::") != NULL) { | ||
| TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, | ||
| CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); | ||
| if ((nsPtr == NULL) || (tail == NULL)) { | ||
| return (Tcl_Command) NULL; | ||
| } | ||
| } else { | ||
| nsPtr = iPtr->globalNsPtr; | ||
| tail = cmdName; | ||
| } | ||
| hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); | ||
| if (!new) { | ||
| /* | ||
| * Command already exists. Delete the old one. | ||
| * Be careful to preserve any existing import links so we can | ||
| * restore them down below. That way, you can redefine a | ||
| * command and its import status will remain intact. | ||
| */ | ||
| cmdPtr = (Command *) Tcl_GetHashValue(hPtr); | ||
| oldRefPtr = cmdPtr->importRefPtr; | ||
| cmdPtr->importRefPtr = NULL; | ||
| Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); | ||
| hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); | ||
| if (!new) { | ||
| /* | ||
| * If the deletion callback recreated the command, just throw | ||
| * away the new command (if we try to delete it again, we | ||
| * could get stuck in an infinite loop). | ||
| */ | ||
| ckfree((char*) Tcl_GetHashValue(hPtr)); | ||
| } | ||
| } | ||
| cmdPtr = (Command *) ckalloc(sizeof(Command)); | ||
| Tcl_SetHashValue(hPtr, cmdPtr); | ||
| cmdPtr->hPtr = hPtr; | ||
| cmdPtr->nsPtr = nsPtr; | ||
| cmdPtr->refCount = 1; | ||
| cmdPtr->cmdEpoch = 0; | ||
| cmdPtr->compileProc = (CompileProc *) NULL; | ||
| cmdPtr->objProc = TclInvokeStringCommand; | ||
| cmdPtr->objClientData = (ClientData) cmdPtr; | ||
| cmdPtr->proc = proc; | ||
| cmdPtr->clientData = clientData; | ||
| cmdPtr->deleteProc = deleteProc; | ||
| cmdPtr->deleteData = clientData; | ||
| cmdPtr->deleted = 0; | ||
| cmdPtr->importRefPtr = NULL; | ||
| /* | ||
| * Plug in any existing import references found above. Be sure | ||
| * to update all of these references to point to the new command. | ||
| */ | ||
| if (oldRefPtr != NULL) { | ||
| cmdPtr->importRefPtr = oldRefPtr; | ||
| while (oldRefPtr != NULL) { | ||
| refCmdPtr = oldRefPtr->importedCmdPtr; | ||
| dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; | ||
| dataPtr->realCmdPtr = cmdPtr; | ||
| oldRefPtr = oldRefPtr->nextPtr; | ||
| } | ||
| } | ||
| /* | ||
| * We just created a command, so in its namespace and all of its parent | ||
| * namespaces, it may shadow global commands with the same name. If any | ||
| * shadowed commands are found, invalidate all cached command references | ||
| * in the affected namespaces. | ||
| */ | ||
| TclResetShadowedCmdRefs(interp, cmdPtr); | ||
| return (Tcl_Command) cmdPtr; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_CreateObjCommand -- | ||
| * | ||
| * Define a new object-based command in a command table. | ||
| * | ||
| * Results: | ||
| * The return value is a token for the command, which can | ||
| * be used in future calls to Tcl_GetCommandName. | ||
| * | ||
| * Side effects: | ||
| * If no command named "cmdName" already exists for interp, one is | ||
| * created. Otherwise, if a command does exist, then if the | ||
| * object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume | ||
| * Tcl_CreateCommand was called previously for the same command and | ||
| * just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we | ||
| * delete the old command. | ||
| * | ||
| * In the future, during bytecode evaluation when "cmdName" is seen as | ||
| * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based | ||
| * Tcl_ObjCmdProc proc will be called. When the command is deleted from | ||
| * the table, deleteProc will be called. See the manual entry for | ||
| * details on the calling sequence. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| Tcl_Command | ||
| Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) | ||
| Tcl_Interp *interp; /* Token for command interpreter (returned | ||
| * by previous call to Tcl_CreateInterp). */ | ||
| char *cmdName; /* Name of command. If it contains namespace | ||
| * qualifiers, the new command is put in the | ||
| * specified namespace; otherwise it is put | ||
| * in the global namespace. */ | ||
| Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with | ||
| * name. */ | ||
| ClientData clientData; /* Arbitrary value to pass to object | ||
| * procedure. */ | ||
| Tcl_CmdDeleteProc *deleteProc; | ||
| /* If not NULL, gives a procedure to call | ||
| * when this command is deleted. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| ImportRef *oldRefPtr = NULL; | ||
| Namespace *nsPtr, *dummy1, *dummy2; | ||
| Command *cmdPtr, *refCmdPtr; | ||
| Tcl_HashEntry *hPtr; | ||
| char *tail; | ||
| int new; | ||
| ImportedCmdData *dataPtr; | ||
| if (iPtr->flags & DELETED) { | ||
| /* | ||
| * The interpreter is being deleted. Don't create any new | ||
| * commands; it's not safe to muck with the interpreter anymore. | ||
| */ | ||
| return (Tcl_Command) NULL; | ||
| } | ||
| /* | ||
| * Determine where the command should reside. If its name contains | ||
| * namespace qualifiers, we put it in the specified namespace; | ||
| * otherwise, we always put it in the global namespace. | ||
| */ | ||
| if (strstr(cmdName, "::") != NULL) { | ||
| TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, | ||
| CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); | ||
| if ((nsPtr == NULL) || (tail == NULL)) { | ||
| return (Tcl_Command) NULL; | ||
| } | ||
| } else { | ||
| nsPtr = iPtr->globalNsPtr; | ||
| tail = cmdName; | ||
| } | ||
| hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); | ||
| if (!new) { | ||
| cmdPtr = (Command *) Tcl_GetHashValue(hPtr); | ||
| /* | ||
| * Command already exists. If its object-based Tcl_ObjCmdProc is | ||
| * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the | ||
| * argument "proc". Otherwise, we delete the old command. | ||
| */ | ||
| if (cmdPtr->objProc == TclInvokeStringCommand) { | ||
| cmdPtr->objProc = proc; | ||
| cmdPtr->objClientData = clientData; | ||
| cmdPtr->deleteProc = deleteProc; | ||
| cmdPtr->deleteData = clientData; | ||
| return (Tcl_Command) cmdPtr; | ||
| } | ||
| /* | ||
| * Otherwise, we delete the old command. Be careful to preserve | ||
| * any existing import links so we can restore them down below. | ||
| * That way, you can redefine a command and its import status | ||
| * will remain intact. | ||
| */ | ||
| oldRefPtr = cmdPtr->importRefPtr; | ||
| cmdPtr->importRefPtr = NULL; | ||
| Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); | ||
| hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); | ||
| if (!new) { | ||
| /* | ||
| * If the deletion callback recreated the command, just throw | ||
| * away the new command (if we try to delete it again, we | ||
| * could get stuck in an infinite loop). | ||
| */ | ||
| ckfree((char *) Tcl_GetHashValue(hPtr)); | ||
| } | ||
| } | ||
| cmdPtr = (Command *) ckalloc(sizeof(Command)); | ||
| Tcl_SetHashValue(hPtr, cmdPtr); | ||
| cmdPtr->hPtr = hPtr; | ||
| cmdPtr->nsPtr = nsPtr; | ||
| cmdPtr->refCount = 1; | ||
| cmdPtr->cmdEpoch = 0; | ||
| cmdPtr->compileProc = (CompileProc *) NULL; | ||
| cmdPtr->objProc = proc; | ||
| cmdPtr->objClientData = clientData; | ||
| cmdPtr->proc = TclInvokeObjectCommand; | ||
| cmdPtr->clientData = (ClientData) cmdPtr; | ||
| cmdPtr->deleteProc = deleteProc; | ||
| cmdPtr->deleteData = clientData; | ||
| cmdPtr->deleted = 0; | ||
| cmdPtr->importRefPtr = NULL; | ||
| /* | ||
| * Plug in any existing import references found above. Be sure | ||
| * to update all of these references to point to the new command. | ||
| */ | ||
| if (oldRefPtr != NULL) { | ||
| cmdPtr->importRefPtr = oldRefPtr; | ||
| while (oldRefPtr != NULL) { | ||
| refCmdPtr = oldRefPtr->importedCmdPtr; | ||
| dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; | ||
| dataPtr->realCmdPtr = cmdPtr; | ||
| oldRefPtr = oldRefPtr->nextPtr; | ||
| } | ||
| } | ||
| /* | ||
| * We just created a command, so in its namespace and all of its parent | ||
| * namespaces, it may shadow global commands with the same name. If any | ||
| * shadowed commands are found, invalidate all cached command references | ||
| * in the affected namespaces. | ||
| */ | ||
| TclResetShadowedCmdRefs(interp, cmdPtr); | ||
| return (Tcl_Command) cmdPtr; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * TclInvokeStringCommand -- | ||
| * | ||
| * "Wrapper" Tcl_ObjCmdProc used to call an existing string-based | ||
| * Tcl_CmdProc if no object-based procedure exists for a command. A | ||
| * pointer to this procedure is stored as the Tcl_ObjCmdProc in a | ||
| * Command structure. It simply turns around and calls the string | ||
| * Tcl_CmdProc in the Command structure. | ||
| * | ||
| * Results: | ||
| * A standard Tcl object result value. | ||
| * | ||
| * Side effects: | ||
| * Besides those side effects of the called Tcl_CmdProc, | ||
| * TclInvokeStringCommand allocates and frees storage. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| TclInvokeStringCommand(clientData, interp, objc, objv) | ||
| ClientData clientData; /* Points to command's Command structure. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| register int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| register Command *cmdPtr = (Command *) clientData; | ||
| register int i; | ||
| int result; | ||
| /* | ||
| * This procedure generates an argv array for the string arguments. It | ||
| * starts out with stack-allocated space but uses dynamically-allocated | ||
| * storage if needed. | ||
| */ | ||
| #define NUM_ARGS 20 | ||
| char *(argStorage[NUM_ARGS]); | ||
| char **argv = argStorage; | ||
| /* | ||
| * Create the string argument array "argv". Make sure argv is large | ||
| * enough to hold the objc arguments plus 1 extra for the zero | ||
| * end-of-argv word. | ||
| */ | ||
| if ((objc + 1) > NUM_ARGS) { | ||
| argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); | ||
| } | ||
| for (i = 0; i < objc; i++) { | ||
| argv[i] = Tcl_GetString(objv[i]); | ||
| } | ||
| argv[objc] = 0; | ||
| /* | ||
| * Invoke the command's string-based Tcl_CmdProc. | ||
| */ | ||
| result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv); | ||
| /* | ||
| * Free the argv array if malloc'ed storage was used. | ||
| */ | ||
| if (argv != argStorage) { | ||
| ckfree((char *) argv); | ||
| } | ||
| return result; | ||
| #undef NUM_ARGS | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * TclInvokeObjectCommand -- | ||
| * | ||
| * "Wrapper" Tcl_CmdProc used to call an existing object-based | ||
| * Tcl_ObjCmdProc if no string-based procedure exists for a command. | ||
| * A pointer to this procedure is stored as the Tcl_CmdProc in a | ||
| * Command structure. It simply turns around and calls the object | ||
| * Tcl_ObjCmdProc in the Command structure. | ||
| * | ||
| * Results: | ||
| * A standard Tcl string result value. | ||
| * | ||
| * Side effects: | ||
| * Besides those side effects of the called Tcl_CmdProc, | ||
| * TclInvokeStringCommand allocates and frees storage. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| TclInvokeObjectCommand(clientData, interp, argc, argv) | ||
| ClientData clientData; /* Points to command's Command structure. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int argc; /* Number of arguments. */ | ||
| register char **argv; /* Argument strings. */ | ||
| { | ||
| Command *cmdPtr = (Command *) clientData; | ||
| register Tcl_Obj *objPtr; | ||
| register int i; | ||
| int length, result; | ||
| /* | ||
| * This procedure generates an objv array for object arguments that hold | ||
| * the argv strings. It starts out with stack-allocated space but uses | ||
| * dynamically-allocated storage if needed. | ||
| */ | ||
| #define NUM_ARGS 20 | ||
| Tcl_Obj *(argStorage[NUM_ARGS]); | ||
| register Tcl_Obj **objv = argStorage; | ||
| /* | ||
| * Create the object argument array "objv". Make sure objv is large | ||
| * enough to hold the objc arguments plus 1 extra for the zero | ||
| * end-of-objv word. | ||
| */ | ||
| if ((argc + 1) > NUM_ARGS) { | ||
| objv = (Tcl_Obj **) | ||
| ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); | ||
| } | ||
| for (i = 0; i < argc; i++) { | ||
| length = strlen(argv[i]); | ||
| TclNewObj(objPtr); | ||
| TclInitStringRep(objPtr, argv[i], length); | ||
| Tcl_IncrRefCount(objPtr); | ||
| objv[i] = objPtr; | ||
| } | ||
| objv[argc] = 0; | ||
| /* | ||
| * Invoke the command's object-based Tcl_ObjCmdProc. | ||
| */ | ||
| result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv); | ||
| /* | ||
| * Move the interpreter's object result to the string result, | ||
| * then reset the object result. | ||
| */ | ||
| Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), | ||
| TCL_VOLATILE); | ||
| /* | ||
| * Decrement the ref counts for the argument objects created above, | ||
| * then free the objv array if malloc'ed storage was used. | ||
| */ | ||
| for (i = 0; i < argc; i++) { | ||
| objPtr = objv[i]; | ||
| Tcl_DecrRefCount(objPtr); | ||
| } | ||
| if (objv != argStorage) { | ||
| ckfree((char *) objv); | ||
| } | ||
| return result; | ||
| #undef NUM_ARGS | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * TclRenameCommand -- | ||
| * | ||
| * Called to give an existing Tcl command a different name. Both the | ||
| * old command name and the new command name can have "::" namespace | ||
| * qualifiers. If the new command has a different namespace context, | ||
| * the command will be moved to that namespace and will execute in | ||
| * the context of that new namespace. | ||
| * | ||
| * If the new command name is NULL or the null string, the command is | ||
| * deleted. | ||
| * | ||
| * Results: | ||
| * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. | ||
| * | ||
| * Side effects: | ||
| * If anything goes wrong, an error message is returned in the | ||
| * interpreter's result object. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| TclRenameCommand(interp, oldName, newName) | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| char *oldName; /* Existing command name. */ | ||
| char *newName; /* New command name. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| char *newTail; | ||
| Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2; | ||
| Tcl_Command cmd; | ||
| Command *cmdPtr; | ||
| Tcl_HashEntry *hPtr, *oldHPtr; | ||
| int new, result; | ||
| /* | ||
| * Find the existing command. An error is returned if cmdName can't | ||
| * be found. | ||
| */ | ||
| cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL, | ||
| /*flags*/ 0); | ||
| cmdPtr = (Command *) cmd; | ||
| if (cmdPtr == NULL) { | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ", | ||
| ((newName == NULL)||(*newName == '\0'))? "delete":"rename", | ||
| " \"", oldName, "\": command doesn't exist", (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| cmdNsPtr = cmdPtr->nsPtr; | ||
| /* | ||
| * If the new command name is NULL or empty, delete the command. Do this | ||
| * with Tcl_DeleteCommandFromToken, since we already have the command. | ||
| */ | ||
| if ((newName == NULL) || (*newName == '\0')) { | ||
| Tcl_DeleteCommandFromToken(interp, cmd); | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| * Make sure that the destination command does not already exist. | ||
| * The rename operation is like creating a command, so we should | ||
| * automatically create the containing namespaces just like | ||
| * Tcl_CreateCommand would. | ||
| */ | ||
| TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL, | ||
| CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); | ||
| if ((newNsPtr == NULL) || (newTail == NULL)) { | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | ||
| "can't rename to \"", newName, "\": bad command name", | ||
| (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) { | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | ||
| "can't rename to \"", newName, | ||
| "\": command already exists", (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * Warning: any changes done in the code here are likely | ||
| * to be needed in Tcl_HideCommand() code too. | ||
| * (until the common parts are extracted out) --dl | ||
| */ | ||
| /* | ||
| * Put the command in the new namespace so we can check for an alias | ||
| * loop. Since we are adding a new command to a namespace, we must | ||
| * handle any shadowing of the global commands that this might create. | ||
| */ | ||
| oldHPtr = cmdPtr->hPtr; | ||
| hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new); | ||
| Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); | ||
| cmdPtr->hPtr = hPtr; | ||
| cmdPtr->nsPtr = newNsPtr; | ||
| TclResetShadowedCmdRefs(interp, cmdPtr); | ||
| /* | ||
| * Now check for an alias loop. If we detect one, put everything back | ||
| * the way it was and report the error. | ||
| */ | ||
| result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr); | ||
| if (result != TCL_OK) { | ||
| Tcl_DeleteHashEntry(cmdPtr->hPtr); | ||
| cmdPtr->hPtr = oldHPtr; | ||
| cmdPtr->nsPtr = cmdNsPtr; | ||
| return result; | ||
| } | ||
| /* | ||
| * The new command name is okay, so remove the command from its | ||
| * current namespace. This is like deleting the command, so bump | ||
| * the cmdEpoch to invalidate any cached references to the command. | ||
| */ | ||
| Tcl_DeleteHashEntry(oldHPtr); | ||
| cmdPtr->cmdEpoch++; | ||
| /* | ||
| * If the command being renamed has a compile procedure, increment the | ||
| * interpreter's compileEpoch to invalidate its compiled code. This | ||
| * makes sure that we don't later try to execute old code compiled for | ||
| * the now-renamed command. | ||
| */ | ||
| if (cmdPtr->compileProc != NULL) { | ||
| iPtr->compileEpoch++; | ||
| } | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_SetCommandInfo -- | ||
| * | ||
| * Modifies various information about a Tcl command. Note that | ||
| * this procedure will not change a command's namespace; use | ||
| * Tcl_RenameCommand to do that. Also, the isNativeObjectProc | ||
| * member of *infoPtr is ignored. | ||
| * | ||
| * Results: | ||
| * If cmdName exists in interp, then the information at *infoPtr | ||
| * is stored with the command in place of the current information | ||
| * and 1 is returned. If the command doesn't exist then 0 is | ||
| * returned. | ||
| * | ||
| * Side effects: | ||
| * None. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_SetCommandInfo(interp, cmdName, infoPtr) | ||
| Tcl_Interp *interp; /* Interpreter in which to look | ||
| * for command. */ | ||
| char *cmdName; /* Name of desired command. */ | ||
| Tcl_CmdInfo *infoPtr; /* Where to find information | ||
| * to store in the command. */ | ||
| { | ||
| Tcl_Command cmd; | ||
| Command *cmdPtr; | ||
| cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, | ||
| /*flags*/ 0); | ||
| if (cmd == (Tcl_Command) NULL) { | ||
| return 0; | ||
| } | ||
| /* | ||
| * The isNativeObjectProc and nsPtr members of *infoPtr are ignored. | ||
| */ | ||
| cmdPtr = (Command *) cmd; | ||
| cmdPtr->proc = infoPtr->proc; | ||
| cmdPtr->clientData = infoPtr->clientData; | ||
| if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { | ||
| cmdPtr->objProc = TclInvokeStringCommand; | ||
| cmdPtr->objClientData = (ClientData) cmdPtr; | ||
| } else { | ||
| cmdPtr->objProc = infoPtr->objProc; | ||
| cmdPtr->objClientData = infoPtr->objClientData; | ||
| } | ||
| cmdPtr->deleteProc = infoPtr->deleteProc; | ||
| cmdPtr->deleteData = infoPtr->deleteData; | ||
| return 1; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_GetCommandInfo -- | ||
| * | ||
| * Returns various information about a Tcl command. | ||
| * | ||
| * Results: | ||
| * If cmdName exists in interp, then *infoPtr is modified to | ||
| * hold information about cmdName and 1 is returned. If the | ||
| * command doesn't exist then 0 is returned and *infoPtr isn't | ||
| * modified. | ||
| * | ||
| * Side effects: | ||
| * None. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_GetCommandInfo(interp, cmdName, infoPtr) | ||
| Tcl_Interp *interp; /* Interpreter in which to look | ||
| * for command. */ | ||
| char *cmdName; /* Name of desired command. */ | ||
| Tcl_CmdInfo *infoPtr; /* Where to store information about | ||
| * command. */ | ||
| { | ||
| Tcl_Command cmd; | ||
| Command *cmdPtr; | ||
| cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, | ||
| /*flags*/ 0); | ||
| if (cmd == (Tcl_Command) NULL) { | ||
| return 0; | ||
| } | ||
| /* | ||
| * Set isNativeObjectProc 1 if objProc was registered by a call to | ||
| * Tcl_CreateObjCommand. Otherwise set it to 0. | ||
| */ | ||
| cmdPtr = (Command *) cmd; | ||
| infoPtr->isNativeObjectProc = | ||
| (cmdPtr->objProc != TclInvokeStringCommand); | ||
| infoPtr->objProc = cmdPtr->objProc; | ||
| infoPtr->objClientData = cmdPtr->objClientData; | ||
| infoPtr->proc = cmdPtr->proc; | ||
| infoPtr->clientData = cmdPtr->clientData; | ||
| infoPtr->deleteProc = cmdPtr->deleteProc; | ||
| infoPtr->deleteData = cmdPtr->deleteData; | ||
| infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; | ||
| return 1; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_GetCommandName -- | ||
| * | ||
| * Given a token returned by Tcl_CreateCommand, this procedure | ||
| * returns the current name of the command (which may have changed | ||
| * due to renaming). | ||
| * | ||
| * Results: | ||
| * The return value is the name of the given command. | ||
| * | ||
| * Side effects: | ||
| * None. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| char * | ||
| Tcl_GetCommandName(interp, command) | ||
| Tcl_Interp *interp; /* Interpreter containing the command. */ | ||
| Tcl_Command command; /* Token for command returned by a previous | ||
| * call to Tcl_CreateCommand. The command | ||
| * must not have been deleted. */ | ||
| { | ||
| Command *cmdPtr = (Command *) command; | ||
| if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) { | ||
| /* | ||
| * This should only happen if command was "created" after the | ||
| * interpreter began to be deleted, so there isn't really any | ||
| * command. Just return an empty string. | ||
| */ | ||
| return ""; | ||
| } | ||
| return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_GetCommandFullName -- | ||
| * | ||
| * Given a token returned by, e.g., Tcl_CreateCommand or | ||
| * Tcl_FindCommand, this procedure appends to an object the command's | ||
| * full name, qualified by a sequence of parent namespace names. The | ||
| * command's fully-qualified name may have changed due to renaming. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * The command's fully-qualified name is appended to the string | ||
| * representation of objPtr. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| void | ||
| Tcl_GetCommandFullName(interp, command, objPtr) | ||
| Tcl_Interp *interp; /* Interpreter containing the command. */ | ||
| Tcl_Command command; /* Token for command returned by a previous | ||
| * call to Tcl_CreateCommand. The command | ||
| * must not have been deleted. */ | ||
| Tcl_Obj *objPtr; /* Points to the object onto which the | ||
| * command's full name is appended. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| register Command *cmdPtr = (Command *) command; | ||
| char *name; | ||
| /* | ||
| * Add the full name of the containing namespace, followed by the "::" | ||
| * separator, and the command name. | ||
| */ | ||
| if (cmdPtr != NULL) { | ||
| if (cmdPtr->nsPtr != NULL) { | ||
| Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1); | ||
| if (cmdPtr->nsPtr != iPtr->globalNsPtr) { | ||
| Tcl_AppendToObj(objPtr, "::", 2); | ||
| } | ||
| } | ||
| if (cmdPtr->hPtr != NULL) { | ||
| name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); | ||
| Tcl_AppendToObj(objPtr, name, -1); | ||
| } | ||
| } | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_DeleteCommand -- | ||
| * | ||
| * Remove the given command from the given interpreter. | ||
| * | ||
| * Results: | ||
| * 0 is returned if the command was deleted successfully. | ||
| * -1 is returned if there didn't exist a command by that name. | ||
| * | ||
| * Side effects: | ||
| * cmdName will no longer be recognized as a valid command for | ||
| * interp. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_DeleteCommand(interp, cmdName) | ||
| Tcl_Interp *interp; /* Token for command interpreter (returned | ||
| * by a previous Tcl_CreateInterp call). */ | ||
| char *cmdName; /* Name of command to remove. */ | ||
| { | ||
| Tcl_Command cmd; | ||
| /* | ||
| * Find the desired command and delete it. | ||
| */ | ||
| cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, | ||
| /*flags*/ 0); | ||
| if (cmd == (Tcl_Command) NULL) { | ||
| return -1; | ||
| } | ||
| return Tcl_DeleteCommandFromToken(interp, cmd); | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_DeleteCommandFromToken -- | ||
| * | ||
| * Removes the given command from the given interpreter. This procedure | ||
| * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead | ||
| * of a command name for efficiency. | ||
| * | ||
| * Results: | ||
| * 0 is returned if the command was deleted successfully. | ||
| * -1 is returned if there didn't exist a command by that name. | ||
| * | ||
| * Side effects: | ||
| * The command specified by "cmd" will no longer be recognized as a | ||
| * valid command for "interp". | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_DeleteCommandFromToken(interp, cmd) | ||
| Tcl_Interp *interp; /* Token for command interpreter returned by | ||
| * a previous call to Tcl_CreateInterp. */ | ||
| Tcl_Command cmd; /* Token for command to delete. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| Command *cmdPtr = (Command *) cmd; | ||
| ImportRef *refPtr, *nextRefPtr; | ||
| Tcl_Command importCmd; | ||
| /* | ||
| * The code here is tricky. We can't delete the hash table entry | ||
| * before invoking the deletion callback because there are cases | ||
| * where the deletion callback needs to invoke the command (e.g. | ||
| * object systems such as OTcl). However, this means that the | ||
| * callback could try to delete or rename the command. The deleted | ||
| * flag allows us to detect these cases and skip nested deletes. | ||
| */ | ||
| if (cmdPtr->deleted) { | ||
| /* | ||
| * Another deletion is already in progress. Remove the hash | ||
| * table entry now, but don't invoke a callback or free the | ||
| * command structure. | ||
| */ | ||
| Tcl_DeleteHashEntry(cmdPtr->hPtr); | ||
| cmdPtr->hPtr = NULL; | ||
| return 0; | ||
| } | ||
| /* | ||
| * If the command being deleted has a compile procedure, increment the | ||
| * interpreter's compileEpoch to invalidate its compiled code. This | ||
| * makes sure that we don't later try to execute old code compiled with | ||
| * command-specific (i.e., inline) bytecodes for the now-deleted | ||
| * command. This field is checked in Tcl_EvalObj and ObjInterpProc, and | ||
| * code whose compilation epoch doesn't match is recompiled. | ||
| */ | ||
| if (cmdPtr->compileProc != NULL) { | ||
| iPtr->compileEpoch++; | ||
| } | ||
| cmdPtr->deleted = 1; | ||
| if (cmdPtr->deleteProc != NULL) { | ||
| /* | ||
| * Delete the command's client data. If this was an imported command | ||
| * created when a command was imported into a namespace, this client | ||
| * data will be a pointer to a ImportedCmdData structure describing | ||
| * the "real" command that this imported command refers to. | ||
| */ | ||
| /* | ||
| * If you are getting a crash during the call to deleteProc and | ||
| * cmdPtr->deleteProc is a pointer to the function free(), the | ||
| * most likely cause is that your extension allocated memory | ||
| * for the clientData argument to Tcl_CreateObjCommand() with | ||
| * the ckalloc() macro and you are now trying to deallocate | ||
| * this memory with free() instead of ckfree(). You should | ||
| * pass a pointer to your own method that calls ckfree(). | ||
| */ | ||
| (*cmdPtr->deleteProc)(cmdPtr->deleteData); | ||
| } | ||
| /* | ||
| * Bump the command epoch counter. This will invalidate all cached | ||
| * references that point to this command. | ||
| */ | ||
| cmdPtr->cmdEpoch++; | ||
| /* | ||
| * If this command was imported into other namespaces, then imported | ||
| * commands were created that refer back to this command. Delete these | ||
| * imported commands now. | ||
| */ | ||
| for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; | ||
| refPtr = nextRefPtr) { | ||
| nextRefPtr = refPtr->nextPtr; | ||
| importCmd = (Tcl_Command) refPtr->importedCmdPtr; | ||
| Tcl_DeleteCommandFromToken(interp, importCmd); | ||
| } | ||
| /* | ||
| * Don't use hPtr to delete the hash entry here, because it's | ||
| * possible that the deletion callback renamed the command. | ||
| * Instead, use cmdPtr->hptr, and make sure that no-one else | ||
| * has already deleted the hash entry. | ||
| */ | ||
| if (cmdPtr->hPtr != NULL) { | ||
| Tcl_DeleteHashEntry(cmdPtr->hPtr); | ||
| } | ||
| /* | ||
| * Mark the Command structure as no longer valid. This allows | ||
| * TclExecuteByteCode to recognize when a Command has logically been | ||
| * deleted and a pointer to this Command structure cached in a CmdName | ||
| * object is invalid. TclExecuteByteCode will look up the command again | ||
| * in the interpreter's command hashtable. | ||
| */ | ||
| cmdPtr->objProc = NULL; | ||
| /* | ||
| * Now free the Command structure, unless there is another reference to | ||
| * it from a CmdName Tcl object in some ByteCode code sequence. In that | ||
| * case, delay the cleanup until all references are either discarded | ||
| * (when a ByteCode is freed) or replaced by a new reference (when a | ||
| * cached CmdName Command reference is found to be invalid and | ||
| * TclExecuteByteCode looks up the command in the command hashtable). | ||
| */ | ||
| TclCleanupCommand(cmdPtr); | ||
| return 0; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * TclCleanupCommand -- | ||
| * | ||
| * This procedure frees up a Command structure unless it is still | ||
| * referenced from an interpreter's command hashtable or from a CmdName | ||
| * Tcl object representing the name of a command in a ByteCode | ||
| * instruction sequence. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * Memory gets freed unless a reference to the Command structure still | ||
| * exists. In that case the cleanup is delayed until the command is | ||
| * deleted or when the last ByteCode referring to it is freed. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| void | ||
| TclCleanupCommand(cmdPtr) | ||
| register Command *cmdPtr; /* Points to the Command structure to | ||
| * be freed. */ | ||
| { | ||
| cmdPtr->refCount--; | ||
| if (cmdPtr->refCount <= 0) { | ||
| ckfree((char *) cmdPtr); | ||
| } | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_CreateMathFunc -- | ||
| * | ||
| * Creates a new math function for expressions in a given | ||
| * interpreter. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * The function defined by "name" is created or redefined. If the | ||
| * function already exists then its definition is replaced; this | ||
| * includes the builtin functions. Redefining a builtin function forces | ||
| * all existing code to be invalidated since that code may be compiled | ||
| * using an instruction specific to the replaced function. In addition, | ||
| * redefioning a non-builtin function will force existing code to be | ||
| * invalidated if the number of arguments has changed. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| void | ||
| Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) | ||
| Tcl_Interp *interp; /* Interpreter in which function is | ||
| * to be available. */ | ||
| char *name; /* Name of function (e.g. "sin"). */ | ||
| int numArgs; /* Nnumber of arguments required by | ||
| * function. */ | ||
| Tcl_ValueType *argTypes; /* Array of types acceptable for | ||
| * each argument. */ | ||
| Tcl_MathProc *proc; /* Procedure that implements the | ||
| * math function. */ | ||
| ClientData clientData; /* Additional value to pass to the | ||
| * function. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| Tcl_HashEntry *hPtr; | ||
| MathFunc *mathFuncPtr; | ||
| int new, i; | ||
| hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); | ||
| if (new) { | ||
| Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); | ||
| } | ||
| mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); | ||
| if (!new) { | ||
| if (mathFuncPtr->builtinFuncIndex >= 0) { | ||
| /* | ||
| * We are redefining a builtin math function. Invalidate the | ||
| * interpreter's existing code by incrementing its | ||
| * compileEpoch member. This field is checked in Tcl_EvalObj | ||
| * and ObjInterpProc, and code whose compilation epoch doesn't | ||
| * match is recompiled. Newly compiled code will no longer | ||
| * treat the function as builtin. | ||
| */ | ||
| iPtr->compileEpoch++; | ||
| } else { | ||
| /* | ||
| * A non-builtin function is being redefined. We must invalidate | ||
| * existing code if the number of arguments has changed. This | ||
| * is because existing code was compiled assuming that number. | ||
| */ | ||
| if (numArgs != mathFuncPtr->numArgs) { | ||
| iPtr->compileEpoch++; | ||
| } | ||
| } | ||
| } | ||
| mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */ | ||
| if (numArgs > MAX_MATH_ARGS) { | ||
| numArgs = MAX_MATH_ARGS; | ||
| } | ||
| mathFuncPtr->numArgs = numArgs; | ||
| for (i = 0; i < numArgs; i++) { | ||
| mathFuncPtr->argTypes[i] = argTypes[i]; | ||
| } | ||
| mathFuncPtr->proc = proc; | ||
| mathFuncPtr->clientData = clientData; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_EvalObjEx -- | ||
| * | ||
| * Execute Tcl commands stored in a Tcl object. These commands are | ||
| * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT | ||
| * is specified. | ||
| * | ||
| * Results: | ||
| * The return value is one of the return codes defined in tcl.h | ||
| * (such as TCL_OK), and the interpreter's result contains a value | ||
| * to supplement the return code. | ||
| * | ||
| * Side effects: | ||
| * The object is converted, if necessary, to a ByteCode object that | ||
| * holds the bytecode instructions for the commands. Executing the | ||
| * commands will almost certainly have side effects that depend | ||
| * on those commands. | ||
| * | ||
| * Just as in Tcl_Eval, interp->termOffset is set to the offset of the | ||
| * last character executed in the objPtr's string. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_EvalObjEx(interp, objPtr, flags) | ||
| Tcl_Interp *interp; /* Token for command interpreter | ||
| * (returned by a previous call to | ||
| * Tcl_CreateInterp). */ | ||
| register Tcl_Obj *objPtr; /* Pointer to object containing | ||
| * commands to execute. */ | ||
| int flags; /* Collection of OR-ed bits that | ||
| * control the evaluation of the | ||
| * script. Supported values are | ||
| * TCL_EVAL_GLOBAL and | ||
| * TCL_EVAL_DIRECT. */ | ||
| { | ||
| register Interp *iPtr = (Interp *) interp; | ||
| int evalFlags; /* Interp->evalFlags value when the | ||
| * procedure was called. */ | ||
| register ByteCode* codePtr; /* Tcl Internal type of bytecode. */ | ||
| int oldCount = iPtr->cmdCount; /* Used to tell whether any commands | ||
| * at all were executed. */ | ||
| int numSrcBytes; | ||
| int result; | ||
| CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr | ||
| * in case TCL_EVAL_GLOBAL was set. */ | ||
| Namespace *namespacePtr; | ||
| Tcl_IncrRefCount(objPtr); | ||
| if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) { | ||
| /* | ||
| * We're not supposed to use the compiler or byte-code interpreter. | ||
| * Let Tcl_EvalEx evaluate the command directly (and probably | ||
| * more slowly). | ||
| * | ||
| * Pure List Optimization (no string representation). In this | ||
| * case, we can safely use Tcl_EvalObjv instead and get an | ||
| * appreciable improvement in execution speed. This is because it | ||
| * allows us to avoid a setFromAny step that would just pack | ||
| * everything into a string and back out again. | ||
| * | ||
| * USE_EVAL_DIRECT is a special flag used for testing purpose only | ||
| * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt) | ||
| */ | ||
| if (!(iPtr->flags & USE_EVAL_DIRECT) && | ||
| (objPtr->typePtr == &tclListType) && /* is a list... */ | ||
| (objPtr->bytes == NULL) /* ...without a string rep */) { | ||
| register List *listRepPtr = | ||
| (List *) objPtr->internalRep.otherValuePtr; | ||
| result = Tcl_EvalObjv(interp, listRepPtr->elemCount, | ||
| listRepPtr->elements, flags); | ||
| } else { | ||
| register char *p; | ||
| p = Tcl_GetStringFromObj(objPtr, &numSrcBytes); | ||
| result = Tcl_EvalEx(interp, p, numSrcBytes, flags); | ||
| } | ||
| Tcl_DecrRefCount(objPtr); | ||
| return result; | ||
| } | ||
| /* | ||
| * Prevent the object from being deleted as a side effect of evaling it. | ||
| */ | ||
| savedVarFramePtr = iPtr->varFramePtr; | ||
| if (flags & TCL_EVAL_GLOBAL) { | ||
| iPtr->varFramePtr = NULL; | ||
| } | ||
| /* | ||
| * Reset both the interpreter's string and object results and clear out | ||
| * any error information. This makes sure that we return an empty | ||
| * result if there are no commands in the command string. | ||
| */ | ||
| Tcl_ResetResult(interp); | ||
| /* | ||
| * Check depth of nested calls to Tcl_Eval: if this gets too large, | ||
| * it's probably because of an infinite loop somewhere. | ||
| */ | ||
| iPtr->numLevels++; | ||
| if (iPtr->numLevels > iPtr->maxNestingDepth) { | ||
| Tcl_AppendToObj(Tcl_GetObjResult(interp), | ||
| "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); | ||
| result = TCL_ERROR; | ||
| goto done; | ||
| } | ||
| /* | ||
| * On the Mac, we will never reach the default recursion limit before | ||
| * blowing the stack. So we need to do a check here. | ||
| */ | ||
| if (TclpCheckStackSpace() == 0) { | ||
| /*NOTREACHED*/ | ||
| Tcl_AppendToObj(Tcl_GetObjResult(interp), | ||
| "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); | ||
| result = TCL_ERROR; | ||
| goto done; | ||
| } | ||
| /* | ||
| * If the interpreter has been deleted, return an error. | ||
| */ | ||
| if (iPtr->flags & DELETED) { | ||
| Tcl_ResetResult(interp); | ||
| Tcl_AppendToObj(Tcl_GetObjResult(interp), | ||
| "attempt to call eval in deleted interpreter", -1); | ||
| Tcl_SetErrorCode(interp, "CORE", "IDELETE", | ||
| "attempt to call eval in deleted interpreter", | ||
| (char *) NULL); | ||
| result = TCL_ERROR; | ||
| goto done; | ||
| } | ||
| /* | ||
| * Get the ByteCode from the object. If it exists, make sure it hasn't | ||
| * been invalidated by, e.g., someone redefining a command with a | ||
| * compile procedure (this might make the compiled code wrong). If | ||
| * necessary, convert the object to be a ByteCode object and compile it. | ||
| * Also, if the code was compiled in/for a different interpreter, | ||
| * or for a different namespace, or for the same namespace but | ||
| * with different name resolution rules, we recompile it. | ||
| * | ||
| * Precompiled objects, however, are immutable and therefore | ||
| * they are not recompiled, even if the epoch has changed. | ||
| * | ||
| * To be pedantically correct, we should also check that the | ||
| * originating procPtr is the same as the current context procPtr | ||
| * (assuming one exists at all - none for global level). This | ||
| * code is #def'ed out because [info body] was changed to never | ||
| * return a bytecode type object, which should obviate us from | ||
| * the extra checks here. | ||
| */ | ||
| if (iPtr->varFramePtr != NULL) { | ||
| namespacePtr = iPtr->varFramePtr->nsPtr; | ||
| } else { | ||
| namespacePtr = iPtr->globalNsPtr; | ||
| } | ||
| if (objPtr->typePtr == &tclByteCodeType) { | ||
| codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; | ||
| if (((Interp *) *codePtr->interpHandle != iPtr) | ||
| || (codePtr->compileEpoch != iPtr->compileEpoch) | ||
| #ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */ | ||
| || (codePtr->procPtr != NULL && !(iPtr->varFramePtr && | ||
| iPtr->varFramePtr->procPtr == codePtr->procPtr)) | ||
| #endif | ||
| || (codePtr->nsPtr != namespacePtr) | ||
| || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { | ||
| if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { | ||
| if ((Interp *) *codePtr->interpHandle != iPtr) { | ||
| panic("Tcl_EvalObj: compiled script jumped interps"); | ||
| } | ||
| codePtr->compileEpoch = iPtr->compileEpoch; | ||
| } else { | ||
| tclByteCodeType.freeIntRepProc(objPtr); | ||
| } | ||
| } | ||
| } | ||
| if (objPtr->typePtr != &tclByteCodeType) { | ||
| iPtr->errorLine = 1; | ||
| result = tclByteCodeType.setFromAnyProc(interp, objPtr); | ||
| if (result != TCL_OK) { | ||
| goto done; | ||
| } | ||
| } else { | ||
| codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; | ||
| if (((Interp *) *codePtr->interpHandle != iPtr) | ||
| || (codePtr->compileEpoch != iPtr->compileEpoch)) { | ||
| (*tclByteCodeType.freeIntRepProc)(objPtr); | ||
| iPtr->errorLine = 1; | ||
| result = (*tclByteCodeType.setFromAnyProc)(interp, objPtr); | ||
| if (result != TCL_OK) { | ||
| iPtr->numLevels--; | ||
| return result; | ||
| } | ||
| } | ||
| } | ||
| codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; | ||
| /* | ||
| * Extract then reset the compilation flags in the interpreter. | ||
| * Resetting the flags must be done after any compilation. | ||
| */ | ||
| evalFlags = iPtr->evalFlags; | ||
| iPtr->evalFlags = 0; | ||
| /* | ||
| * Execute the commands. If the code was compiled from an empty string, | ||
| * don't bother executing the code. | ||
| */ | ||
| numSrcBytes = codePtr->numSrcBytes; | ||
| if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { | ||
| /* | ||
| * Increment the code's ref count while it is being executed. If | ||
| * afterwards no references to it remain, free the code. | ||
| */ | ||
| codePtr->refCount++; | ||
| result = TclExecuteByteCode(interp, codePtr); | ||
| codePtr->refCount--; | ||
| if (codePtr->refCount <= 0) { | ||
| TclCleanupByteCode(codePtr); | ||
| } | ||
| } else { | ||
| result = TCL_OK; | ||
| } | ||
| /* | ||
| * If no commands at all were executed, check for asynchronous | ||
| * handlers so that they at least get one change to execute. | ||
| * This is needed to handle event loops written in Tcl with | ||
| * empty bodies. | ||
| */ | ||
| if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) { | ||
| result = Tcl_AsyncInvoke(interp, result); | ||
| } | ||
| /* | ||
| * Update the interpreter's evaluation level count. If we are again at | ||
| * the top level, process any unusual return code returned by the | ||
| * evaluated code. | ||
| */ | ||
| if (iPtr->numLevels == 1) { | ||
| if (result == TCL_RETURN) { | ||
| result = TclUpdateReturnInfo(iPtr); | ||
| } | ||
| if ((result != TCL_OK) && (result != TCL_ERROR) | ||
| && ((evalFlags & TCL_ALLOW_EXCEPTIONS) == 0)) { | ||
| ProcessUnexpectedResult(interp, result); | ||
| result = TCL_ERROR; | ||
| } | ||
| } | ||
| /* | ||
| * If an error occurred, record information about what was being | ||
| * executed when the error occurred. | ||
| */ | ||
| if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { | ||
| RecordTracebackInfo(interp, objPtr, numSrcBytes); | ||
| } | ||
| /* | ||
| * Set the interpreter's termOffset member to the offset of the | ||
| * character just after the last one executed. We approximate the offset | ||
| * of the last character executed by using the number of characters | ||
| * compiled. | ||
| */ | ||
| iPtr->termOffset = numSrcBytes; | ||
| iPtr->flags &= ~ERR_ALREADY_LOGGED; | ||
| done: | ||
| TclDecrRefCount(objPtr); | ||
| iPtr->varFramePtr = savedVarFramePtr; | ||
| iPtr->numLevels--; | ||
| return result; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * ProcessUnexpectedResult -- | ||
| * | ||
| * Procedure called by Tcl_EvalObj to set the interpreter's result | ||
| * value to an appropriate error message when the code it evaluates | ||
| * returns an unexpected result code (not TCL_OK and not TCL_ERROR) to | ||
| * the topmost evaluation level. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * The interpreter result is set to an error message appropriate to | ||
| * the result code. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| static void | ||
| ProcessUnexpectedResult(interp, returnCode) | ||
| Tcl_Interp *interp; /* The interpreter in which the unexpected | ||
| * result code was returned. */ | ||
| int returnCode; /* The unexpected result code. */ | ||
| { | ||
| Tcl_ResetResult(interp); | ||
| if (returnCode == TCL_BREAK) { | ||
| Tcl_AppendToObj(Tcl_GetObjResult(interp), | ||
| "invoked \"break\" outside of a loop", -1); | ||
| } else if (returnCode == TCL_CONTINUE) { | ||
| Tcl_AppendToObj(Tcl_GetObjResult(interp), | ||
| "invoked \"continue\" outside of a loop", -1); | ||
| } else { | ||
| char buf[30 + TCL_INTEGER_SPACE]; | ||
| sprintf(buf, "command returned bad code: %d", returnCode); | ||
| Tcl_SetResult(interp, buf, TCL_VOLATILE); | ||
| } | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * RecordTracebackInfo -- | ||
| * | ||
| * Procedure called by Tcl_EvalObj to record information about what was | ||
| * being executed when the error occurred. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * Appends information about the script being evaluated to the | ||
| * interpreter's "errorInfo" variable. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| static void | ||
| RecordTracebackInfo(interp, objPtr, numSrcBytes) | ||
| Tcl_Interp *interp; /* The interpreter in which the error | ||
| * occurred. */ | ||
| Tcl_Obj *objPtr; /* Points to object containing script whose | ||
| * evaluation resulted in an error. */ | ||
| int numSrcBytes; /* Number of bytes compiled in script. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| char buf[200]; | ||
| char *ellipsis, *bytes; | ||
| int length; | ||
| /* | ||
| * Decide how much of the command to print in the error message | ||
| * (up to a certain number of bytes). | ||
| */ | ||
| bytes = Tcl_GetStringFromObj(objPtr, &length); | ||
| length = TclMin(numSrcBytes, length); | ||
| ellipsis = ""; | ||
| if (length > 150) { | ||
| length = 150; | ||
| ellipsis = " ..."; | ||
| } | ||
| if (!(iPtr->flags & ERR_IN_PROGRESS)) { | ||
| sprintf(buf, "\n while executing\n\"%.*s%s\"", | ||
| length, bytes, ellipsis); | ||
| } else { | ||
| sprintf(buf, "\n invoked from within\n\"%.*s%s\"", | ||
| length, bytes, ellipsis); | ||
| } | ||
| Tcl_AddObjErrorInfo(interp, buf, -1); | ||
| } | ||
| /* | ||
| *--------------------------------------------------------------------------- | ||
| * | ||
| * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- | ||
| * | ||
| * Procedures to evaluate an expression and return its value in a | ||
| * particular form. | ||
| * | ||
| * Results: | ||
| * Each of the procedures below returns a standard Tcl result. If an | ||
| * error occurs then an error message is left in the interp's result. | ||
| * Otherwise the value of the expression, in the appropriate form, | ||
| * is stored at *ptr. If the expression had a result that was | ||
| * incompatible with the desired form then an error is returned. | ||
| * | ||
| * Side effects: | ||
| * None. | ||
| * | ||
| *--------------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_ExprLong(interp, string, ptr) | ||
| Tcl_Interp *interp; /* Context in which to evaluate the | ||
| * expression. */ | ||
| char *string; /* Expression to evaluate. */ | ||
| long *ptr; /* Where to store result. */ | ||
| { | ||
| register Tcl_Obj *exprPtr; | ||
| Tcl_Obj *resultPtr; | ||
| int length = strlen(string); | ||
| int result = TCL_OK; | ||
| if (length > 0) { | ||
| exprPtr = Tcl_NewStringObj(string, length); | ||
| Tcl_IncrRefCount(exprPtr); | ||
| result = Tcl_ExprObj(interp, exprPtr, &resultPtr); | ||
| if (result == TCL_OK) { | ||
| /* | ||
| * Store an integer based on the expression result. | ||
| */ | ||
| if (resultPtr->typePtr == &tclIntType) { | ||
| *ptr = resultPtr->internalRep.longValue; | ||
| } else if (resultPtr->typePtr == &tclDoubleType) { | ||
| *ptr = (long) resultPtr->internalRep.doubleValue; | ||
| } else { | ||
| Tcl_SetResult(interp, | ||
| "expression didn't have numeric value", TCL_STATIC); | ||
| result = TCL_ERROR; | ||
| } | ||
| Tcl_DecrRefCount(resultPtr); /* discard the result object */ | ||
| } else { | ||
| /* | ||
| * Move the interpreter's object result to the string result, | ||
| * then reset the object result. | ||
| */ | ||
| Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), | ||
| TCL_VOLATILE); | ||
| } | ||
| Tcl_DecrRefCount(exprPtr); /* discard the expression object */ | ||
| } else { | ||
| /* | ||
| * An empty string. Just set the result integer to 0. | ||
| */ | ||
| *ptr = 0; | ||
| } | ||
| return result; | ||
| } | ||
| int | ||
| Tcl_ExprDouble(interp, string, ptr) | ||
| Tcl_Interp *interp; /* Context in which to evaluate the | ||
| * expression. */ | ||
| char *string; /* Expression to evaluate. */ | ||
| double *ptr; /* Where to store result. */ | ||
| { | ||
| register Tcl_Obj *exprPtr; | ||
| Tcl_Obj *resultPtr; | ||
| int length = strlen(string); | ||
| int result = TCL_OK; | ||
| if (length > 0) { | ||
| exprPtr = Tcl_NewStringObj(string, length); | ||
| Tcl_IncrRefCount(exprPtr); | ||
| result = Tcl_ExprObj(interp, exprPtr, &resultPtr); | ||
| if (result == TCL_OK) { | ||
| /* | ||
| * Store a double based on the expression result. | ||
| */ | ||
| if (resultPtr->typePtr == &tclIntType) { | ||
| *ptr = (double) resultPtr->internalRep.longValue; | ||
| } else if (resultPtr->typePtr == &tclDoubleType) { | ||
| *ptr = resultPtr->internalRep.doubleValue; | ||
| } else { | ||
| Tcl_SetResult(interp, | ||
| "expression didn't have numeric value", TCL_STATIC); | ||
| result = TCL_ERROR; | ||
| } | ||
| Tcl_DecrRefCount(resultPtr); /* discard the result object */ | ||
| } else { | ||
| /* | ||
| * Move the interpreter's object result to the string result, | ||
| * then reset the object result. | ||
| */ | ||
| Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), | ||
| TCL_VOLATILE); | ||
| } | ||
| Tcl_DecrRefCount(exprPtr); /* discard the expression object */ | ||
| } else { | ||
| /* | ||
| * An empty string. Just set the result double to 0.0. | ||
| */ | ||
| *ptr = 0.0; | ||
| } | ||
| return result; | ||
| } | ||
| int | ||
| Tcl_ExprBoolean(interp, string, ptr) | ||
| Tcl_Interp *interp; /* Context in which to evaluate the | ||
| * expression. */ | ||
| char *string; /* Expression to evaluate. */ | ||
| int *ptr; /* Where to store 0/1 result. */ | ||
| { | ||
| register Tcl_Obj *exprPtr; | ||
| Tcl_Obj *resultPtr; | ||
| int length = strlen(string); | ||
| int result = TCL_OK; | ||
| if (length > 0) { | ||
| exprPtr = Tcl_NewStringObj(string, length); | ||
| Tcl_IncrRefCount(exprPtr); | ||
| result = Tcl_ExprObj(interp, exprPtr, &resultPtr); | ||
| if (result == TCL_OK) { | ||
| /* | ||
| * Store a boolean based on the expression result. | ||
| */ | ||
| if (resultPtr->typePtr == &tclIntType) { | ||
| *ptr = (resultPtr->internalRep.longValue != 0); | ||
| } else if (resultPtr->typePtr == &tclDoubleType) { | ||
| *ptr = (resultPtr->internalRep.doubleValue != 0.0); | ||
| } else { | ||
| result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); | ||
| } | ||
| Tcl_DecrRefCount(resultPtr); /* discard the result object */ | ||
| } | ||
| if (result != TCL_OK) { | ||
| /* | ||
| * Move the interpreter's object result to the string result, | ||
| * then reset the object result. | ||
| */ | ||
| Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), | ||
| TCL_VOLATILE); | ||
| } | ||
| Tcl_DecrRefCount(exprPtr); /* discard the expression object */ | ||
| } else { | ||
| /* | ||
| * An empty string. Just set the result boolean to 0 (false). | ||
| */ | ||
| *ptr = 0; | ||
| } | ||
| return result; | ||
| } | ||
| /* | ||
| *-------------------------------------------------------------- | ||
| * | ||
| * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj -- | ||
| * | ||
| * Procedures to evaluate an expression in an object and return its | ||
| * value in a particular form. | ||
| * | ||
| * Results: | ||
| * Each of the procedures below returns a standard Tcl result | ||
| * object. If an error occurs then an error message is left in the | ||
| * interpreter's result. Otherwise the value of the expression, in the | ||
| * appropriate form, is stored at *ptr. If the expression had a result | ||
| * that was incompatible with the desired form then an error is | ||
| * returned. | ||
| * | ||
| * Side effects: | ||
| * None. | ||
| * | ||
| *-------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_ExprLongObj(interp, objPtr, ptr) | ||
| Tcl_Interp *interp; /* Context in which to evaluate the | ||
| * expression. */ | ||
| register Tcl_Obj *objPtr; /* Expression to evaluate. */ | ||
| long *ptr; /* Where to store long result. */ | ||
| { | ||
| Tcl_Obj *resultPtr; | ||
| int result; | ||
| result = Tcl_ExprObj(interp, objPtr, &resultPtr); | ||
| if (result == TCL_OK) { | ||
| if (resultPtr->typePtr == &tclIntType) { | ||
| *ptr = resultPtr->internalRep.longValue; | ||
| } else if (resultPtr->typePtr == &tclDoubleType) { | ||
| *ptr = (long) resultPtr->internalRep.doubleValue; | ||
| } else { | ||
| result = Tcl_GetLongFromObj(interp, resultPtr, ptr); | ||
| if (result != TCL_OK) { | ||
| return result; | ||
| } | ||
| } | ||
| Tcl_DecrRefCount(resultPtr); /* discard the result object */ | ||
| } | ||
| return result; | ||
| } | ||
| int | ||
| Tcl_ExprDoubleObj(interp, objPtr, ptr) | ||
| Tcl_Interp *interp; /* Context in which to evaluate the | ||
| * expression. */ | ||
| register Tcl_Obj *objPtr; /* Expression to evaluate. */ | ||
| double *ptr; /* Where to store double result. */ | ||
| { | ||
| Tcl_Obj *resultPtr; | ||
| int result; | ||
| result = Tcl_ExprObj(interp, objPtr, &resultPtr); | ||
| if (result == TCL_OK) { | ||
| if (resultPtr->typePtr == &tclIntType) { | ||
| *ptr = (double) resultPtr->internalRep.longValue; | ||
| } else if (resultPtr->typePtr == &tclDoubleType) { | ||
| *ptr = resultPtr->internalRep.doubleValue; | ||
| } else { | ||
| result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr); | ||
| if (result != TCL_OK) { | ||
| return result; | ||
| } | ||
| } | ||
| Tcl_DecrRefCount(resultPtr); /* discard the result object */ | ||
| } | ||
| return result; | ||
| } | ||
| int | ||
| Tcl_ExprBooleanObj(interp, objPtr, ptr) | ||
| Tcl_Interp *interp; /* Context in which to evaluate the | ||
| * expression. */ | ||
| register Tcl_Obj *objPtr; /* Expression to evaluate. */ | ||
| int *ptr; /* Where to store 0/1 result. */ | ||
| { | ||
| Tcl_Obj *resultPtr; | ||
| int result; | ||
| result = Tcl_ExprObj(interp, objPtr, &resultPtr); | ||
| if (result == TCL_OK) { | ||
| if (resultPtr->typePtr == &tclIntType) { | ||
| *ptr = (resultPtr->internalRep.longValue != 0); | ||
| } else if (resultPtr->typePtr == &tclDoubleType) { | ||
| *ptr = (resultPtr->internalRep.doubleValue != 0.0); | ||
| } else { | ||
| result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); | ||
| } | ||
| Tcl_DecrRefCount(resultPtr); /* discard the result object */ | ||
| } | ||
| return result; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * TclInvoke -- | ||
| * | ||
| * Invokes a Tcl command, given an argv/argc, from either the | ||
| * exposed or the hidden sets of commands in the given interpreter. | ||
| * NOTE: The command is invoked in the current stack frame of | ||
| * the interpreter, thus it can modify local variables. | ||
| * | ||
| * Results: | ||
| * A standard Tcl result. | ||
| * | ||
| * Side effects: | ||
| * Whatever the command does. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| TclInvoke(interp, argc, argv, flags) | ||
| Tcl_Interp *interp; /* Where to invoke the command. */ | ||
| int argc; /* Count of args. */ | ||
| register char **argv; /* The arg strings; argv[0] is the name of | ||
| * the command to invoke. */ | ||
| int flags; /* Combination of flags controlling the | ||
| * call: TCL_INVOKE_HIDDEN and | ||
| * TCL_INVOKE_NO_UNKNOWN. */ | ||
| { | ||
| register Tcl_Obj *objPtr; | ||
| register int i; | ||
| int length, result; | ||
| /* | ||
| * This procedure generates an objv array for object arguments that hold | ||
| * the argv strings. It starts out with stack-allocated space but uses | ||
| * dynamically-allocated storage if needed. | ||
| */ | ||
| #define NUM_ARGS 20 | ||
| Tcl_Obj *(objStorage[NUM_ARGS]); | ||
| register Tcl_Obj **objv = objStorage; | ||
| /* | ||
| * Create the object argument array "objv". Make sure objv is large | ||
| * enough to hold the objc arguments plus 1 extra for the zero | ||
| * end-of-objv word. | ||
| */ | ||
| if ((argc + 1) > NUM_ARGS) { | ||
| objv = (Tcl_Obj **) | ||
| ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); | ||
| } | ||
| for (i = 0; i < argc; i++) { | ||
| length = strlen(argv[i]); | ||
| objv[i] = Tcl_NewStringObj(argv[i], length); | ||
| Tcl_IncrRefCount(objv[i]); | ||
| } | ||
| objv[argc] = 0; | ||
| /* | ||
| * Use TclObjInterpProc to actually invoke the command. | ||
| */ | ||
| result = TclObjInvoke(interp, argc, objv, flags); | ||
| /* | ||
| * Move the interpreter's object result to the string result, | ||
| * then reset the object result. | ||
| */ | ||
| Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), | ||
| TCL_VOLATILE); | ||
| /* | ||
| * Decrement the ref counts on the objv elements since we are done | ||
| * with them. | ||
| */ | ||
| for (i = 0; i < argc; i++) { | ||
| objPtr = objv[i]; | ||
| Tcl_DecrRefCount(objPtr); | ||
| } | ||
| /* | ||
| * Free the objv array if malloc'ed storage was used. | ||
| */ | ||
| if (objv != objStorage) { | ||
| ckfree((char *) objv); | ||
| } | ||
| return result; | ||
| #undef NUM_ARGS | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * TclGlobalInvoke -- | ||
| * | ||
| * Invokes a Tcl command, given an argv/argc, from either the | ||
| * exposed or hidden sets of commands in the given interpreter. | ||
| * NOTE: The command is invoked in the global stack frame of | ||
| * the interpreter, thus it cannot see any current state on | ||
| * the stack for that interpreter. | ||
| * | ||
| * Results: | ||
| * A standard Tcl result. | ||
| * | ||
| * Side effects: | ||
| * Whatever the command does. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| TclGlobalInvoke(interp, argc, argv, flags) | ||
| Tcl_Interp *interp; /* Where to invoke the command. */ | ||
| int argc; /* Count of args. */ | ||
| register char **argv; /* The arg strings; argv[0] is the name of | ||
| * the command to invoke. */ | ||
| int flags; /* Combination of flags controlling the | ||
| * call: TCL_INVOKE_HIDDEN and | ||
| * TCL_INVOKE_NO_UNKNOWN. */ | ||
| { | ||
| register Interp *iPtr = (Interp *) interp; | ||
| int result; | ||
| CallFrame *savedVarFramePtr; | ||
| savedVarFramePtr = iPtr->varFramePtr; | ||
| iPtr->varFramePtr = NULL; | ||
| result = TclInvoke(interp, argc, argv, flags); | ||
| iPtr->varFramePtr = savedVarFramePtr; | ||
| return result; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * TclObjInvokeGlobal -- | ||
| * | ||
| * Object version: Invokes a Tcl command, given an objv/objc, from | ||
| * either the exposed or hidden set of commands in the given | ||
| * interpreter. | ||
| * NOTE: The command is invoked in the global stack frame of the | ||
| * interpreter, thus it cannot see any current state on the | ||
| * stack of that interpreter. | ||
| * | ||
| * Results: | ||
| * A standard Tcl result. | ||
| * | ||
| * Side effects: | ||
| * Whatever the command does. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| TclObjInvokeGlobal(interp, objc, objv, flags) | ||
| Tcl_Interp *interp; /* Interpreter in which command is to be | ||
| * invoked. */ | ||
| int objc; /* Count of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the | ||
| * name of the command to invoke. */ | ||
| int flags; /* Combination of flags controlling the | ||
| * call: TCL_INVOKE_HIDDEN, | ||
| * TCL_INVOKE_NO_UNKNOWN, or | ||
| * TCL_INVOKE_NO_TRACEBACK. */ | ||
| { | ||
| register Interp *iPtr = (Interp *) interp; | ||
| int result; | ||
| CallFrame *savedVarFramePtr; | ||
| savedVarFramePtr = iPtr->varFramePtr; | ||
| iPtr->varFramePtr = NULL; | ||
| result = TclObjInvoke(interp, objc, objv, flags); | ||
| iPtr->varFramePtr = savedVarFramePtr; | ||
| return result; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * TclObjInvoke -- | ||
| * | ||
| * Invokes a Tcl command, given an objv/objc, from either the | ||
| * exposed or the hidden sets of commands in the given interpreter. | ||
| * | ||
| * Results: | ||
| * A standard Tcl object result. | ||
| * | ||
| * Side effects: | ||
| * Whatever the command does. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| TclObjInvoke(interp, objc, objv, flags) | ||
| Tcl_Interp *interp; /* Interpreter in which command is to be | ||
| * invoked. */ | ||
| int objc; /* Count of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the | ||
| * name of the command to invoke. */ | ||
| int flags; /* Combination of flags controlling the | ||
| * call: TCL_INVOKE_HIDDEN, | ||
| * TCL_INVOKE_NO_UNKNOWN, or | ||
| * TCL_INVOKE_NO_TRACEBACK. */ | ||
| { | ||
| register Interp *iPtr = (Interp *) interp; | ||
| Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ | ||
| char *cmdName; /* Name of the command from objv[0]. */ | ||
| register Tcl_HashEntry *hPtr; | ||
| Tcl_Command cmd; | ||
| Command *cmdPtr; | ||
| int localObjc; /* Used to invoke "unknown" if the */ | ||
| Tcl_Obj **localObjv = NULL; /* command is not found. */ | ||
| register int i; | ||
| int length, result; | ||
| char *bytes; | ||
| if (interp == (Tcl_Interp *) NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) { | ||
| Tcl_AppendToObj(Tcl_GetObjResult(interp), | ||
| "illegal argument vector", -1); | ||
| return TCL_ERROR; | ||
| } | ||
| cmdName = Tcl_GetString(objv[0]); | ||
| if (flags & TCL_INVOKE_HIDDEN) { | ||
| /* | ||
| * We never invoke "unknown" for hidden commands. | ||
| */ | ||
| hPtr = NULL; | ||
| hTblPtr = ((Interp *) interp)->hiddenCmdTablePtr; | ||
| if (hTblPtr != NULL) { | ||
| hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); | ||
| } | ||
| if (hPtr == NULL) { | ||
| Tcl_ResetResult(interp); | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | ||
| "invalid hidden command name \"", cmdName, "\"", | ||
| (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| cmdPtr = (Command *) Tcl_GetHashValue(hPtr); | ||
| } else { | ||
| cmdPtr = NULL; | ||
| cmd = Tcl_FindCommand(interp, cmdName, | ||
| (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); | ||
| if (cmd != (Tcl_Command) NULL) { | ||
| cmdPtr = (Command *) cmd; | ||
| } | ||
| if (cmdPtr == NULL) { | ||
| if (!(flags & TCL_INVOKE_NO_UNKNOWN)) { | ||
| cmd = Tcl_FindCommand(interp, "unknown", | ||
| (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); | ||
| if (cmd != (Tcl_Command) NULL) { | ||
| cmdPtr = (Command *) cmd; | ||
| } | ||
| if (cmdPtr != NULL) { | ||
| localObjc = (objc + 1); | ||
| localObjv = (Tcl_Obj **) | ||
| ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc)); | ||
| localObjv[0] = Tcl_NewStringObj("unknown", -1); | ||
| Tcl_IncrRefCount(localObjv[0]); | ||
| for (i = 0; i < objc; i++) { | ||
| localObjv[i+1] = objv[i]; | ||
| } | ||
| objc = localObjc; | ||
| objv = localObjv; | ||
| } | ||
| } | ||
| /* | ||
| * Check again if we found the command. If not, "unknown" is | ||
| * not present and we cannot help, or the caller said not to | ||
| * call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN). | ||
| */ | ||
| if (cmdPtr == NULL) { | ||
| Tcl_ResetResult(interp); | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | ||
| "invalid command name \"", cmdName, "\"", | ||
| (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| } | ||
| } | ||
| /* | ||
| * Invoke the command procedure. First reset the interpreter's string | ||
| * and object results to their default empty values since they could | ||
| * have gotten changed by earlier invocations. | ||
| */ | ||
| Tcl_ResetResult(interp); | ||
| iPtr->cmdCount++; | ||
| result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); | ||
| /* | ||
| * If an error occurred, record information about what was being | ||
| * executed when the error occurred. | ||
| */ | ||
| if ((result == TCL_ERROR) | ||
| && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) | ||
| && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { | ||
| Tcl_DString ds; | ||
| Tcl_DStringInit(&ds); | ||
| if (!(iPtr->flags & ERR_IN_PROGRESS)) { | ||
| Tcl_DStringAppend(&ds, "\n while invoking\n\"", -1); | ||
| } else { | ||
| Tcl_DStringAppend(&ds, "\n invoked from within\n\"", -1); | ||
| } | ||
| for (i = 0; i < objc; i++) { | ||
| bytes = Tcl_GetStringFromObj(objv[i], &length); | ||
| Tcl_DStringAppend(&ds, bytes, length); | ||
| if (i < (objc - 1)) { | ||
| Tcl_DStringAppend(&ds, " ", -1); | ||
| } else if (Tcl_DStringLength(&ds) > 100) { | ||
| Tcl_DStringSetLength(&ds, 100); | ||
| Tcl_DStringAppend(&ds, "...", -1); | ||
| break; | ||
| } | ||
| } | ||
| Tcl_DStringAppend(&ds, "\"", -1); | ||
| Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&ds), -1); | ||
| Tcl_DStringFree(&ds); | ||
| iPtr->flags &= ~ERR_ALREADY_LOGGED; | ||
| } | ||
| /* | ||
| * Free any locally allocated storage used to call "unknown". | ||
| */ | ||
| if (localObjv != (Tcl_Obj **) NULL) { | ||
| Tcl_DecrRefCount(localObjv[0]); | ||
| ckfree((char *) localObjv); | ||
| } | ||
| return result; | ||
| } | ||
| /* | ||
| *--------------------------------------------------------------------------- | ||
| * | ||
| * Tcl_ExprString -- | ||
| * | ||
| * Evaluate an expression in a string and return its value in string | ||
| * form. | ||
| * | ||
| * Results: | ||
| * A standard Tcl result. If the result is TCL_OK, then the interp's | ||
| * result is set to the string value of the expression. If the result | ||
| * is TCL_ERROR, then the interp's result contains an error message. | ||
| * | ||
| * Side effects: | ||
| * A Tcl object is allocated to hold a copy of the expression string. | ||
| * This expression object is passed to Tcl_ExprObj and then | ||
| * deallocated. | ||
| * | ||
| *--------------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_ExprString(interp, string) | ||
| Tcl_Interp *interp; /* Context in which to evaluate the | ||
| * expression. */ | ||
| char *string; /* Expression to evaluate. */ | ||
| { | ||
| register Tcl_Obj *exprPtr; | ||
| Tcl_Obj *resultPtr; | ||
| int length = strlen(string); | ||
| char buf[TCL_DOUBLE_SPACE]; | ||
| int result = TCL_OK; | ||
| if (length > 0) { | ||
| TclNewObj(exprPtr); | ||
| TclInitStringRep(exprPtr, string, length); | ||
| Tcl_IncrRefCount(exprPtr); | ||
| result = Tcl_ExprObj(interp, exprPtr, &resultPtr); | ||
| if (result == TCL_OK) { | ||
| /* | ||
| * Set the interpreter's string result from the result object. | ||
| */ | ||
| if (resultPtr->typePtr == &tclIntType) { | ||
| sprintf(buf, "%ld", resultPtr->internalRep.longValue); | ||
| Tcl_SetResult(interp, buf, TCL_VOLATILE); | ||
| } else if (resultPtr->typePtr == &tclDoubleType) { | ||
| Tcl_PrintDouble((Tcl_Interp *) NULL, | ||
| resultPtr->internalRep.doubleValue, buf); | ||
| Tcl_SetResult(interp, buf, TCL_VOLATILE); | ||
| } else { | ||
| /* | ||
| * Set interpreter's string result from the result object. | ||
| */ | ||
| Tcl_SetResult(interp, TclGetString(resultPtr), | ||
| TCL_VOLATILE); | ||
| } | ||
| Tcl_DecrRefCount(resultPtr); /* discard the result object */ | ||
| } else { | ||
| /* | ||
| * Move the interpreter's object result to the string result, | ||
| * then reset the object result. | ||
| */ | ||
| Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), | ||
| TCL_VOLATILE); | ||
| } | ||
| Tcl_DecrRefCount(exprPtr); /* discard the expression object */ | ||
| } else { | ||
| /* | ||
| * An empty string. Just set the interpreter's result to 0. | ||
| */ | ||
| Tcl_SetResult(interp, "0", TCL_VOLATILE); | ||
| } | ||
| return result; | ||
| } | ||
| /* | ||
| *-------------------------------------------------------------- | ||
| * | ||
| * Tcl_ExprObj -- | ||
| * | ||
| * Evaluate an expression in a Tcl_Obj. | ||
| * | ||
| * Results: | ||
| * A standard Tcl object result. If the result is other than TCL_OK, | ||
| * then the interpreter's result contains an error message. If the | ||
| * result is TCL_OK, then a pointer to the expression's result value | ||
| * object is stored in resultPtrPtr. In that case, the object's ref | ||
| * count is incremented to reflect the reference returned to the | ||
| * caller; the caller is then responsible for the resulting object | ||
| * and must, for example, decrement the ref count when it is finished | ||
| * with the object. | ||
| * | ||
| * Side effects: | ||
| * Any side effects caused by subcommands in the expression, if any. | ||
| * The interpreter result is not modified unless there is an error. | ||
| * | ||
| *-------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_ExprObj(interp, objPtr, resultPtrPtr) | ||
| Tcl_Interp *interp; /* Context in which to evaluate the | ||
| * expression. */ | ||
| register Tcl_Obj *objPtr; /* Points to Tcl object containing | ||
| * expression to evaluate. */ | ||
| Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression | ||
| * result is stored if no errors occur. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| CompileEnv compEnv; /* Compilation environment structure | ||
| * allocated in frame. */ | ||
| LiteralTable *localTablePtr = &(compEnv.localLitTable); | ||
| register ByteCode *codePtr = NULL; | ||
| /* Tcl Internal type of bytecode. | ||
| * Initialized to avoid compiler warning. */ | ||
| AuxData *auxDataPtr; | ||
| LiteralEntry *entryPtr; | ||
| Tcl_Obj *saveObjPtr; | ||
| char *string; | ||
| int length, i, result; | ||
| /* | ||
| * First handle some common expressions specially. | ||
| */ | ||
| string = Tcl_GetStringFromObj(objPtr, &length); | ||
| if (length == 1) { | ||
| if (*string == '0') { | ||
| *resultPtrPtr = Tcl_NewLongObj(0); | ||
| Tcl_IncrRefCount(*resultPtrPtr); | ||
| return TCL_OK; | ||
| } else if (*string == '1') { | ||
| *resultPtrPtr = Tcl_NewLongObj(1); | ||
| Tcl_IncrRefCount(*resultPtrPtr); | ||
| return TCL_OK; | ||
| } | ||
| } else if ((length == 2) && (*string == '!')) { | ||
| if (*(string+1) == '0') { | ||
| *resultPtrPtr = Tcl_NewLongObj(1); | ||
| Tcl_IncrRefCount(*resultPtrPtr); | ||
| return TCL_OK; | ||
| } else if (*(string+1) == '1') { | ||
| *resultPtrPtr = Tcl_NewLongObj(0); | ||
| Tcl_IncrRefCount(*resultPtrPtr); | ||
| return TCL_OK; | ||
| } | ||
| } | ||
| /* | ||
| * Get the ByteCode from the object. If it exists, make sure it hasn't | ||
| * been invalidated by, e.g., someone redefining a command with a | ||
| * compile procedure (this might make the compiled code wrong). If | ||
| * necessary, convert the object to be a ByteCode object and compile it. | ||
| * Also, if the code was compiled in/for a different interpreter, we | ||
| * recompile it. | ||
| * | ||
| * Precompiled expressions, however, are immutable and therefore | ||
| * they are not recompiled, even if the epoch has changed. | ||
| * | ||
| */ | ||
| if (objPtr->typePtr == &tclByteCodeType) { | ||
| codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; | ||
| if (((Interp *) *codePtr->interpHandle != iPtr) | ||
| || (codePtr->compileEpoch != iPtr->compileEpoch)) { | ||
| if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { | ||
| if ((Interp *) *codePtr->interpHandle != iPtr) { | ||
| panic("Tcl_ExprObj: compiled expression jumped interps"); | ||
| } | ||
| codePtr->compileEpoch = iPtr->compileEpoch; | ||
| } else { | ||
| (*tclByteCodeType.freeIntRepProc)(objPtr); | ||
| objPtr->typePtr = (Tcl_ObjType *) NULL; | ||
| } | ||
| } | ||
| } | ||
| if (objPtr->typePtr != &tclByteCodeType) { | ||
| TclInitCompileEnv(interp, &compEnv, string, length); | ||
| result = TclCompileExpr(interp, string, length, &compEnv); | ||
| /* | ||
| * Free the compilation environment's literal table bucket array if | ||
| * it was dynamically allocated. | ||
| */ | ||
| if (localTablePtr->buckets != localTablePtr->staticBuckets) { | ||
| ckfree((char *) localTablePtr->buckets); | ||
| } | ||
| if (result != TCL_OK) { | ||
| /* | ||
| * Compilation errors. Free storage allocated for compilation. | ||
| */ | ||
| #ifdef TCL_COMPILE_DEBUG | ||
| TclVerifyLocalLiteralTable(&compEnv); | ||
| #endif /*TCL_COMPILE_DEBUG*/ | ||
| entryPtr = compEnv.literalArrayPtr; | ||
| for (i = 0; i < compEnv.literalArrayNext; i++) { | ||
| TclReleaseLiteral(interp, entryPtr->objPtr); | ||
| entryPtr++; | ||
| } | ||
| #ifdef TCL_COMPILE_DEBUG | ||
| TclVerifyGlobalLiteralTable(iPtr); | ||
| #endif /*TCL_COMPILE_DEBUG*/ | ||
| auxDataPtr = compEnv.auxDataArrayPtr; | ||
| for (i = 0; i < compEnv.auxDataArrayNext; i++) { | ||
| if (auxDataPtr->type->freeProc != NULL) { | ||
| auxDataPtr->type->freeProc(auxDataPtr->clientData); | ||
| } | ||
| auxDataPtr++; | ||
| } | ||
| TclFreeCompileEnv(&compEnv); | ||
| return result; | ||
| } | ||
| /* | ||
| * Successful compilation. If the expression yielded no | ||
| * instructions, push an zero object as the expression's result. | ||
| */ | ||
| if (compEnv.codeNext == compEnv.codeStart) { | ||
| TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0), | ||
| &compEnv); | ||
| } | ||
| /* | ||
| * Add a "done" instruction as the last instruction and change the | ||
| * object into a ByteCode object. Ownership of the literal objects | ||
| * and aux data items is given to the ByteCode object. | ||
| */ | ||
| compEnv.numSrcBytes = iPtr->termOffset; | ||
| TclEmitOpcode(INST_DONE, &compEnv); | ||
| TclInitByteCodeObj(objPtr, &compEnv); | ||
| TclFreeCompileEnv(&compEnv); | ||
| codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; | ||
| #ifdef TCL_COMPILE_DEBUG | ||
| if (tclTraceCompile == 2) { | ||
| TclPrintByteCodeObj(interp, objPtr); | ||
| } | ||
| #endif /* TCL_COMPILE_DEBUG */ | ||
| } | ||
| /* | ||
| * Execute the expression after first saving the interpreter's result. | ||
| */ | ||
| saveObjPtr = Tcl_GetObjResult(interp); | ||
| Tcl_IncrRefCount(saveObjPtr); | ||
| Tcl_ResetResult(interp); | ||
| /* | ||
| * Increment the code's ref count while it is being executed. If | ||
| * afterwards no references to it remain, free the code. | ||
| */ | ||
| codePtr->refCount++; | ||
| result = TclExecuteByteCode(interp, codePtr); | ||
| codePtr->refCount--; | ||
| if (codePtr->refCount <= 0) { | ||
| TclCleanupByteCode(codePtr); | ||
| objPtr->typePtr = NULL; | ||
| objPtr->internalRep.otherValuePtr = NULL; | ||
| } | ||
| /* | ||
| * If the expression evaluated successfully, store a pointer to its | ||
| * value object in resultPtrPtr then restore the old interpreter result. | ||
| * We increment the object's ref count to reflect the reference that we | ||
| * are returning to the caller. We also decrement the ref count of the | ||
| * interpreter's result object after calling Tcl_SetResult since we | ||
| * next store into that field directly. | ||
| */ | ||
| if (result == TCL_OK) { | ||
| *resultPtrPtr = iPtr->objResultPtr; | ||
| Tcl_IncrRefCount(iPtr->objResultPtr); | ||
| Tcl_SetObjResult(interp, saveObjPtr); | ||
| } | ||
| Tcl_DecrRefCount(saveObjPtr); | ||
| return result; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_CreateTrace -- | ||
| * | ||
| * Arrange for a procedure to be called to trace command execution. | ||
| * | ||
| * Results: | ||
| * The return value is a token for the trace, which may be passed | ||
| * to Tcl_DeleteTrace to eliminate the trace. | ||
| * | ||
| * Side effects: | ||
| * From now on, proc will be called just before a command procedure | ||
| * is called to execute a Tcl command. Calls to proc will have the | ||
| * following form: | ||
| * | ||
| * void | ||
| * proc(clientData, interp, level, command, cmdProc, cmdClientData, | ||
| * argc, argv) | ||
| * ClientData clientData; | ||
| * Tcl_Interp *interp; | ||
| * int level; | ||
| * char *command; | ||
| * int (*cmdProc)(); | ||
| * ClientData cmdClientData; | ||
| * int argc; | ||
| * char **argv; | ||
| * { | ||
| * } | ||
| * | ||
| * The clientData and interp arguments to proc will be the same | ||
| * as the corresponding arguments to this procedure. Level gives | ||
| * the nesting level of command interpretation for this interpreter | ||
| * (0 corresponds to top level). Command gives the ASCII text of | ||
| * the raw command, cmdProc and cmdClientData give the procedure that | ||
| * will be called to process the command and the ClientData value it | ||
| * will receive, and argc and argv give the arguments to the | ||
| * command, after any argument parsing and substitution. Proc | ||
| * does not return a value. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| Tcl_Trace | ||
| Tcl_CreateTrace(interp, level, proc, clientData) | ||
| Tcl_Interp *interp; /* Interpreter in which to create trace. */ | ||
| int level; /* Only call proc for commands at nesting | ||
| * level<=argument level (1=>top level). */ | ||
| Tcl_CmdTraceProc *proc; /* Procedure to call before executing each | ||
| * command. */ | ||
| ClientData clientData; /* Arbitrary value word to pass to proc. */ | ||
| { | ||
| register Trace *tracePtr; | ||
| register Interp *iPtr = (Interp *) interp; | ||
| /* | ||
| * Invalidate existing compiled code for this interpreter and arrange | ||
| * (by setting the DONT_COMPILE_CMDS_INLINE flag) that when compiling | ||
| * new code, no commands will be compiled inline (i.e., into an inline | ||
| * sequence of instructions). We do this because commands that were | ||
| * compiled inline will never result in a command trace being called. | ||
| */ | ||
| iPtr->compileEpoch++; | ||
| iPtr->flags |= DONT_COMPILE_CMDS_INLINE; | ||
| tracePtr = (Trace *) ckalloc(sizeof(Trace)); | ||
| tracePtr->level = level; | ||
| tracePtr->proc = proc; | ||
| tracePtr->clientData = clientData; | ||
| tracePtr->nextPtr = iPtr->tracePtr; | ||
| iPtr->tracePtr = tracePtr; | ||
| return (Tcl_Trace) tracePtr; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_DeleteTrace -- | ||
| * | ||
| * Remove a trace. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * From now on there will be no more calls to the procedure given | ||
| * in trace. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| void | ||
| Tcl_DeleteTrace(interp, trace) | ||
| Tcl_Interp *interp; /* Interpreter that contains trace. */ | ||
| Tcl_Trace trace; /* Token for trace (returned previously by | ||
| * Tcl_CreateTrace). */ | ||
| { | ||
| register Interp *iPtr = (Interp *) interp; | ||
| register Trace *tracePtr = (Trace *) trace; | ||
| register Trace *tracePtr2; | ||
| if (iPtr->tracePtr == tracePtr) { | ||
| iPtr->tracePtr = tracePtr->nextPtr; | ||
| ckfree((char *) tracePtr); | ||
| } else { | ||
| for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL; | ||
| tracePtr2 = tracePtr2->nextPtr) { | ||
| if (tracePtr2->nextPtr == tracePtr) { | ||
| tracePtr2->nextPtr = tracePtr->nextPtr; | ||
| ckfree((char *) tracePtr); | ||
| break; | ||
| } | ||
| } | ||
| } | ||
| if (iPtr->tracePtr == NULL) { | ||
| /* | ||
| * When compiling new code, allow commands to be compiled inline. | ||
| */ | ||
| iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; | ||
| } | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_AddErrorInfo -- | ||
| * | ||
| * Add information to the "errorInfo" variable that describes the | ||
| * current error. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * The contents of message are added to the "errorInfo" variable. | ||
| * If Tcl_Eval has been called since the current value of errorInfo | ||
| * was set, errorInfo is cleared before adding the new message. | ||
| * If we are just starting to log an error, errorInfo is initialized | ||
| * from the error message in the interpreter's result. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| void | ||
| Tcl_AddErrorInfo(interp, message) | ||
| Tcl_Interp *interp; /* Interpreter to which error information | ||
| * pertains. */ | ||
| CONST char *message; /* Message to record. */ | ||
| { | ||
| Tcl_AddObjErrorInfo(interp, message, -1); | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_AddObjErrorInfo -- | ||
| * | ||
| * Add information to the "errorInfo" variable that describes the | ||
| * current error. This routine differs from Tcl_AddErrorInfo by | ||
| * taking a byte pointer and length. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * "length" bytes from "message" are added to the "errorInfo" variable. | ||
| * If "length" is negative, use bytes up to the first NULL byte. | ||
| * If Tcl_EvalObj has been called since the current value of errorInfo | ||
| * was set, errorInfo is cleared before adding the new message. | ||
| * If we are just starting to log an error, errorInfo is initialized | ||
| * from the error message in the interpreter's result. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| void | ||
| Tcl_AddObjErrorInfo(interp, message, length) | ||
| Tcl_Interp *interp; /* Interpreter to which error information | ||
| * pertains. */ | ||
| CONST char *message; /* Points to the first byte of an array of | ||
| * bytes of the message. */ | ||
| int length; /* The number of bytes in the message. | ||
| * If < 0, then append all bytes up to a | ||
| * NULL byte. */ | ||
| { | ||
| register Interp *iPtr = (Interp *) interp; | ||
| Tcl_Obj *messagePtr; | ||
| /* | ||
| * If we are just starting to log an error, errorInfo is initialized | ||
| * from the error message in the interpreter's result. | ||
| */ | ||
| if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */ | ||
| iPtr->flags |= ERR_IN_PROGRESS; | ||
| if (iPtr->result[0] == 0) { | ||
| (void) Tcl_SetVar2Ex(interp, "errorInfo", NULL, iPtr->objResultPtr, | ||
| TCL_GLOBAL_ONLY); | ||
| } else { /* use the string result */ | ||
| Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result, | ||
| TCL_GLOBAL_ONLY); | ||
| } | ||
| /* | ||
| * If the errorCode variable wasn't set by the code that generated | ||
| * the error, set it to "NONE". | ||
| */ | ||
| if (!(iPtr->flags & ERROR_CODE_SET)) { | ||
| (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE", | ||
| TCL_GLOBAL_ONLY); | ||
| } | ||
| } | ||
| /* | ||
| * Now append "message" to the end of errorInfo. | ||
| */ | ||
| if (length != 0) { | ||
| messagePtr = Tcl_NewStringObj(message, length); | ||
| Tcl_IncrRefCount(messagePtr); | ||
| Tcl_SetVar2Ex(interp, "errorInfo", NULL, messagePtr, | ||
| (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); | ||
| Tcl_DecrRefCount(messagePtr); /* free msg object appended above */ | ||
| } | ||
| } | ||
| /* | ||
| *--------------------------------------------------------------------------- | ||
| * | ||
| * Tcl_VarEvalVA -- | ||
| * | ||
| * Given a variable number of string arguments, concatenate them | ||
| * all together and execute the result as a Tcl command. | ||
| * | ||
| * Results: | ||
| * A standard Tcl return result. An error message or other result may | ||
| * be left in the interp's result. | ||
| * | ||
| * Side effects: | ||
| * Depends on what was done by the command. | ||
| * | ||
| *--------------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_VarEvalVA (interp, argList) | ||
| Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ | ||
| va_list argList; /* Variable argument list. */ | ||
| { | ||
| Tcl_DString buf; | ||
| char *string; | ||
| int result; | ||
| /* | ||
| * Copy the strings one after the other into a single larger | ||
| * string. Use stack-allocated space for small commands, but if | ||
| * the command gets too large than call ckalloc to create the | ||
| * space. | ||
| */ | ||
| Tcl_DStringInit(&buf); | ||
| while (1) { | ||
| string = va_arg(argList, char *); | ||
| if (string == NULL) { | ||
| break; | ||
| } | ||
| Tcl_DStringAppend(&buf, string, -1); | ||
| } | ||
| result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); | ||
| Tcl_DStringFree(&buf); | ||
| return result; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_VarEval -- | ||
| * | ||
| * Given a variable number of string arguments, concatenate them | ||
| * all together and execute the result as a Tcl command. | ||
| * | ||
| * Results: | ||
| * A standard Tcl return result. An error message or other | ||
| * result may be left in interp->result. | ||
| * | ||
| * Side effects: | ||
| * Depends on what was done by the command. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* VARARGS2 */ /* ARGSUSED */ | ||
| int | ||
| Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) | ||
| { | ||
| Tcl_Interp *interp; | ||
| va_list argList; | ||
| int result; | ||
| interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); | ||
| result = Tcl_VarEvalVA(interp, argList); | ||
| va_end(argList); | ||
| return result; | ||
| } | ||
| /* | ||
| *--------------------------------------------------------------------------- | ||
| * | ||
| * Tcl_GlobalEval -- | ||
| * | ||
| * Evaluate a command at global level in an interpreter. | ||
| * | ||
| * Results: | ||
| * A standard Tcl result is returned, and the interp's result is | ||
| * modified accordingly. | ||
| * | ||
| * Side effects: | ||
| * The command string is executed in interp, and the execution | ||
| * is carried out in the variable context of global level (no | ||
| * procedures active), just as if an "uplevel #0" command were | ||
| * being executed. | ||
| * | ||
| --------------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_GlobalEval(interp, command) | ||
| Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ | ||
| char *command; /* Command to evaluate. */ | ||
| { | ||
| register Interp *iPtr = (Interp *) interp; | ||
| int result; | ||
| CallFrame *savedVarFramePtr; | ||
| savedVarFramePtr = iPtr->varFramePtr; | ||
| iPtr->varFramePtr = NULL; | ||
| result = Tcl_Eval(interp, command); | ||
| iPtr->varFramePtr = savedVarFramePtr; | ||
| return result; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_SetRecursionLimit -- | ||
| * | ||
| * Set the maximum number of recursive calls that may be active | ||
| * for an interpreter at once. | ||
| * | ||
| * Results: | ||
| * The return value is the old limit on nesting for interp. | ||
| * | ||
| * Side effects: | ||
| * None. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_SetRecursionLimit(interp, depth) | ||
| Tcl_Interp *interp; /* Interpreter whose nesting limit | ||
| * is to be set. */ | ||
| int depth; /* New value for maximimum depth. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| int old; | ||
| old = iPtr->maxNestingDepth; | ||
| if (depth > 0) { | ||
| iPtr->maxNestingDepth = depth; | ||
| } | ||
| return old; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_AllowExceptions -- | ||
| * | ||
| * Sets a flag in an interpreter so that exceptions can occur | ||
| * in the next call to Tcl_Eval without them being turned into | ||
| * errors. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's | ||
| * evalFlags structure. See the reference documentation for | ||
| * more details. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| void | ||
| Tcl_AllowExceptions(interp) | ||
| Tcl_Interp *interp; /* Interpreter in which to set flag. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_GetVersion | ||
| * | ||
| * Get the Tcl major, minor, and patchlevel version numbers and | ||
| * the release type. A patch is a release type TCL_FINAL_RELEASE | ||
| * with a patchLevel > 0. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * None. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| void Tcl_GetVersion(majorV, minorV, patchLevelV, type) | ||
| int *majorV; | ||
| int *minorV; | ||
| int *patchLevelV; | ||
| int *type; | ||
| { | ||
| if (majorV != NULL) { | ||
| *majorV = TCL_MAJOR_VERSION; | ||
| } | ||
| if (minorV != NULL) { | ||
| *minorV = TCL_MINOR_VERSION; | ||
| } | ||
| if (patchLevelV != NULL) { | ||
| *patchLevelV = TCL_RELEASE_SERIAL; | ||
| } | ||
| if (type != NULL) { | ||
| *type = TCL_RELEASE_LEVEL; | ||
| } | ||
| } | ||
| /* $History: tclbasic.c $ | ||
| * | ||
| * ***************** Version 1 ***************** | ||
| * User: Dtashley Date: 1/02/01 Time: 1:34a | ||
| * Created in $/IjuScripter, IjuConsole/Source/Tcl Base | ||
| * Initial check-in. | ||
| */ | ||
| /* End of TCLBASIC.C */ | ||
| 1 | /* $Header$ */ | |
| 2 | /* | |
| 3 | * tclBasic.c -- | |
| 4 | * | |
| 5 | * Contains the basic facilities for TCL command interpretation, | |
| 6 | * including interpreter creation and deletion, command creation | |
| 7 | * and deletion, and command parsing and execution. | |
| 8 | * | |
| 9 | * Copyright (c) 1987-1994 The Regents of the University of California. | |
| 10 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. | |
| 11 | * Copyright (c) 1998-1999 by Scriptics Corporation. | |
| 12 | * | |
| 13 | * See the file "license.terms" for information on usage and redistribution | |
| 14 | * of this file, and for a DISCLAIMER OF ALL WARRANTIES. | |
| 15 | * | |
| 16 | * RCS: @(#) $Id: tclbasic.c,v 1.1.1.1 2001/06/13 04:33:43 dtashley Exp $ | |
| 17 | */ | |
| 18 | ||
| 19 | #include "tclInt.h" | |
| 20 | #include "tclCompile.h" | |
| 21 | #ifndef TCL_GENERIC_ONLY | |
| 22 | # include "tclPort.h" | |
| 23 | #endif | |
| 24 | ||
| 25 | /* | |
| 26 | * Static procedures in this file: | |
| 27 | */ | |
| 28 | ||
| 29 | static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); | |
| 30 | static void ProcessUnexpectedResult _ANSI_ARGS_(( | |
| 31 | Tcl_Interp *interp, int returnCode)); | |
| 32 | static void RecordTracebackInfo _ANSI_ARGS_(( | |
| 33 | Tcl_Interp *interp, Tcl_Obj *objPtr, | |
| 34 | int numSrcBytes)); | |
| 35 | ||
| 36 | extern TclStubs tclStubs; | |
| 37 | ||
| 38 | /* | |
| 39 | * The following structure defines the commands in the Tcl core. | |
| 40 | */ | |
| 41 | ||
| 42 | typedef struct { | |
| 43 | char *name; /* Name of object-based command. */ | |
| 44 | Tcl_CmdProc *proc; /* String-based procedure for command. */ | |
| 45 | Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */ | |
| 46 | CompileProc *compileProc; /* Procedure called to compile command. */ | |
| 47 | int isSafe; /* If non-zero, command will be present | |
| 48 | * in safe interpreter. Otherwise it will | |
| 49 | * be hidden. */ | |
| 50 | } CmdInfo; | |
| 51 | ||
| 52 | /* | |
| 53 | * The built-in commands, and the procedures that implement them: | |
| 54 | */ | |
| 55 | ||
| 56 | static CmdInfo builtInCmds[] = { | |
| 57 | /* | |
| 58 | * Commands in the generic core. Note that at least one of the proc or | |
| 59 | * objProc members should be non-NULL. This avoids infinitely recursive | |
| 60 | * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a | |
| 61 | * command name is computed at runtime and results in the name of a | |
| 62 | * compiled command. | |
| 63 | */ | |
| 64 | ||
| 65 | {"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd, | |
| 66 | (CompileProc *) NULL, 1}, | |
| 67 | {"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd, | |
| 68 | (CompileProc *) NULL, 1}, | |
| 69 | {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd, | |
| 70 | (CompileProc *) NULL, 1}, | |
| 71 | {"break", (Tcl_CmdProc *) NULL, Tcl_BreakObjCmd, | |
| 72 | TclCompileBreakCmd, 1}, | |
| 73 | {"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd, | |
| 74 | (CompileProc *) NULL, 1}, | |
| 75 | {"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd, | |
| 76 | TclCompileCatchCmd, 1}, | |
| 77 | {"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd, | |
| 78 | (CompileProc *) NULL, 1}, | |
| 79 | {"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd, | |
| 80 | (CompileProc *) NULL, 1}, | |
| 81 | {"continue", (Tcl_CmdProc *) NULL, Tcl_ContinueObjCmd, | |
| 82 | TclCompileContinueCmd, 1}, | |
| 83 | {"encoding", (Tcl_CmdProc *) NULL, Tcl_EncodingObjCmd, | |
| 84 | (CompileProc *) NULL, 0}, | |
| 85 | {"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd, | |
| 86 | (CompileProc *) NULL, 1}, | |
| 87 | {"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd, | |
| 88 | (CompileProc *) NULL, 1}, | |
| 89 | {"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd, | |
| 90 | (CompileProc *) NULL, 0}, | |
| 91 | {"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd, | |
| 92 | TclCompileExprCmd, 1}, | |
| 93 | {"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd, | |
| 94 | (CompileProc *) NULL, 1}, | |
| 95 | {"fileevent", (Tcl_CmdProc *) NULL, Tcl_FileEventObjCmd, | |
| 96 | (CompileProc *) NULL, 1}, | |
| 97 | {"for", (Tcl_CmdProc *) NULL, Tcl_ForObjCmd, | |
| 98 | TclCompileForCmd, 1}, | |
| 99 | {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd, | |
| 100 | TclCompileForeachCmd, 1}, | |
| 101 | {"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd, | |
| 102 | (CompileProc *) NULL, 1}, | |
| 103 | {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd, | |
| 104 | (CompileProc *) NULL, 1}, | |
| 105 | {"if", (Tcl_CmdProc *) NULL, Tcl_IfObjCmd, | |
| 106 | TclCompileIfCmd, 1}, | |
| 107 | {"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd, | |
| 108 | TclCompileIncrCmd, 1}, | |
| 109 | {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd, | |
| 110 | (CompileProc *) NULL, 1}, | |
| 111 | {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd, | |
| 112 | (CompileProc *) NULL, 1}, | |
| 113 | {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd, | |
| 114 | (CompileProc *) NULL, 1}, | |
| 115 | {"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd, | |
| 116 | (CompileProc *) NULL, 1}, | |
| 117 | {"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd, | |
| 118 | (CompileProc *) NULL, 1}, | |
| 119 | {"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd, | |
| 120 | (CompileProc *) NULL, 1}, | |
| 121 | {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd, | |
| 122 | (CompileProc *) NULL, 1}, | |
| 123 | {"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd, | |
| 124 | (CompileProc *) NULL, 0}, | |
| 125 | {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd, | |
| 126 | (CompileProc *) NULL, 1}, | |
| 127 | {"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd, | |
| 128 | (CompileProc *) NULL, 1}, | |
| 129 | {"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd, | |
| 130 | (CompileProc *) NULL, 1}, | |
| 131 | {"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd, | |
| 132 | (CompileProc *) NULL, 1}, | |
| 133 | {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd, | |
| 134 | (CompileProc *) NULL, 1}, | |
| 135 | {"package", (Tcl_CmdProc *) NULL, Tcl_PackageObjCmd, | |
| 136 | (CompileProc *) NULL, 1}, | |
| 137 | {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd, | |
| 138 | (CompileProc *) NULL, 1}, | |
| 139 | {"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd, | |
| 140 | (CompileProc *) NULL, 1}, | |
| 141 | {"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd, | |
| 142 | (CompileProc *) NULL, 1}, | |
| 143 | {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd, | |
| 144 | (CompileProc *) NULL, 1}, | |
| 145 | {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd, | |
| 146 | (CompileProc *) NULL, 1}, | |
| 147 | {"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd, | |
| 148 | (CompileProc *) NULL, 1}, | |
| 149 | {"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd, | |
| 150 | TclCompileSetCmd, 1}, | |
| 151 | {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd, | |
| 152 | (CompileProc *) NULL, 1}, | |
| 153 | {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd, | |
| 154 | (CompileProc *) NULL, 1}, | |
| 155 | {"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd, | |
| 156 | (CompileProc *) NULL, 1}, | |
| 157 | {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd, | |
| 158 | (CompileProc *) NULL, 1}, | |
| 159 | {"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd, | |
| 160 | (CompileProc *) NULL, 1}, | |
| 161 | {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd, | |
| 162 | (CompileProc *) NULL, 1}, | |
| 163 | {"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd, | |
| 164 | (CompileProc *) NULL, 1}, | |
| 165 | {"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd, | |
| 166 | (CompileProc *) NULL, 1}, | |
| 167 | {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd, | |
| 168 | (CompileProc *) NULL, 1}, | |
| 169 | {"while", (Tcl_CmdProc *) NULL, Tcl_WhileObjCmd, | |
| 170 | TclCompileWhileCmd, 1}, | |
| 171 | ||
| 172 | /* | |
| 173 | * Commands in the UNIX core: | |
| 174 | */ | |
| 175 | ||
| 176 | #ifndef TCL_GENERIC_ONLY | |
| 177 | {"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd, | |
| 178 | (CompileProc *) NULL, 1}, | |
| 179 | {"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd, | |
| 180 | (CompileProc *) NULL, 0}, | |
| 181 | {"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd, | |
| 182 | (CompileProc *) NULL, 1}, | |
| 183 | {"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd, | |
| 184 | (CompileProc *) NULL, 1}, | |
| 185 | {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd, | |
| 186 | (CompileProc *) NULL, 1}, | |
| 187 | {"fconfigure", (Tcl_CmdProc *) NULL, Tcl_FconfigureObjCmd, | |
| 188 | (CompileProc *) NULL, 0}, | |
| 189 | {"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd, | |
| 190 | (CompileProc *) NULL, 0}, | |
| 191 | {"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd, | |
| 192 | (CompileProc *) NULL, 1}, | |
| 193 | {"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd, | |
| 194 | (CompileProc *) NULL, 1}, | |
| 195 | {"glob", (Tcl_CmdProc *) NULL, Tcl_GlobObjCmd, | |
| 196 | (CompileProc *) NULL, 0}, | |
| 197 | {"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd, | |
| 198 | (CompileProc *) NULL, 0}, | |
| 199 | {"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd, | |
| 200 | (CompileProc *) NULL, 1}, | |
| 201 | {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd, | |
| 202 | (CompileProc *) NULL, 1}, | |
| 203 | {"pwd", (Tcl_CmdProc *) NULL, Tcl_PwdObjCmd, | |
| 204 | (CompileProc *) NULL, 0}, | |
| 205 | {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd, | |
| 206 | (CompileProc *) NULL, 1}, | |
| 207 | {"seek", (Tcl_CmdProc *) NULL, Tcl_SeekObjCmd, | |
| 208 | (CompileProc *) NULL, 1}, | |
| 209 | {"socket", (Tcl_CmdProc *) NULL, Tcl_SocketObjCmd, | |
| 210 | (CompileProc *) NULL, 0}, | |
| 211 | {"tell", (Tcl_CmdProc *) NULL, Tcl_TellObjCmd, | |
| 212 | (CompileProc *) NULL, 1}, | |
| 213 | {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd, | |
| 214 | (CompileProc *) NULL, 1}, | |
| 215 | {"update", (Tcl_CmdProc *) NULL, Tcl_UpdateObjCmd, | |
| 216 | (CompileProc *) NULL, 1}, | |
| 217 | {"vwait", (Tcl_CmdProc *) NULL, Tcl_VwaitObjCmd, | |
| 218 | (CompileProc *) NULL, 1}, | |
| 219 | ||
| 220 | #ifdef MAC_TCL | |
| 221 | {"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd, | |
| 222 | (CompileProc *) NULL, 0}, | |
| 223 | {"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL, | |
| 224 | (CompileProc *) NULL, 0}, | |
| 225 | {"ls", (Tcl_CmdProc *) NULL, Tcl_LsObjCmd, | |
| 226 | (CompileProc *) NULL, 0}, | |
| 227 | {"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd, | |
| 228 | (CompileProc *) NULL, 1}, | |
| 229 | {"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd, | |
| 230 | (CompileProc *) NULL, 0}, | |
| 231 | #else | |
| 232 | {"exec", (Tcl_CmdProc *) NULL, Tcl_ExecObjCmd, | |
| 233 | (CompileProc *) NULL, 0}, | |
| 234 | {"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd, | |
| 235 | (CompileProc *) NULL, 0}, | |
| 236 | #endif /* MAC_TCL */ | |
| 237 | ||
| 238 | #endif /* TCL_GENERIC_ONLY */ | |
| 239 | {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL, | |
| 240 | (CompileProc *) NULL, 0} | |
| 241 | }; | |
| 242 | ||
| 243 | ||
| 244 | /* | |
| 245 | *---------------------------------------------------------------------- | |
| 246 | * | |
| 247 | * Tcl_CreateInterp -- | |
| 248 | * | |
| 249 | * Create a new TCL command interpreter. | |
| 250 | * | |
| 251 | * Results: | |
| 252 | * The return value is a token for the interpreter, which may be | |
| 253 | * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or | |
| 254 | * Tcl_DeleteInterp. | |
| 255 | * | |
| 256 | * Side effects: | |
| 257 | * The command interpreter is initialized with an empty variable | |
| 258 | * table and the built-in commands. | |
| 259 | * | |
| 260 | *---------------------------------------------------------------------- | |
| 261 | */ | |
| 262 | ||
| 263 | Tcl_Interp * | |
| 264 | Tcl_CreateInterp() | |
| 265 | { | |
| 266 | Interp *iPtr; | |
| 267 | Tcl_Interp *interp; | |
| 268 | Command *cmdPtr; | |
| 269 | BuiltinFunc *builtinFuncPtr; | |
| 270 | MathFunc *mathFuncPtr; | |
| 271 | Tcl_HashEntry *hPtr; | |
| 272 | CmdInfo *cmdInfoPtr; | |
| 273 | int i; | |
| 274 | union { | |
| 275 | char c[sizeof(short)]; | |
| 276 | short s; | |
| 277 | } order; | |
| 278 | #ifdef TCL_COMPILE_STATS | |
| 279 | ByteCodeStats *statsPtr; | |
| 280 | #endif /* TCL_COMPILE_STATS */ | |
| 281 | ||
| 282 | TclInitSubsystems(NULL); | |
| 283 | ||
| 284 | /* | |
| 285 | * Panic if someone updated the CallFrame structure without | |
| 286 | * also updating the Tcl_CallFrame structure (or vice versa). | |
| 287 | */ | |
| 288 | ||
| 289 | if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) { | |
| 290 | /*NOTREACHED*/ | |
| 291 | panic("Tcl_CallFrame and CallFrame are not the same size"); | |
| 292 | } | |
| 293 | ||
| 294 | /* | |
| 295 | * Initialize support for namespaces and create the global namespace | |
| 296 | * (whose name is ""; an alias is "::"). This also initializes the | |
| 297 | * Tcl object type table and other object management code. | |
| 298 | */ | |
| 299 | ||
| 300 | iPtr = (Interp *) ckalloc(sizeof(Interp)); | |
| 301 | interp = (Tcl_Interp *) iPtr; | |
| 302 | ||
| 303 | iPtr->result = iPtr->resultSpace; | |
| 304 | iPtr->freeProc = NULL; | |
| 305 | iPtr->errorLine = 0; | |
| 306 | iPtr->objResultPtr = Tcl_NewObj(); | |
| 307 | Tcl_IncrRefCount(iPtr->objResultPtr); | |
| 308 | iPtr->handle = TclHandleCreate(iPtr); | |
| 309 | iPtr->globalNsPtr = NULL; | |
| 310 | iPtr->hiddenCmdTablePtr = NULL; | |
| 311 | iPtr->interpInfo = NULL; | |
| 312 | Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); | |
| 313 | ||
| 314 | iPtr->numLevels = 0; | |
| 315 | iPtr->maxNestingDepth = 1000; | |
| 316 | iPtr->framePtr = NULL; | |
| 317 | iPtr->varFramePtr = NULL; | |
| 318 | iPtr->activeTracePtr = NULL; | |
| 319 | iPtr->returnCode = TCL_OK; | |
| 320 | iPtr->errorInfo = NULL; | |
| 321 | iPtr->errorCode = NULL; | |
| 322 | ||
| 323 | iPtr->appendResult = NULL; | |
| 324 | iPtr->appendAvl = 0; | |
| 325 | iPtr->appendUsed = 0; | |
| 326 | ||
| 327 | Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); | |
| 328 | iPtr->packageUnknown = NULL; | |
| 329 | iPtr->cmdCount = 0; | |
| 330 | iPtr->termOffset = 0; | |
| 331 | TclInitLiteralTable(&(iPtr->literalTable)); | |
| 332 | iPtr->compileEpoch = 0; | |
| 333 | iPtr->compiledProcPtr = NULL; | |
| 334 | iPtr->resolverPtr = NULL; | |
| 335 | iPtr->evalFlags = 0; | |
| 336 | iPtr->scriptFile = NULL; | |
| 337 | iPtr->flags = 0; | |
| 338 | iPtr->tracePtr = NULL; | |
| 339 | iPtr->assocData = (Tcl_HashTable *) NULL; | |
| 340 | iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ | |
| 341 | iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ | |
| 342 | Tcl_IncrRefCount(iPtr->emptyObjPtr); | |
| 343 | iPtr->resultSpace[0] = 0; | |
| 344 | ||
| 345 | iPtr->globalNsPtr = NULL; /* force creation of global ns below */ | |
| 346 | iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "", | |
| 347 | (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); | |
| 348 | if (iPtr->globalNsPtr == NULL) { | |
| 349 | panic("Tcl_CreateInterp: can't create global namespace"); | |
| 350 | } | |
| 351 | ||
| 352 | /* | |
| 353 | * Initialize support for code compilation and execution. We call | |
| 354 | * TclCreateExecEnv after initializing namespaces since it tries to | |
| 355 | * reference a Tcl variable (it links to the Tcl "tcl_traceExec" | |
| 356 | * variable). | |
| 357 | */ | |
| 358 | ||
| 359 | iPtr->execEnvPtr = TclCreateExecEnv(interp); | |
| 360 | ||
| 361 | /* | |
| 362 | * Initialize the compilation and execution statistics kept for this | |
| 363 | * interpreter. | |
| 364 | */ | |
| 365 | ||
| 366 | #ifdef TCL_COMPILE_STATS | |
| 367 | statsPtr = &(iPtr->stats); | |
| 368 | statsPtr->numExecutions = 0; | |
| 369 | statsPtr->numCompilations = 0; | |
| 370 | statsPtr->numByteCodesFreed = 0; | |
| 371 | (VOID *) memset(statsPtr->instructionCount, 0, | |
| 372 | sizeof(statsPtr->instructionCount)); | |
| 373 | ||
| 374 | statsPtr->totalSrcBytes = 0.0; | |
| 375 | statsPtr->totalByteCodeBytes = 0.0; | |
| 376 | statsPtr->currentSrcBytes = 0.0; | |
| 377 | statsPtr->currentByteCodeBytes = 0.0; | |
| 378 | (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); | |
| 379 | (VOID *) memset(statsPtr->byteCodeCount, 0, | |
| 380 | sizeof(statsPtr->byteCodeCount)); | |
| 381 | (VOID *) memset(statsPtr->lifetimeCount, 0, | |
| 382 | sizeof(statsPtr->lifetimeCount)); | |
| 383 | ||
| 384 | statsPtr->currentInstBytes = 0.0; | |
| 385 | statsPtr->currentLitBytes = 0.0; | |
| 386 | statsPtr->currentExceptBytes = 0.0; | |
| 387 | statsPtr->currentAuxBytes = 0.0; | |
| 388 | statsPtr->currentCmdMapBytes = 0.0; | |
| 389 | ||
| 390 | statsPtr->numLiteralsCreated = 0; | |
| 391 | statsPtr->totalLitStringBytes = 0.0; | |
| 392 | statsPtr->currentLitStringBytes = 0.0; | |
| 393 | (VOID *) memset(statsPtr->literalCount, 0, | |
| 394 | sizeof(statsPtr->literalCount)); | |
| 395 | #endif /* TCL_COMPILE_STATS */ | |
| 396 | ||
| 397 | /* | |
| 398 | * Initialise the stub table pointer. | |
| 399 | */ | |
| 400 | ||
| 401 | iPtr->stubTable = &tclStubs; | |
| 402 | ||
| 403 | ||
| 404 | /* | |
| 405 | * Create the core commands. Do it here, rather than calling | |
| 406 | * Tcl_CreateCommand, because it's faster (there's no need to check for | |
| 407 | * a pre-existing command by the same name). If a command has a | |
| 408 | * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to | |
| 409 | * TclInvokeStringCommand. This is an object-based wrapper procedure | |
| 410 | * that extracts strings, calls the string procedure, and creates an | |
| 411 | * object for the result. Similarly, if a command has a Tcl_ObjCmdProc | |
| 412 | * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. | |
| 413 | */ | |
| 414 | ||
| 415 | for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; | |
| 416 | cmdInfoPtr++) { | |
| 417 | int new; | |
| 418 | Tcl_HashEntry *hPtr; | |
| 419 | ||
| 420 | if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) | |
| 421 | && (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) | |
| 422 | && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) { | |
| 423 | panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n"); | |
| 424 | } | |
| 425 | ||
| 426 | hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, | |
| 427 | cmdInfoPtr->name, &new); | |
| 428 | if (new) { | |
| 429 | cmdPtr = (Command *) ckalloc(sizeof(Command)); | |
| 430 | cmdPtr->hPtr = hPtr; | |
| 431 | cmdPtr->nsPtr = iPtr->globalNsPtr; | |
| 432 | cmdPtr->refCount = 1; | |
| 433 | cmdPtr->cmdEpoch = 0; | |
| 434 | cmdPtr->compileProc = cmdInfoPtr->compileProc; | |
| 435 | if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) { | |
| 436 | cmdPtr->proc = TclInvokeObjectCommand; | |
| 437 | cmdPtr->clientData = (ClientData) cmdPtr; | |
| 438 | } else { | |
| 439 | cmdPtr->proc = cmdInfoPtr->proc; | |
| 440 | cmdPtr->clientData = (ClientData) NULL; | |
| 441 | } | |
| 442 | if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { | |
| 443 | cmdPtr->objProc = TclInvokeStringCommand; | |
| 444 | cmdPtr->objClientData = (ClientData) cmdPtr; | |
| 445 | } else { | |
| 446 | cmdPtr->objProc = cmdInfoPtr->objProc; | |
| 447 | cmdPtr->objClientData = (ClientData) NULL; | |
| 448 | } | |
| 449 | cmdPtr->deleteProc = NULL; | |
| 450 | cmdPtr->deleteData = (ClientData) NULL; | |
| 451 | cmdPtr->deleted = 0; | |
| 452 | cmdPtr->importRefPtr = NULL; | |
| 453 | Tcl_SetHashValue(hPtr, cmdPtr); | |
| 454 | } | |
| 455 | } | |
| 456 | ||
| 457 | /* | |
| 458 | * Register the builtin math functions. | |
| 459 | */ | |
| 460 | ||
| 461 | i = 0; | |
| 462 | for (builtinFuncPtr = builtinFuncTable; builtinFuncPtr->name != NULL; | |
| 463 | builtinFuncPtr++) { | |
| 464 | Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name, | |
| 465 | builtinFuncPtr->numArgs, builtinFuncPtr->argTypes, | |
| 466 | (Tcl_MathProc *) NULL, (ClientData) 0); | |
| 467 | hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, | |
| 468 | builtinFuncPtr->name); | |
| 469 | if (hPtr == NULL) { | |
| 470 | panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name); | |
| 471 | return NULL; | |
| 472 | } | |
| 473 | mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); | |
| 474 | mathFuncPtr->builtinFuncIndex = i; | |
| 475 | i++; | |
| 476 | } | |
| 477 | iPtr->flags |= EXPR_INITIALIZED; | |
| 478 | ||
| 479 | /* | |
| 480 | * Do Multiple/Safe Interps Tcl init stuff | |
| 481 | */ | |
| 482 | ||
| 483 | TclInterpInit(interp); | |
| 484 | ||
| 485 | /* | |
| 486 | * We used to create the "errorInfo" and "errorCode" global vars at this | |
| 487 | * point because so much of the Tcl implementation assumes they already | |
| 488 | * exist. This is not quite enough, however, since they can be unset | |
| 489 | * at any time. | |
| 490 | * | |
| 491 | * There are 2 choices: | |
| 492 | * + Check every place where a GetVar of those is used | |
| 493 | * and the NULL result is not checked (like in tclLoad.c) | |
| 494 | * + Make SetVar,... NULL friendly | |
| 495 | * We choose the second option because : | |
| 496 | * + It is easy and low cost to check for NULL pointer before | |
| 497 | * calling strlen() | |
| 498 | * + It can be helpfull to other people using those API | |
| 499 | * + Passing a NULL value to those closest 'meaning' is empty string | |
| 500 | * (specially with the new objects where 0 bytes strings are ok) | |
| 501 | * So the following init is commented out: -- dl | |
| 502 | * | |
| 503 | * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, | |
| 504 | * "", TCL_GLOBAL_ONLY); | |
| 505 | * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, | |
| 506 | * "NONE", TCL_GLOBAL_ONLY); | |
| 507 | */ | |
| 508 | ||
| 509 | #ifndef TCL_GENERIC_ONLY | |
| 510 | TclSetupEnv(interp); | |
| 511 | #endif | |
| 512 | ||
| 513 | /* | |
| 514 | * Compute the byte order of this machine. | |
| 515 | */ | |
| 516 | ||
| 517 | order.s = 1; | |
| 518 | Tcl_SetVar2(interp, "tcl_platform", "byteOrder", | |
| 519 | ((order.c[0] == 1) ? "littleEndian" : "bigEndian"), | |
| 520 | TCL_GLOBAL_ONLY); | |
| 521 | ||
| 522 | /* | |
| 523 | * Set up other variables such as tcl_version and tcl_library | |
| 524 | */ | |
| 525 | ||
| 526 | Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); | |
| 527 | Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); | |
| 528 | Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL, | |
| 529 | TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, | |
| 530 | TclPrecTraceProc, (ClientData) NULL); | |
| 531 | TclpSetVariables(interp); | |
| 532 | ||
| 533 | #ifdef TCL_THREADS | |
| 534 | /* | |
| 535 | * The existence of the "threaded" element of the tcl_platform array indicates | |
| 536 | * that this particular Tcl shell has been compiled with threads turned on. | |
| 537 | * Using "info exists tcl_platform(threaded)" a Tcl script can introspect on the | |
| 538 | * interpreter level of thread safety. | |
| 539 | */ | |
| 540 | ||
| 541 | ||
| 542 | Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", | |
| 543 | TCL_GLOBAL_ONLY); | |
| 544 | #endif | |
| 545 | ||
| 546 | /* | |
| 547 | * Register Tcl's version number. | |
| 548 | */ | |
| 549 | ||
| 550 | Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs); | |
| 551 | ||
| 552 | #ifdef Tcl_InitStubs | |
| 553 | #undef Tcl_InitStubs | |
| 554 | #endif | |
| 555 | Tcl_InitStubs(interp, TCL_VERSION, 1); | |
| 556 | ||
| 557 | return interp; | |
| 558 | } | |
| 559 | ||
| 560 | /* | |
| 561 | *---------------------------------------------------------------------- | |
| 562 | * | |
| 563 | * TclHideUnsafeCommands -- | |
| 564 | * | |
| 565 | * Hides base commands that are not marked as safe from this | |
| 566 | * interpreter. | |
| 567 | * | |
| 568 | * Results: | |
| 569 | * TCL_OK if it succeeds, TCL_ERROR else. | |
| 570 | * | |
| 571 | * Side effects: | |
| 572 | * Hides functionality in an interpreter. | |
| 573 | * | |
| 574 | *---------------------------------------------------------------------- | |
| 575 | */ | |
| 576 | ||
| 577 | int | |
| 578 | TclHideUnsafeCommands(interp) | |
| 579 | Tcl_Interp *interp; /* Hide commands in this interpreter. */ | |
| 580 | { | |
| 581 | register CmdInfo *cmdInfoPtr; | |
| 582 | ||
| 583 | if (interp == (Tcl_Interp *) NULL) { | |
| 584 | return TCL_ERROR; | |
| 585 | } | |
| 586 | for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { | |
| 587 | if (!cmdInfoPtr->isSafe) { | |
| 588 | Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); | |
| 589 | } | |
| 590 | } | |
| 591 | return TCL_OK; | |
| 592 | } | |
| 593 | ||
| 594 | /* | |
| 595 | *-------------------------------------------------------------- | |
| 596 | * | |
| 597 | * Tcl_CallWhenDeleted -- | |
| 598 | * | |
| 599 | * Arrange for a procedure to be called before a given | |
| 600 | * interpreter is deleted. The procedure is called as soon | |
| 601 | * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is | |
| 602 | * called on an interpreter that has already been deleted, | |
| 603 | * the procedure will be called when the last Tcl_Release is | |
| 604 | * done on the interpreter. | |
| 605 | * | |
| 606 | * Results: | |
| 607 | * None. | |
| 608 | * | |
| 609 | * Side effects: | |
| 610 | * When Tcl_DeleteInterp is invoked to delete interp, | |
| 611 | * proc will be invoked. See the manual entry for | |
| 612 | * details. | |
| 613 | * | |
| 614 | *-------------------------------------------------------------- | |
| 615 | */ | |
| 616 | ||
| 617 | void | |
| 618 | Tcl_CallWhenDeleted(interp, proc, clientData) | |
| 619 | Tcl_Interp *interp; /* Interpreter to watch. */ | |
| 620 | Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter | |
| 621 | * is about to be deleted. */ | |
| 622 | ClientData clientData; /* One-word value to pass to proc. */ | |
| 623 | { | |
| 624 | Interp *iPtr = (Interp *) interp; | |
| 625 | static int assocDataCounter = 0; | |
| 626 | #ifdef TCL_THREADS | |
| 627 | static Tcl_Mutex assocMutex; | |
| 628 | #endif | |
| 629 | int new; | |
| 630 | char buffer[32 + TCL_INTEGER_SPACE]; | |
| 631 | AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); | |
| 632 | Tcl_HashEntry *hPtr; | |
| 633 | ||
| 634 | Tcl_MutexLock(&assocMutex); | |
| 635 | sprintf(buffer, "Assoc Data Key #%d", assocDataCounter); | |
| 636 | assocDataCounter++; | |
| 637 | Tcl_MutexUnlock(&assocMutex); | |
| 638 | ||
| 639 | if (iPtr->assocData == (Tcl_HashTable *) NULL) { | |
| 640 | iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); | |
| 641 | Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); | |
| 642 | } | |
| 643 | hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new); | |
| 644 | dPtr->proc = proc; | |
| 645 | dPtr->clientData = clientData; | |
| 646 | Tcl_SetHashValue(hPtr, dPtr); | |
| 647 | } | |
| 648 | ||
| 649 | /* | |
| 650 | *-------------------------------------------------------------- | |
| 651 | * | |
| 652 | * Tcl_DontCallWhenDeleted -- | |
| 653 | * | |
| 654 | * Cancel the arrangement for a procedure to be called when | |
| 655 | * a given interpreter is deleted. | |
| 656 | * | |
| 657 | * Results: | |
| 658 | * None. | |
| 659 | * | |
| 660 | * Side effects: | |
| 661 | * If proc and clientData were previously registered as a | |
| 662 | * callback via Tcl_CallWhenDeleted, they are unregistered. | |
| 663 | * If they weren't previously registered then nothing | |
| 664 | * happens. | |
| 665 | * | |
| 666 | *-------------------------------------------------------------- | |
| 667 | */ | |
| 668 | ||
| 669 | void | |
| 670 | Tcl_DontCallWhenDeleted(interp, proc, clientData) | |
| 671 | Tcl_Interp *interp; /* Interpreter to watch. */ | |
| 672 | Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter | |
| 673 | * is about to be deleted. */ | |
| 674 | ClientData clientData; /* One-word value to pass to proc. */ | |
| 675 | { | |
| 676 | Interp *iPtr = (Interp *) interp; | |
| 677 | Tcl_HashTable *hTablePtr; | |
| 678 | Tcl_HashSearch hSearch; | |
| 679 | Tcl_HashEntry *hPtr; | |
| 680 | AssocData *dPtr; | |
| 681 | ||
| 682 | hTablePtr = iPtr->assocData; | |
| 683 | if (hTablePtr == (Tcl_HashTable *) NULL) { | |
| 684 | return; | |
| 685 | } | |
| 686 | for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; | |
| 687 | hPtr = Tcl_NextHashEntry(&hSearch)) { | |
| 688 | dPtr = (AssocData *) Tcl_GetHashValue(hPtr); | |
| 689 | if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { | |
| 690 | ckfree((char *) dPtr); | |
| 691 | Tcl_DeleteHashEntry(hPtr); | |
| 692 | return; | |
| 693 | } | |
| 694 | } | |
| 695 | } | |
| 696 | ||
| 697 | /* | |
| 698 | *---------------------------------------------------------------------- | |
| 699 | * | |
| 700 | * Tcl_SetAssocData -- | |
| 701 | * | |
| 702 | * Creates a named association between user-specified data, a delete | |
| 703 | * function and this interpreter. If the association already exists | |
| 704 | * the data is overwritten with the new data. The delete function will | |
| 705 | * be invoked when the interpreter is deleted. | |
| 706 | * | |
| 707 | * Results: | |
| 708 | * None. | |
| 709 | * | |
| 710 | * Side effects: | |
| 711 | * Sets the associated data, creates the association if needed. | |
| 712 | * | |
| 713 | *---------------------------------------------------------------------- | |
| 714 | */ | |
| 715 | ||
| 716 | void | |
| 717 | Tcl_SetAssocData(interp, name, proc, clientData) | |
| 718 | Tcl_Interp *interp; /* Interpreter to associate with. */ | |
| 719 | char *name; /* Name for association. */ | |
| 720 | Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is | |
| 721 | * about to be deleted. */ | |
| 722 | ClientData clientData; /* One-word value to pass to proc. */ | |
| 723 | { | |
| 724 | Interp *iPtr = (Interp *) interp; | |
| 725 | AssocData *dPtr; | |
| 726 | Tcl_HashEntry *hPtr; | |
| 727 | int new; | |
| 728 | ||
| 729 | if (iPtr->assocData == (Tcl_HashTable *) NULL) { | |
| 730 | iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); | |
| 731 | Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); | |
| 732 | } | |
| 733 | hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new); | |
| 734 | if (new == 0) { | |
| 735 | dPtr = (AssocData *) Tcl_GetHashValue(hPtr); | |
| 736 | } else { | |
| 737 | dPtr = (AssocData *) ckalloc(sizeof(AssocData)); | |
| 738 | } | |
| 739 | dPtr->proc = proc; | |
| 740 | dPtr->clientData = clientData; | |
| 741 | ||
| 742 | Tcl_SetHashValue(hPtr, dPtr); | |
| 743 | } | |
| 744 | ||
| 745 | /* | |
| 746 | *---------------------------------------------------------------------- | |
| 747 | * | |
| 748 | * Tcl_DeleteAssocData -- | |
| 749 | * | |
| 750 | * Deletes a named association of user-specified data with | |
| 751 | * the specified interpreter. | |
| 752 | * | |
| 753 | * Results: | |
| 754 | * None. | |
| 755 | * | |
| 756 | * Side effects: | |
| 757 | * Deletes the association. | |
| 758 | * | |
| 759 | *---------------------------------------------------------------------- | |
| 760 | */ | |
| 761 | ||
| 762 | void | |
| 763 | Tcl_DeleteAssocData(interp, name) | |
| 764 | Tcl_Interp *interp; /* Interpreter to associate with. */ | |
| 765 | char *name; /* Name of association. */ | |
| 766 | { | |
| 767 | Interp *iPtr = (Interp *) interp; | |
| 768 | AssocData *dPtr; | |
| 769 | Tcl_HashEntry *hPtr; | |
| 770 | ||
| 771 | if (iPtr->assocData == (Tcl_HashTable *) NULL) { | |
| 772 | return; | |
| 773 | } | |
| 774 | hPtr = Tcl_FindHashEntry(iPtr->assocData, name); | |
| 775 | if (hPtr == (Tcl_HashEntry *) NULL) { | |
| 776 | return; | |
| 777 | } | |
| 778 | dPtr = (AssocData *) Tcl_GetHashValue(hPtr); | |
| 779 | if (dPtr->proc != NULL) { | |
| 780 | (dPtr->proc) (dPtr->clientData, interp); | |
| 781 | } | |
| 782 | ckfree((char *) dPtr); | |
| 783 | Tcl_DeleteHashEntry(hPtr); | |
| 784 | } | |
| 785 | ||
| 786 | /* | |
| 787 | *---------------------------------------------------------------------- | |
| 788 | * | |
| 789 | * Tcl_GetAssocData -- | |
| 790 | * | |
| 791 | * Returns the client data associated with this name in the | |
| 792 | * specified interpreter. | |
| 793 | * | |
| 794 | * Results: | |
| 795 | * The client data in the AssocData record denoted by the named | |
| 796 | * association, or NULL. | |
| 797 | * | |
| 798 | * Side effects: | |
| 799 | * None. | |
| 800 | * | |
| 801 | *---------------------------------------------------------------------- | |
| 802 | */ | |
| 803 | ||
| 804 | ClientData | |
| 805 | Tcl_GetAssocData(interp, name, procPtr) | |
| 806 | Tcl_Interp *interp; /* Interpreter associated with. */ | |
| 807 | char *name; /* Name of association. */ | |
| 808 | Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address | |
| 809 | * of current deletion callback. */ | |
| 810 | { | |
| 811 | Interp *iPtr = (Interp *) interp; | |
| 812 | AssocData *dPtr; | |
| 813 | Tcl_HashEntry *hPtr; | |
| 814 | ||
| 815 | if (iPtr->assocData == (Tcl_HashTable *) NULL) { | |
| 816 | return (ClientData) NULL; | |
| 817 | } | |
| 818 | hPtr = Tcl_FindHashEntry(iPtr->assocData, name); | |
| 819 | if (hPtr == (Tcl_HashEntry *) NULL) { | |
| 820 | return (ClientData) NULL; | |
| 821 | } | |
| 822 | dPtr = (AssocData *) Tcl_GetHashValue(hPtr); | |
| 823 | if (procPtr != (Tcl_InterpDeleteProc **) NULL) { | |
| 824 | *procPtr = dPtr->proc; | |
| 825 | } | |
| 826 | return dPtr->clientData; | |
| 827 | } | |
| 828 | ||
| 829 | /* | |
| 830 | *---------------------------------------------------------------------- | |
| 831 | * | |
| 832 | * Tcl_InterpDeleted -- | |
| 833 | * | |
| 834 | * Returns nonzero if the interpreter has been deleted with a call | |
| 835 | * to Tcl_DeleteInterp. | |
| 836 | * | |
| 837 | * Results: | |
| 838 | * Nonzero if the interpreter is deleted, zero otherwise. | |
| 839 | * | |
| 840 | * Side effects: | |
| 841 | * None. | |
| 842 | * | |
| 843 | *---------------------------------------------------------------------- | |
| 844 | */ | |
| 845 | ||
| 846 | int | |
| 847 | Tcl_InterpDeleted(interp) | |
| 848 | Tcl_Interp *interp; | |
| 849 | { | |
| 850 | return (((Interp *) interp)->flags & DELETED) ? 1 : 0; | |
| 851 | } | |
| 852 | ||
| 853 | /* | |
| 854 | *---------------------------------------------------------------------- | |
| 855 | * | |
| 856 | * Tcl_DeleteInterp -- | |
| 857 | * | |
| 858 | * Ensures that the interpreter will be deleted eventually. If there | |
| 859 | * are no Tcl_Preserve calls in effect for this interpreter, it is | |
| 860 | * deleted immediately, otherwise the interpreter is deleted when | |
| 861 | * the last Tcl_Preserve is matched by a call to Tcl_Release. In either | |
| 862 | * case, the procedure runs the currently registered deletion callbacks. | |
| 863 | * | |
| 864 | * Results: | |
| 865 | * None. | |
| 866 | * | |
| 867 | * Side effects: | |
| 868 | * The interpreter is marked as deleted. The caller may still use it | |
| 869 | * safely if there are calls to Tcl_Preserve in effect for the | |
| 870 | * interpreter, but further calls to Tcl_Eval etc in this interpreter | |
| 871 | * will fail. | |
| 872 | * | |
| 873 | *---------------------------------------------------------------------- | |
| 874 | */ | |
| 875 | ||
| 876 | void | |
| 877 | Tcl_DeleteInterp(interp) | |
| 878 | Tcl_Interp *interp; /* Token for command interpreter (returned | |
| 879 | * by a previous call to Tcl_CreateInterp). */ | |
| 880 | { | |
| 881 | Interp *iPtr = (Interp *) interp; | |
| 882 | ||
| 883 | /* | |
| 884 | * If the interpreter has already been marked deleted, just punt. | |
| 885 | */ | |
| 886 | ||
| 887 | if (iPtr->flags & DELETED) { | |
| 888 | return; | |
| 889 | } | |
| 890 | ||
| 891 | /* | |
| 892 | * Mark the interpreter as deleted. No further evals will be allowed. | |
| 893 | */ | |
| 894 | ||
| 895 | iPtr->flags |= DELETED; | |
| 896 | ||
| 897 | /* | |
| 898 | * Ensure that the interpreter is eventually deleted. | |
| 899 | */ | |
| 900 | ||
| 901 | Tcl_EventuallyFree((ClientData) interp, | |
| 902 | (Tcl_FreeProc *) DeleteInterpProc); | |
| 903 | } | |
| 904 | ||
| 905 | /* | |
| 906 | *---------------------------------------------------------------------- | |
| 907 | * | |
| 908 | * DeleteInterpProc -- | |
| 909 | * | |
| 910 | * Helper procedure to delete an interpreter. This procedure is | |
| 911 | * called when the last call to Tcl_Preserve on this interpreter | |
| 912 | * is matched by a call to Tcl_Release. The procedure cleans up | |
| 913 | * all resources used in the interpreter and calls all currently | |
| 914 | * registered interpreter deletion callbacks. | |
| 915 | * | |
| 916 | * Results: | |
| 917 | * None. | |
| 918 | * | |
| 919 | * Side effects: | |
| 920 | * Whatever the interpreter deletion callbacks do. Frees resources | |
| 921 | * used by the interpreter. | |
| 922 | * | |
| 923 | *---------------------------------------------------------------------- | |
| 924 | */ | |
| 925 | ||
| 926 | static void | |
| 927 | DeleteInterpProc(interp) | |
| 928 | Tcl_Interp *interp; /* Interpreter to delete. */ | |
| 929 | { | |
| 930 | Interp *iPtr = (Interp *) interp; | |
| 931 | Tcl_HashEntry *hPtr; | |
| 932 | Tcl_HashSearch search; | |
| 933 | Tcl_HashTable *hTablePtr; | |
| 934 | ResolverScheme *resPtr, *nextResPtr; | |
| 935 | ||
| 936 | /* | |
| 937 | * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. | |
| 938 | */ | |
| 939 | ||
| 940 | if (iPtr->numLevels > 0) { | |
| 941 | panic("DeleteInterpProc called with active evals"); | |
| 942 | } | |
| 943 | ||
| 944 | /* | |
| 945 | * The interpreter should already be marked deleted; otherwise how | |
| 946 | * did we get here? | |
| 947 | */ | |
| 948 | ||
| 949 | if (!(iPtr->flags & DELETED)) { | |
| 950 | panic("DeleteInterpProc called on interpreter not marked deleted"); | |
| 951 | } | |
| 952 | ||
| 953 | TclHandleFree(iPtr->handle); | |
| 954 | ||
| 955 | /* | |
| 956 | * Dismantle everything in the global namespace except for the | |
| 957 | * "errorInfo" and "errorCode" variables. These remain until the | |
| 958 | * namespace is actually destroyed, in case any errors occur. | |
| 959 | * | |
| 960 | * Dismantle the namespace here, before we clear the assocData. If any | |
| 961 | * background errors occur here, they will be deleted below. | |
| 962 | */ | |
| 963 | ||
| 964 | TclTeardownNamespace(iPtr->globalNsPtr); | |
| 965 | ||
| 966 | /* | |
| 967 | * Delete all the hidden commands. | |
| 968 | */ | |
| 969 | ||
| 970 | hTablePtr = iPtr->hiddenCmdTablePtr; | |
| 971 | if (hTablePtr != NULL) { | |
| 972 | /* | |
| 973 | * Non-pernicious deletion. The deletion callbacks will not be | |
| 974 | * allowed to create any new hidden or non-hidden commands. | |
| 975 | * Tcl_DeleteCommandFromToken() will remove the entry from the | |
| 976 | * hiddenCmdTablePtr. | |
| 977 | */ | |
| 978 | ||
| 979 | hPtr = Tcl_FirstHashEntry(hTablePtr, &search); | |
| 980 | for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { | |
| 981 | Tcl_DeleteCommandFromToken(interp, | |
| 982 | (Tcl_Command) Tcl_GetHashValue(hPtr)); | |
| 983 | } | |
| 984 | Tcl_DeleteHashTable(hTablePtr); | |
| 985 | ckfree((char *) hTablePtr); | |
| 986 | } | |
| 987 | /* | |
| 988 | * Tear down the math function table. | |
| 989 | */ | |
| 990 | ||
| 991 | for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search); | |
| 992 | hPtr != NULL; | |
| 993 | hPtr = Tcl_NextHashEntry(&search)) { | |
| 994 | ckfree((char *) Tcl_GetHashValue(hPtr)); | |
| 995 | } | |
| 996 | Tcl_DeleteHashTable(&iPtr->mathFuncTable); | |
| 997 | ||
| 998 | /* | |
| 999 | * Invoke deletion callbacks; note that a callback can create new | |
| 1000 | * callbacks, so we iterate. | |
| 1001 | */ | |
| 1002 | ||
| 1003 | while (iPtr->assocData != (Tcl_HashTable *) NULL) { | |
| 1004 | AssocData *dPtr; | |
| 1005 | ||
| 1006 | hTablePtr = iPtr->assocData; | |
| 1007 | iPtr->assocData = (Tcl_HashTable *) NULL; | |
| 1008 | for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); | |
| 1009 | hPtr != NULL; | |
| 1010 | hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { | |
| 1011 | dPtr = (AssocData *) Tcl_GetHashValue(hPtr); | |
| 1012 | Tcl_DeleteHashEntry(hPtr); | |
| 1013 | if (dPtr->proc != NULL) { | |
| 1014 | (*dPtr->proc)(dPtr->clientData, interp); | |
| 1015 | } | |
| 1016 | ckfree((char *) dPtr); | |
| 1017 | } | |
| 1018 | Tcl_DeleteHashTable(hTablePtr); | |
| 1019 | ckfree((char *) hTablePtr); | |
| 1020 | } | |
| 1021 | ||
| 1022 | /* | |
| 1023 | * Finish deleting the global namespace. | |
| 1024 | */ | |
| 1025 | ||
| 1026 | Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); | |
| 1027 | ||
| 1028 | /* | |
| 1029 | * Free up the result *after* deleting variables, since variable | |
| 1030 | * deletion could have transferred ownership of the result string | |
| 1031 | * to Tcl. | |
| 1032 | */ | |
| 1033 | ||
| 1034 | Tcl_FreeResult(interp); | |
| 1035 | interp->result = NULL; | |
| 1036 | Tcl_DecrRefCount(iPtr->objResultPtr); | |
| 1037 | iPtr->objResultPtr = NULL; | |
| 1038 | if (iPtr->errorInfo != NULL) { | |
| 1039 | ckfree(iPtr->errorInfo); | |
| 1040 | iPtr->errorInfo = NULL; | |
| 1041 | } | |
| 1042 | if (iPtr->errorCode != NULL) { | |
| 1043 | ckfree(iPtr->errorCode); | |
| 1044 | iPtr->errorCode = NULL; | |
| 1045 | } | |
| 1046 | if (iPtr->appendResult != NULL) { | |
| 1047 | ckfree(iPtr->appendResult); | |
| 1048 | iPtr->appendResult = NULL; | |
| 1049 | } | |
| 1050 | TclFreePackageInfo(iPtr); | |
| 1051 | while (iPtr->tracePtr != NULL) { | |
| 1052 | Trace *nextPtr = iPtr->tracePtr->nextPtr; | |
| 1053 | ||
| 1054 | ckfree((char *) iPtr->tracePtr); | |
| 1055 | iPtr->tracePtr = nextPtr; | |
| 1056 | } | |
| 1057 | if (iPtr->execEnvPtr != NULL) { | |
| 1058 | TclDeleteExecEnv(iPtr->execEnvPtr); | |
| 1059 | } | |
| 1060 | Tcl_DecrRefCount(iPtr->emptyObjPtr); | |
| 1061 | iPtr->emptyObjPtr = NULL; | |
| 1062 | ||
| 1063 | resPtr = iPtr->resolverPtr; | |
| 1064 | while (resPtr) { | |
| 1065 | nextResPtr = resPtr->nextPtr; | |
| 1066 | ckfree(resPtr->name); | |
| 1067 | ckfree((char *) resPtr); | |
| 1068 | resPtr = nextResPtr; | |
| 1069 | } | |
| 1070 | ||
| 1071 | /* | |
| 1072 | * Free up literal objects created for scripts compiled by the | |
| 1073 | * interpreter. | |
| 1074 | */ | |
| 1075 | ||
| 1076 | TclDeleteLiteralTable(interp, &(iPtr->literalTable)); | |
| 1077 | ckfree((char *) iPtr); | |
| 1078 | } | |
| 1079 | ||
| 1080 | /* | |
| 1081 | *--------------------------------------------------------------------------- | |
| 1082 | * | |
| 1083 | * Tcl_HideCommand -- | |
| 1084 | * | |
| 1085 | * Makes a command hidden so that it cannot be invoked from within | |
| 1086 | * an interpreter, only from within an ancestor. | |
| 1087 | * | |
| 1088 | * Results: | |
| 1089 | * A standard Tcl result; also leaves a message in the interp's result | |
| 1090 | * if an error occurs. | |
| 1091 | * | |
| 1092 | * Side effects: | |
| 1093 | * Removes a command from the command table and create an entry | |
| 1094 | * into the hidden command table under the specified token name. | |
| 1095 | * | |
| 1096 | *--------------------------------------------------------------------------- | |
| 1097 | */ | |
| 1098 | ||
| 1099 | int | |
| 1100 | Tcl_HideCommand(interp, cmdName, hiddenCmdToken) | |
| 1101 | Tcl_Interp *interp; /* Interpreter in which to hide command. */ | |
| 1102 | char *cmdName; /* Name of command to hide. */ | |
| 1103 | char *hiddenCmdToken; /* Token name of the to-be-hidden command. */ | |
| 1104 | { | |
| 1105 | Interp *iPtr = (Interp *) interp; | |
| 1106 | Tcl_Command cmd; | |
| 1107 | Command *cmdPtr; | |
| 1108 | Tcl_HashTable *hiddenCmdTablePtr; | |
| 1109 | Tcl_HashEntry *hPtr; | |
| 1110 | int new; | |
| 1111 | ||
| 1112 | if (iPtr->flags & DELETED) { | |
| 1113 | ||
| 1114 | /* | |
| 1115 | * The interpreter is being deleted. Do not create any new | |
| 1116 | * structures, because it is not safe to modify the interpreter. | |
| 1117 | */ | |
| 1118 | ||
| 1119 | return TCL_ERROR; | |
| 1120 | } | |
| 1121 | ||
| 1122 | /* | |
| 1123 | * Disallow hiding of commands that are currently in a namespace or | |
| 1124 | * renaming (as part of hiding) into a namespace. | |
| 1125 | * | |
| 1126 | * (because the current implementation with a single global table | |
| 1127 | * and the needed uniqueness of names cause problems with namespaces) | |
| 1128 | * | |
| 1129 | * we don't need to check for "::" in cmdName because the real check is | |
| 1130 | * on the nsPtr below. | |
| 1131 | * | |
| 1132 | * hiddenCmdToken is just a string which is not interpreted in any way. | |
| 1133 | * It may contain :: but the string is not interpreted as a namespace | |
| 1134 | * qualifier command name. Thus, hiding foo::bar to foo::bar and then | |
| 1135 | * trying to expose or invoke ::foo::bar will NOT work; but if the | |
| 1136 | * application always uses the same strings it will get consistent | |
| 1137 | * behaviour. | |
| 1138 | * | |
| 1139 | * But as we currently limit ourselves to the global namespace only | |
| 1140 | * for the source, in order to avoid potential confusion, | |
| 1141 | * lets prevent "::" in the token too. --dl | |
| 1142 | */ | |
| 1143 |