os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclBasic.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclBasic.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,6094 @@
1.4 +/*
1.5 + * tclBasic.c --
1.6 + *
1.7 + * Contains the basic facilities for TCL command interpretation,
1.8 + * including interpreter creation and deletion, command creation
1.9 + * and deletion, and command/script execution.
1.10 + *
1.11 + * Copyright (c) 1987-1994 The Regents of the University of California.
1.12 + * Copyright (c) 1994-1997 Sun Microsystems, Inc.
1.13 + * Copyright (c) 1998-1999 by Scriptics Corporation.
1.14 + * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
1.15 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.16 + *
1.17 + * See the file "license.terms" for information on usage and redistribution
1.18 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.19 + *
1.20 + * RCS: @(#) $Id: tclBasic.c,v 1.75.2.26 2006/11/28 22:19:59 andreas_kupries Exp $
1.21 + */
1.22 +
1.23 +#include "tclInt.h"
1.24 +#include "tclCompile.h"
1.25 +#ifndef TCL_GENERIC_ONLY
1.26 +# include "tclPort.h"
1.27 +#endif
1.28 +
1.29 +/*
1.30 + * Static procedures in this file:
1.31 + */
1.32 +
1.33 +static char * CallCommandTraces _ANSI_ARGS_((Interp *iPtr,
1.34 + Command *cmdPtr, CONST char *oldName,
1.35 + CONST char* newName, int flags));
1.36 +static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
1.37 +static void ProcessUnexpectedResult _ANSI_ARGS_((
1.38 + Tcl_Interp *interp, int returnCode));
1.39 +static int StringTraceProc _ANSI_ARGS_((ClientData clientData,
1.40 + Tcl_Interp* interp,
1.41 + int level,
1.42 + CONST char* command,
1.43 + Tcl_Command commandInfo,
1.44 + int objc,
1.45 + Tcl_Obj *CONST objv[]));
1.46 +static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData));
1.47 +
1.48 +#ifdef TCL_TIP280
1.49 +/* TIP #280 - Modified token based evulation, with line information */
1.50 +static int EvalEx _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script,
1.51 + int numBytes, int flags, int line));
1.52 +
1.53 +static int EvalTokensStandard _ANSI_ARGS_((Tcl_Interp *interp,
1.54 + Tcl_Token *tokenPtr,
1.55 + int count, int line));
1.56 +
1.57 +#endif
1.58 +
1.59 +extern TclStubs tclStubs;
1.60 +
1.61 +/*
1.62 + * The following structure defines the commands in the Tcl core.
1.63 + */
1.64 +
1.65 +typedef struct {
1.66 + char *name; /* Name of object-based command. */
1.67 + Tcl_CmdProc *proc; /* String-based procedure for command. */
1.68 + Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */
1.69 + CompileProc *compileProc; /* Procedure called to compile command. */
1.70 + int isSafe; /* If non-zero, command will be present
1.71 + * in safe interpreter. Otherwise it will
1.72 + * be hidden. */
1.73 +} CmdInfo;
1.74 +
1.75 +/*
1.76 + * The built-in commands, and the procedures that implement them:
1.77 + */
1.78 +
1.79 +static CmdInfo builtInCmds[] = {
1.80 + /*
1.81 + * Commands in the generic core. Note that at least one of the proc or
1.82 + * objProc members should be non-NULL. This avoids infinitely recursive
1.83 + * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a
1.84 + * command name is computed at runtime and results in the name of a
1.85 + * compiled command.
1.86 + */
1.87 +
1.88 + {"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd,
1.89 + TclCompileAppendCmd, 1},
1.90 + {"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd,
1.91 + (CompileProc *) NULL, 1},
1.92 + {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd,
1.93 + (CompileProc *) NULL, 1},
1.94 + {"break", (Tcl_CmdProc *) NULL, Tcl_BreakObjCmd,
1.95 + TclCompileBreakCmd, 1},
1.96 + {"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd,
1.97 + (CompileProc *) NULL, 1},
1.98 + {"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd,
1.99 + TclCompileCatchCmd, 1},
1.100 + {"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd,
1.101 + (CompileProc *) NULL, 1},
1.102 + {"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd,
1.103 + (CompileProc *) NULL, 1},
1.104 + {"continue", (Tcl_CmdProc *) NULL, Tcl_ContinueObjCmd,
1.105 + TclCompileContinueCmd, 1},
1.106 + {"encoding", (Tcl_CmdProc *) NULL, Tcl_EncodingObjCmd,
1.107 + (CompileProc *) NULL, 0},
1.108 + {"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd,
1.109 + (CompileProc *) NULL, 1},
1.110 + {"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd,
1.111 + (CompileProc *) NULL, 1},
1.112 + {"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd,
1.113 + (CompileProc *) NULL, 0},
1.114 + {"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd,
1.115 + TclCompileExprCmd, 1},
1.116 + {"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd,
1.117 + (CompileProc *) NULL, 1},
1.118 + {"fileevent", (Tcl_CmdProc *) NULL, Tcl_FileEventObjCmd,
1.119 + (CompileProc *) NULL, 1},
1.120 + {"for", (Tcl_CmdProc *) NULL, Tcl_ForObjCmd,
1.121 + TclCompileForCmd, 1},
1.122 + {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd,
1.123 + TclCompileForeachCmd, 1},
1.124 + {"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd,
1.125 + (CompileProc *) NULL, 1},
1.126 + {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd,
1.127 + (CompileProc *) NULL, 1},
1.128 + {"if", (Tcl_CmdProc *) NULL, Tcl_IfObjCmd,
1.129 + TclCompileIfCmd, 1},
1.130 + {"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd,
1.131 + TclCompileIncrCmd, 1},
1.132 + {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd,
1.133 + (CompileProc *) NULL, 1},
1.134 + {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd,
1.135 + (CompileProc *) NULL, 1},
1.136 + {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd,
1.137 + TclCompileLappendCmd, 1},
1.138 + {"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd,
1.139 + TclCompileLindexCmd, 1},
1.140 + {"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd,
1.141 + (CompileProc *) NULL, 1},
1.142 + {"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd,
1.143 + TclCompileListCmd, 1},
1.144 + {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd,
1.145 + TclCompileLlengthCmd, 1},
1.146 + {"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd,
1.147 + (CompileProc *) NULL, 0},
1.148 + {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd,
1.149 + (CompileProc *) NULL, 1},
1.150 + {"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd,
1.151 + (CompileProc *) NULL, 1},
1.152 + {"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd,
1.153 + (CompileProc *) NULL, 1},
1.154 + {"lset", (Tcl_CmdProc *) NULL, Tcl_LsetObjCmd,
1.155 + TclCompileLsetCmd, 1},
1.156 + {"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd,
1.157 + (CompileProc *) NULL, 1},
1.158 + {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd,
1.159 + (CompileProc *) NULL, 1},
1.160 + {"package", (Tcl_CmdProc *) NULL, Tcl_PackageObjCmd,
1.161 + (CompileProc *) NULL, 1},
1.162 + {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd,
1.163 + (CompileProc *) NULL, 1},
1.164 + {"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd,
1.165 + TclCompileRegexpCmd, 1},
1.166 + {"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd,
1.167 + (CompileProc *) NULL, 1},
1.168 + {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd,
1.169 + (CompileProc *) NULL, 1},
1.170 + {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd,
1.171 + TclCompileReturnCmd, 1},
1.172 + {"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd,
1.173 + (CompileProc *) NULL, 1},
1.174 + {"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd,
1.175 + TclCompileSetCmd, 1},
1.176 + {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd,
1.177 + (CompileProc *) NULL, 1},
1.178 + {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd,
1.179 + TclCompileStringCmd, 1},
1.180 + {"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd,
1.181 + (CompileProc *) NULL, 1},
1.182 + {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd,
1.183 + (CompileProc *) NULL, 1},
1.184 + {"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd,
1.185 + (CompileProc *) NULL, 1},
1.186 + {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd,
1.187 + (CompileProc *) NULL, 1},
1.188 + {"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd,
1.189 + (CompileProc *) NULL, 1},
1.190 + {"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd,
1.191 + (CompileProc *) NULL, 1},
1.192 + {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd,
1.193 + (CompileProc *) NULL, 1},
1.194 + {"while", (Tcl_CmdProc *) NULL, Tcl_WhileObjCmd,
1.195 + TclCompileWhileCmd, 1},
1.196 +
1.197 + /*
1.198 + * Commands in the UNIX core:
1.199 + */
1.200 +
1.201 +#ifndef TCL_GENERIC_ONLY
1.202 + {"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd,
1.203 + (CompileProc *) NULL, 1},
1.204 + {"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd,
1.205 + (CompileProc *) NULL, 0},
1.206 + {"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd,
1.207 + (CompileProc *) NULL, 1},
1.208 + {"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd,
1.209 + (CompileProc *) NULL, 1},
1.210 + {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd,
1.211 + (CompileProc *) NULL, 1},
1.212 + {"fconfigure", (Tcl_CmdProc *) NULL, Tcl_FconfigureObjCmd,
1.213 + (CompileProc *) NULL, 0},
1.214 + {"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd,
1.215 + (CompileProc *) NULL, 0},
1.216 + {"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd,
1.217 + (CompileProc *) NULL, 1},
1.218 + {"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd,
1.219 + (CompileProc *) NULL, 1},
1.220 + {"glob", (Tcl_CmdProc *) NULL, Tcl_GlobObjCmd,
1.221 + (CompileProc *) NULL, 0},
1.222 + {"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd,
1.223 + (CompileProc *) NULL, 0},
1.224 + {"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd,
1.225 + (CompileProc *) NULL, 1},
1.226 + {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd,
1.227 + (CompileProc *) NULL, 1},
1.228 + {"pwd", (Tcl_CmdProc *) NULL, Tcl_PwdObjCmd,
1.229 + (CompileProc *) NULL, 0},
1.230 + {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd,
1.231 + (CompileProc *) NULL, 1},
1.232 + {"seek", (Tcl_CmdProc *) NULL, Tcl_SeekObjCmd,
1.233 + (CompileProc *) NULL, 1},
1.234 + {"socket", (Tcl_CmdProc *) NULL, Tcl_SocketObjCmd,
1.235 + (CompileProc *) NULL, 0},
1.236 + {"tell", (Tcl_CmdProc *) NULL, Tcl_TellObjCmd,
1.237 + (CompileProc *) NULL, 1},
1.238 + {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd,
1.239 + (CompileProc *) NULL, 1},
1.240 + {"update", (Tcl_CmdProc *) NULL, Tcl_UpdateObjCmd,
1.241 + (CompileProc *) NULL, 1},
1.242 + {"vwait", (Tcl_CmdProc *) NULL, Tcl_VwaitObjCmd,
1.243 + (CompileProc *) NULL, 1},
1.244 +
1.245 +#ifdef MAC_TCL
1.246 + {"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd,
1.247 + (CompileProc *) NULL, 0},
1.248 + {"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL,
1.249 + (CompileProc *) NULL, 0},
1.250 + {"ls", (Tcl_CmdProc *) NULL, Tcl_LsObjCmd,
1.251 + (CompileProc *) NULL, 0},
1.252 + {"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd,
1.253 + (CompileProc *) NULL, 1},
1.254 + {"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd,
1.255 + (CompileProc *) NULL, 0},
1.256 +#else
1.257 + {"exec", (Tcl_CmdProc *) NULL, Tcl_ExecObjCmd,
1.258 + (CompileProc *) NULL, 0},
1.259 + {"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd,
1.260 + (CompileProc *) NULL, 0},
1.261 +#endif /* MAC_TCL */
1.262 +
1.263 +#endif /* TCL_GENERIC_ONLY */
1.264 + {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL,
1.265 + (CompileProc *) NULL, 0}
1.266 +};
1.267 +
1.268 +/*
1.269 + * The following structure holds the client data for string-based
1.270 + * trace procs
1.271 + */
1.272 +
1.273 +typedef struct StringTraceData {
1.274 + ClientData clientData; /* Client data from Tcl_CreateTrace */
1.275 + Tcl_CmdTraceProc* proc; /* Trace procedure from Tcl_CreateTrace */
1.276 +} StringTraceData;
1.277 +
1.278 +/*
1.279 + *----------------------------------------------------------------------
1.280 + *
1.281 + * Tcl_CreateInterp --
1.282 + *
1.283 + * Create a new TCL command interpreter.
1.284 + *
1.285 + * Results:
1.286 + * The return value is a token for the interpreter, which may be
1.287 + * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
1.288 + * Tcl_DeleteInterp.
1.289 + *
1.290 + * Side effects:
1.291 + * The command interpreter is initialized with the built-in commands
1.292 + * and with the variables documented in tclvars(n).
1.293 + *
1.294 + *----------------------------------------------------------------------
1.295 + */
1.296 +
1.297 +EXPORT_C Tcl_Interp *
1.298 +Tcl_CreateInterp()
1.299 +{
1.300 + Interp *iPtr;
1.301 + Tcl_Interp *interp;
1.302 + Command *cmdPtr;
1.303 + BuiltinFunc *builtinFuncPtr;
1.304 + MathFunc *mathFuncPtr;
1.305 + Tcl_HashEntry *hPtr;
1.306 + CmdInfo *cmdInfoPtr;
1.307 + int i;
1.308 + union {
1.309 + char c[sizeof(short)];
1.310 + short s;
1.311 + } order;
1.312 +#ifdef TCL_COMPILE_STATS
1.313 + ByteCodeStats *statsPtr;
1.314 +#endif /* TCL_COMPILE_STATS */
1.315 +
1.316 + TclInitSubsystems(NULL);
1.317 +
1.318 + /*
1.319 + * Panic if someone updated the CallFrame structure without
1.320 + * also updating the Tcl_CallFrame structure (or vice versa).
1.321 + */
1.322 +
1.323 + if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) {
1.324 + /*NOTREACHED*/
1.325 + panic("Tcl_CallFrame and CallFrame are not the same size");
1.326 + }
1.327 +
1.328 + /*
1.329 + * Initialize support for namespaces and create the global namespace
1.330 + * (whose name is ""; an alias is "::"). This also initializes the
1.331 + * Tcl object type table and other object management code.
1.332 + */
1.333 +
1.334 + iPtr = (Interp *) ckalloc(sizeof(Interp));
1.335 + interp = (Tcl_Interp *) iPtr;
1.336 +
1.337 + iPtr->result = iPtr->resultSpace;
1.338 + iPtr->freeProc = NULL;
1.339 + iPtr->errorLine = 0;
1.340 + iPtr->objResultPtr = Tcl_NewObj();
1.341 + Tcl_IncrRefCount(iPtr->objResultPtr);
1.342 + iPtr->handle = TclHandleCreate(iPtr);
1.343 + iPtr->globalNsPtr = NULL;
1.344 + iPtr->hiddenCmdTablePtr = NULL;
1.345 + iPtr->interpInfo = NULL;
1.346 + Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
1.347 +
1.348 + iPtr->numLevels = 0;
1.349 + iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
1.350 + iPtr->framePtr = NULL;
1.351 + iPtr->varFramePtr = NULL;
1.352 +
1.353 +#ifdef TCL_TIP280
1.354 + /*
1.355 + * TIP #280 - Initialize the arrays used to extend the ByteCode and
1.356 + * Proc structures.
1.357 + */
1.358 + iPtr->cmdFramePtr = NULL;
1.359 + iPtr->linePBodyPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
1.360 + iPtr->lineBCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
1.361 + Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS);
1.362 + Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS);
1.363 +#endif
1.364 +
1.365 + iPtr->activeVarTracePtr = NULL;
1.366 + iPtr->returnCode = TCL_OK;
1.367 + iPtr->errorInfo = NULL;
1.368 + iPtr->errorCode = NULL;
1.369 +
1.370 + iPtr->appendResult = NULL;
1.371 + iPtr->appendAvl = 0;
1.372 + iPtr->appendUsed = 0;
1.373 +
1.374 + Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
1.375 + iPtr->packageUnknown = NULL;
1.376 +#ifdef TCL_TIP268
1.377 + /* TIP #268 */
1.378 + iPtr->packagePrefer = (getenv ("TCL_PKG_PREFER_LATEST") == NULL ?
1.379 + PKG_PREFER_STABLE :
1.380 + PKG_PREFER_LATEST);
1.381 +#endif
1.382 + iPtr->cmdCount = 0;
1.383 + iPtr->termOffset = 0;
1.384 + TclInitLiteralTable(&(iPtr->literalTable));
1.385 + iPtr->compileEpoch = 0;
1.386 + iPtr->compiledProcPtr = NULL;
1.387 + iPtr->resolverPtr = NULL;
1.388 + iPtr->evalFlags = 0;
1.389 + iPtr->scriptFile = NULL;
1.390 + iPtr->flags = 0;
1.391 + iPtr->tracePtr = NULL;
1.392 + iPtr->tracesForbiddingInline = 0;
1.393 + iPtr->activeCmdTracePtr = NULL;
1.394 + iPtr->activeInterpTracePtr = NULL;
1.395 + iPtr->assocData = (Tcl_HashTable *) NULL;
1.396 + iPtr->execEnvPtr = NULL; /* set after namespaces initialized */
1.397 + iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */
1.398 + Tcl_IncrRefCount(iPtr->emptyObjPtr);
1.399 + iPtr->resultSpace[0] = 0;
1.400 + iPtr->threadId = Tcl_GetCurrentThread();
1.401 +
1.402 + iPtr->globalNsPtr = NULL; /* force creation of global ns below */
1.403 + iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
1.404 + (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
1.405 + if (iPtr->globalNsPtr == NULL) {
1.406 + panic("Tcl_CreateInterp: can't create global namespace");
1.407 + }
1.408 +
1.409 + /*
1.410 + * Initialize support for code compilation and execution. We call
1.411 + * TclCreateExecEnv after initializing namespaces since it tries to
1.412 + * reference a Tcl variable (it links to the Tcl "tcl_traceExec"
1.413 + * variable).
1.414 + */
1.415 +
1.416 + iPtr->execEnvPtr = TclCreateExecEnv(interp);
1.417 +
1.418 + /*
1.419 + * Initialize the compilation and execution statistics kept for this
1.420 + * interpreter.
1.421 + */
1.422 +
1.423 +#ifdef TCL_COMPILE_STATS
1.424 + statsPtr = &(iPtr->stats);
1.425 + statsPtr->numExecutions = 0;
1.426 + statsPtr->numCompilations = 0;
1.427 + statsPtr->numByteCodesFreed = 0;
1.428 + (VOID *) memset(statsPtr->instructionCount, 0,
1.429 + sizeof(statsPtr->instructionCount));
1.430 +
1.431 + statsPtr->totalSrcBytes = 0.0;
1.432 + statsPtr->totalByteCodeBytes = 0.0;
1.433 + statsPtr->currentSrcBytes = 0.0;
1.434 + statsPtr->currentByteCodeBytes = 0.0;
1.435 + (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount));
1.436 + (VOID *) memset(statsPtr->byteCodeCount, 0,
1.437 + sizeof(statsPtr->byteCodeCount));
1.438 + (VOID *) memset(statsPtr->lifetimeCount, 0,
1.439 + sizeof(statsPtr->lifetimeCount));
1.440 +
1.441 + statsPtr->currentInstBytes = 0.0;
1.442 + statsPtr->currentLitBytes = 0.0;
1.443 + statsPtr->currentExceptBytes = 0.0;
1.444 + statsPtr->currentAuxBytes = 0.0;
1.445 + statsPtr->currentCmdMapBytes = 0.0;
1.446 +
1.447 + statsPtr->numLiteralsCreated = 0;
1.448 + statsPtr->totalLitStringBytes = 0.0;
1.449 + statsPtr->currentLitStringBytes = 0.0;
1.450 + (VOID *) memset(statsPtr->literalCount, 0,
1.451 + sizeof(statsPtr->literalCount));
1.452 +#endif /* TCL_COMPILE_STATS */
1.453 +
1.454 + /*
1.455 + * Initialise the stub table pointer.
1.456 + */
1.457 +
1.458 + iPtr->stubTable = &tclStubs;
1.459 +
1.460 +
1.461 + /*
1.462 + * Create the core commands. Do it here, rather than calling
1.463 + * Tcl_CreateCommand, because it's faster (there's no need to check for
1.464 + * a pre-existing command by the same name). If a command has a
1.465 + * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
1.466 + * TclInvokeStringCommand. This is an object-based wrapper procedure
1.467 + * that extracts strings, calls the string procedure, and creates an
1.468 + * object for the result. Similarly, if a command has a Tcl_ObjCmdProc
1.469 + * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
1.470 + */
1.471 +
1.472 + for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL;
1.473 + cmdInfoPtr++) {
1.474 + int new;
1.475 + Tcl_HashEntry *hPtr;
1.476 +
1.477 + if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL)
1.478 + && (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL)
1.479 + && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) {
1.480 + panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n");
1.481 + }
1.482 +
1.483 + hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
1.484 + cmdInfoPtr->name, &new);
1.485 + if (new) {
1.486 + cmdPtr = (Command *) ckalloc(sizeof(Command));
1.487 + cmdPtr->hPtr = hPtr;
1.488 + cmdPtr->nsPtr = iPtr->globalNsPtr;
1.489 + cmdPtr->refCount = 1;
1.490 + cmdPtr->cmdEpoch = 0;
1.491 + cmdPtr->compileProc = cmdInfoPtr->compileProc;
1.492 + if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) {
1.493 + cmdPtr->proc = TclInvokeObjectCommand;
1.494 + cmdPtr->clientData = (ClientData) cmdPtr;
1.495 + } else {
1.496 + cmdPtr->proc = cmdInfoPtr->proc;
1.497 + cmdPtr->clientData = (ClientData) NULL;
1.498 + }
1.499 + if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
1.500 + cmdPtr->objProc = TclInvokeStringCommand;
1.501 + cmdPtr->objClientData = (ClientData) cmdPtr;
1.502 + } else {
1.503 + cmdPtr->objProc = cmdInfoPtr->objProc;
1.504 + cmdPtr->objClientData = (ClientData) NULL;
1.505 + }
1.506 + cmdPtr->deleteProc = NULL;
1.507 + cmdPtr->deleteData = (ClientData) NULL;
1.508 + cmdPtr->flags = 0;
1.509 + cmdPtr->importRefPtr = NULL;
1.510 + cmdPtr->tracePtr = NULL;
1.511 + Tcl_SetHashValue(hPtr, cmdPtr);
1.512 + }
1.513 + }
1.514 +
1.515 + /*
1.516 + * Register the builtin math functions.
1.517 + */
1.518 +
1.519 + i = 0;
1.520 + for (builtinFuncPtr = tclBuiltinFuncTable; builtinFuncPtr->name != NULL;
1.521 + builtinFuncPtr++) {
1.522 + Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name,
1.523 + builtinFuncPtr->numArgs, builtinFuncPtr->argTypes,
1.524 + (Tcl_MathProc *) NULL, (ClientData) 0);
1.525 + hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,
1.526 + builtinFuncPtr->name);
1.527 + if (hPtr == NULL) {
1.528 + panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name);
1.529 + return NULL;
1.530 + }
1.531 + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
1.532 + mathFuncPtr->builtinFuncIndex = i;
1.533 + i++;
1.534 + }
1.535 + iPtr->flags |= EXPR_INITIALIZED;
1.536 +
1.537 + /*
1.538 + * Do Multiple/Safe Interps Tcl init stuff
1.539 + */
1.540 +
1.541 + TclInterpInit(interp);
1.542 +
1.543 + /*
1.544 + * We used to create the "errorInfo" and "errorCode" global vars at this
1.545 + * point because so much of the Tcl implementation assumes they already
1.546 + * exist. This is not quite enough, however, since they can be unset
1.547 + * at any time.
1.548 + *
1.549 + * There are 2 choices:
1.550 + * + Check every place where a GetVar of those is used
1.551 + * and the NULL result is not checked (like in tclLoad.c)
1.552 + * + Make SetVar,... NULL friendly
1.553 + * We choose the second option because :
1.554 + * + It is easy and low cost to check for NULL pointer before
1.555 + * calling strlen()
1.556 + * + It can be helpfull to other people using those API
1.557 + * + Passing a NULL value to those closest 'meaning' is empty string
1.558 + * (specially with the new objects where 0 bytes strings are ok)
1.559 + * So the following init is commented out: -- dl
1.560 + *
1.561 + * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL,
1.562 + * "", TCL_GLOBAL_ONLY);
1.563 + * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL,
1.564 + * "NONE", TCL_GLOBAL_ONLY);
1.565 + */
1.566 +
1.567 +#ifndef TCL_GENERIC_ONLY
1.568 + TclSetupEnv(interp);
1.569 +#endif
1.570 +
1.571 + /*
1.572 + * Compute the byte order of this machine.
1.573 + */
1.574 +
1.575 + order.s = 1;
1.576 + Tcl_SetVar2(interp, "tcl_platform", "byteOrder",
1.577 + ((order.c[0] == 1) ? "littleEndian" : "bigEndian"),
1.578 + TCL_GLOBAL_ONLY);
1.579 +
1.580 + Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize",
1.581 + Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY);
1.582 +
1.583 + /*
1.584 + * Set up other variables such as tcl_version and tcl_library
1.585 + */
1.586 +
1.587 + Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
1.588 + Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY);
1.589 + Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL,
1.590 + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
1.591 + TclPrecTraceProc, (ClientData) NULL);
1.592 + TclpSetVariables(interp);
1.593 +
1.594 +#ifdef TCL_THREADS
1.595 + /*
1.596 + * The existence of the "threaded" element of the tcl_platform array indicates
1.597 + * that this particular Tcl shell has been compiled with threads turned on.
1.598 + * Using "info exists tcl_platform(threaded)" a Tcl script can introspect on the
1.599 + * interpreter level of thread safety.
1.600 + */
1.601 +
1.602 +
1.603 + Tcl_SetVar2(interp, "tcl_platform", "threaded", "1",
1.604 + TCL_GLOBAL_ONLY);
1.605 +#endif
1.606 +
1.607 + /*
1.608 + * Register Tcl's version number.
1.609 + * TIP#268: Expose information about its status,
1.610 + * for runtime switches in the core library
1.611 + * and tests.
1.612 + */
1.613 +
1.614 + Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs);
1.615 +
1.616 +#ifdef TCL_TIP268
1.617 + Tcl_SetVar2(interp, "tcl_platform", "tip,268", "1",
1.618 + TCL_GLOBAL_ONLY);
1.619 +#endif
1.620 +#ifdef TCL_TIP280
1.621 + Tcl_SetVar2(interp, "tcl_platform", "tip,280", "1",
1.622 + TCL_GLOBAL_ONLY);
1.623 +#endif
1.624 +#ifdef Tcl_InitStubs
1.625 +#undef Tcl_InitStubs
1.626 +#endif
1.627 + Tcl_InitStubs(interp, TCL_VERSION, 1);
1.628 +
1.629 + return interp;
1.630 +}
1.631 +
1.632 +/*
1.633 + *----------------------------------------------------------------------
1.634 + *
1.635 + * TclHideUnsafeCommands --
1.636 + *
1.637 + * Hides base commands that are not marked as safe from this
1.638 + * interpreter.
1.639 + *
1.640 + * Results:
1.641 + * TCL_OK if it succeeds, TCL_ERROR else.
1.642 + *
1.643 + * Side effects:
1.644 + * Hides functionality in an interpreter.
1.645 + *
1.646 + *----------------------------------------------------------------------
1.647 + */
1.648 +
1.649 +int
1.650 +TclHideUnsafeCommands(interp)
1.651 + Tcl_Interp *interp; /* Hide commands in this interpreter. */
1.652 +{
1.653 + register CmdInfo *cmdInfoPtr;
1.654 +
1.655 + if (interp == (Tcl_Interp *) NULL) {
1.656 + return TCL_ERROR;
1.657 + }
1.658 + for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
1.659 + if (!cmdInfoPtr->isSafe) {
1.660 + Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
1.661 + }
1.662 + }
1.663 + return TCL_OK;
1.664 +}
1.665 +
1.666 +/*
1.667 + *--------------------------------------------------------------
1.668 + *
1.669 + * Tcl_CallWhenDeleted --
1.670 + *
1.671 + * Arrange for a procedure to be called before a given
1.672 + * interpreter is deleted. The procedure is called as soon
1.673 + * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is
1.674 + * called on an interpreter that has already been deleted,
1.675 + * the procedure will be called when the last Tcl_Release is
1.676 + * done on the interpreter.
1.677 + *
1.678 + * Results:
1.679 + * None.
1.680 + *
1.681 + * Side effects:
1.682 + * When Tcl_DeleteInterp is invoked to delete interp,
1.683 + * proc will be invoked. See the manual entry for
1.684 + * details.
1.685 + *
1.686 + *--------------------------------------------------------------
1.687 + */
1.688 +
1.689 +EXPORT_C void
1.690 +Tcl_CallWhenDeleted(interp, proc, clientData)
1.691 + Tcl_Interp *interp; /* Interpreter to watch. */
1.692 + Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
1.693 + * is about to be deleted. */
1.694 + ClientData clientData; /* One-word value to pass to proc. */
1.695 +{
1.696 + Interp *iPtr = (Interp *) interp;
1.697 + static Tcl_ThreadDataKey assocDataCounterKey;
1.698 + int *assocDataCounterPtr =
1.699 + Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int));
1.700 + int new;
1.701 + char buffer[32 + TCL_INTEGER_SPACE];
1.702 + AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
1.703 + Tcl_HashEntry *hPtr;
1.704 +
1.705 + sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr);
1.706 + (*assocDataCounterPtr)++;
1.707 +
1.708 + if (iPtr->assocData == (Tcl_HashTable *) NULL) {
1.709 + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
1.710 + Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
1.711 + }
1.712 + hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new);
1.713 + dPtr->proc = proc;
1.714 + dPtr->clientData = clientData;
1.715 + Tcl_SetHashValue(hPtr, dPtr);
1.716 +}
1.717 +
1.718 +/*
1.719 + *--------------------------------------------------------------
1.720 + *
1.721 + * Tcl_DontCallWhenDeleted --
1.722 + *
1.723 + * Cancel the arrangement for a procedure to be called when
1.724 + * a given interpreter is deleted.
1.725 + *
1.726 + * Results:
1.727 + * None.
1.728 + *
1.729 + * Side effects:
1.730 + * If proc and clientData were previously registered as a
1.731 + * callback via Tcl_CallWhenDeleted, they are unregistered.
1.732 + * If they weren't previously registered then nothing
1.733 + * happens.
1.734 + *
1.735 + *--------------------------------------------------------------
1.736 + */
1.737 +
1.738 +EXPORT_C void
1.739 +Tcl_DontCallWhenDeleted(interp, proc, clientData)
1.740 + Tcl_Interp *interp; /* Interpreter to watch. */
1.741 + Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
1.742 + * is about to be deleted. */
1.743 + ClientData clientData; /* One-word value to pass to proc. */
1.744 +{
1.745 + Interp *iPtr = (Interp *) interp;
1.746 + Tcl_HashTable *hTablePtr;
1.747 + Tcl_HashSearch hSearch;
1.748 + Tcl_HashEntry *hPtr;
1.749 + AssocData *dPtr;
1.750 +
1.751 + hTablePtr = iPtr->assocData;
1.752 + if (hTablePtr == (Tcl_HashTable *) NULL) {
1.753 + return;
1.754 + }
1.755 + for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
1.756 + hPtr = Tcl_NextHashEntry(&hSearch)) {
1.757 + dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
1.758 + if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
1.759 + ckfree((char *) dPtr);
1.760 + Tcl_DeleteHashEntry(hPtr);
1.761 + return;
1.762 + }
1.763 + }
1.764 +}
1.765 +
1.766 +/*
1.767 + *----------------------------------------------------------------------
1.768 + *
1.769 + * Tcl_SetAssocData --
1.770 + *
1.771 + * Creates a named association between user-specified data, a delete
1.772 + * function and this interpreter. If the association already exists
1.773 + * the data is overwritten with the new data. The delete function will
1.774 + * be invoked when the interpreter is deleted.
1.775 + *
1.776 + * Results:
1.777 + * None.
1.778 + *
1.779 + * Side effects:
1.780 + * Sets the associated data, creates the association if needed.
1.781 + *
1.782 + *----------------------------------------------------------------------
1.783 + */
1.784 +
1.785 +EXPORT_C void
1.786 +Tcl_SetAssocData(interp, name, proc, clientData)
1.787 + Tcl_Interp *interp; /* Interpreter to associate with. */
1.788 + CONST char *name; /* Name for association. */
1.789 + Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is
1.790 + * about to be deleted. */
1.791 + ClientData clientData; /* One-word value to pass to proc. */
1.792 +{
1.793 + Interp *iPtr = (Interp *) interp;
1.794 + AssocData *dPtr;
1.795 + Tcl_HashEntry *hPtr;
1.796 + int new;
1.797 +
1.798 + if (iPtr->assocData == (Tcl_HashTable *) NULL) {
1.799 + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
1.800 + Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
1.801 + }
1.802 + hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
1.803 + if (new == 0) {
1.804 + dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
1.805 + } else {
1.806 + dPtr = (AssocData *) ckalloc(sizeof(AssocData));
1.807 + }
1.808 + dPtr->proc = proc;
1.809 + dPtr->clientData = clientData;
1.810 +
1.811 + Tcl_SetHashValue(hPtr, dPtr);
1.812 +}
1.813 +
1.814 +/*
1.815 + *----------------------------------------------------------------------
1.816 + *
1.817 + * Tcl_DeleteAssocData --
1.818 + *
1.819 + * Deletes a named association of user-specified data with
1.820 + * the specified interpreter.
1.821 + *
1.822 + * Results:
1.823 + * None.
1.824 + *
1.825 + * Side effects:
1.826 + * Deletes the association.
1.827 + *
1.828 + *----------------------------------------------------------------------
1.829 + */
1.830 +
1.831 +EXPORT_C void
1.832 +Tcl_DeleteAssocData(interp, name)
1.833 + Tcl_Interp *interp; /* Interpreter to associate with. */
1.834 + CONST char *name; /* Name of association. */
1.835 +{
1.836 + Interp *iPtr = (Interp *) interp;
1.837 + AssocData *dPtr;
1.838 + Tcl_HashEntry *hPtr;
1.839 +
1.840 + if (iPtr->assocData == (Tcl_HashTable *) NULL) {
1.841 + return;
1.842 + }
1.843 + hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
1.844 + if (hPtr == (Tcl_HashEntry *) NULL) {
1.845 + return;
1.846 + }
1.847 + dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
1.848 + if (dPtr->proc != NULL) {
1.849 + (dPtr->proc) (dPtr->clientData, interp);
1.850 + }
1.851 + ckfree((char *) dPtr);
1.852 + Tcl_DeleteHashEntry(hPtr);
1.853 +}
1.854 +
1.855 +/*
1.856 + *----------------------------------------------------------------------
1.857 + *
1.858 + * Tcl_GetAssocData --
1.859 + *
1.860 + * Returns the client data associated with this name in the
1.861 + * specified interpreter.
1.862 + *
1.863 + * Results:
1.864 + * The client data in the AssocData record denoted by the named
1.865 + * association, or NULL.
1.866 + *
1.867 + * Side effects:
1.868 + * None.
1.869 + *
1.870 + *----------------------------------------------------------------------
1.871 + */
1.872 +
1.873 +EXPORT_C ClientData
1.874 +Tcl_GetAssocData(interp, name, procPtr)
1.875 + Tcl_Interp *interp; /* Interpreter associated with. */
1.876 + CONST char *name; /* Name of association. */
1.877 + Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address
1.878 + * of current deletion callback. */
1.879 +{
1.880 + Interp *iPtr = (Interp *) interp;
1.881 + AssocData *dPtr;
1.882 + Tcl_HashEntry *hPtr;
1.883 +
1.884 + if (iPtr->assocData == (Tcl_HashTable *) NULL) {
1.885 + return (ClientData) NULL;
1.886 + }
1.887 + hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
1.888 + if (hPtr == (Tcl_HashEntry *) NULL) {
1.889 + return (ClientData) NULL;
1.890 + }
1.891 + dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
1.892 + if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
1.893 + *procPtr = dPtr->proc;
1.894 + }
1.895 + return dPtr->clientData;
1.896 +}
1.897 +
1.898 +/*
1.899 + *----------------------------------------------------------------------
1.900 + *
1.901 + * Tcl_InterpDeleted --
1.902 + *
1.903 + * Returns nonzero if the interpreter has been deleted with a call
1.904 + * to Tcl_DeleteInterp.
1.905 + *
1.906 + * Results:
1.907 + * Nonzero if the interpreter is deleted, zero otherwise.
1.908 + *
1.909 + * Side effects:
1.910 + * None.
1.911 + *
1.912 + *----------------------------------------------------------------------
1.913 + */
1.914 +
1.915 +EXPORT_C int
1.916 +Tcl_InterpDeleted(interp)
1.917 + Tcl_Interp *interp;
1.918 +{
1.919 + return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
1.920 +}
1.921 +
1.922 +/*
1.923 + *----------------------------------------------------------------------
1.924 + *
1.925 + * Tcl_DeleteInterp --
1.926 + *
1.927 + * Ensures that the interpreter will be deleted eventually. If there
1.928 + * are no Tcl_Preserve calls in effect for this interpreter, it is
1.929 + * deleted immediately, otherwise the interpreter is deleted when
1.930 + * the last Tcl_Preserve is matched by a call to Tcl_Release. In either
1.931 + * case, the procedure runs the currently registered deletion callbacks.
1.932 + *
1.933 + * Results:
1.934 + * None.
1.935 + *
1.936 + * Side effects:
1.937 + * The interpreter is marked as deleted. The caller may still use it
1.938 + * safely if there are calls to Tcl_Preserve in effect for the
1.939 + * interpreter, but further calls to Tcl_Eval etc in this interpreter
1.940 + * will fail.
1.941 + *
1.942 + *----------------------------------------------------------------------
1.943 + */
1.944 +
1.945 +EXPORT_C void
1.946 +Tcl_DeleteInterp(interp)
1.947 + Tcl_Interp *interp; /* Token for command interpreter (returned
1.948 + * by a previous call to Tcl_CreateInterp). */
1.949 +{
1.950 + Interp *iPtr = (Interp *) interp;
1.951 +
1.952 + /*
1.953 + * If the interpreter has already been marked deleted, just punt.
1.954 + */
1.955 +
1.956 + if (iPtr->flags & DELETED) {
1.957 + return;
1.958 + }
1.959 +
1.960 + /*
1.961 + * Mark the interpreter as deleted. No further evals will be allowed.
1.962 + */
1.963 +
1.964 + iPtr->flags |= DELETED;
1.965 +
1.966 + /*
1.967 + * Ensure that the interpreter is eventually deleted.
1.968 + */
1.969 +
1.970 + Tcl_EventuallyFree((ClientData) interp,
1.971 + (Tcl_FreeProc *) DeleteInterpProc);
1.972 +}
1.973 +
1.974 +/*
1.975 + *----------------------------------------------------------------------
1.976 + *
1.977 + * DeleteInterpProc --
1.978 + *
1.979 + * Helper procedure to delete an interpreter. This procedure is
1.980 + * called when the last call to Tcl_Preserve on this interpreter
1.981 + * is matched by a call to Tcl_Release. The procedure cleans up
1.982 + * all resources used in the interpreter and calls all currently
1.983 + * registered interpreter deletion callbacks.
1.984 + *
1.985 + * Results:
1.986 + * None.
1.987 + *
1.988 + * Side effects:
1.989 + * Whatever the interpreter deletion callbacks do. Frees resources
1.990 + * used by the interpreter.
1.991 + *
1.992 + *----------------------------------------------------------------------
1.993 + */
1.994 +
1.995 +static void
1.996 +DeleteInterpProc(interp)
1.997 + Tcl_Interp *interp; /* Interpreter to delete. */
1.998 +{
1.999 + Interp *iPtr = (Interp *) interp;
1.1000 + Tcl_HashEntry *hPtr;
1.1001 + Tcl_HashSearch search;
1.1002 + Tcl_HashTable *hTablePtr;
1.1003 + ResolverScheme *resPtr, *nextResPtr;
1.1004 +
1.1005 + /*
1.1006 + * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
1.1007 + */
1.1008 +
1.1009 + if (iPtr->numLevels > 0) {
1.1010 + panic("DeleteInterpProc called with active evals");
1.1011 + }
1.1012 +
1.1013 + /*
1.1014 + * The interpreter should already be marked deleted; otherwise how
1.1015 + * did we get here?
1.1016 + */
1.1017 +
1.1018 + if (!(iPtr->flags & DELETED)) {
1.1019 + panic("DeleteInterpProc called on interpreter not marked deleted");
1.1020 + }
1.1021 +
1.1022 + TclHandleFree(iPtr->handle);
1.1023 +
1.1024 + /*
1.1025 + * Dismantle everything in the global namespace except for the
1.1026 + * "errorInfo" and "errorCode" variables. These remain until the
1.1027 + * namespace is actually destroyed, in case any errors occur.
1.1028 + *
1.1029 + * Dismantle the namespace here, before we clear the assocData. If any
1.1030 + * background errors occur here, they will be deleted below.
1.1031 + */
1.1032 +
1.1033 + TclTeardownNamespace(iPtr->globalNsPtr);
1.1034 +
1.1035 + /*
1.1036 + * Delete all the hidden commands.
1.1037 + */
1.1038 +
1.1039 + hTablePtr = iPtr->hiddenCmdTablePtr;
1.1040 + if (hTablePtr != NULL) {
1.1041 + /*
1.1042 + * Non-pernicious deletion. The deletion callbacks will not be
1.1043 + * allowed to create any new hidden or non-hidden commands.
1.1044 + * Tcl_DeleteCommandFromToken() will remove the entry from the
1.1045 + * hiddenCmdTablePtr.
1.1046 + */
1.1047 +
1.1048 + hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
1.1049 + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
1.1050 + Tcl_DeleteCommandFromToken(interp,
1.1051 + (Tcl_Command) Tcl_GetHashValue(hPtr));
1.1052 + }
1.1053 + Tcl_DeleteHashTable(hTablePtr);
1.1054 + ckfree((char *) hTablePtr);
1.1055 + }
1.1056 + /*
1.1057 + * Tear down the math function table.
1.1058 + */
1.1059 +
1.1060 + for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
1.1061 + hPtr != NULL;
1.1062 + hPtr = Tcl_NextHashEntry(&search)) {
1.1063 + ckfree((char *) Tcl_GetHashValue(hPtr));
1.1064 + }
1.1065 + Tcl_DeleteHashTable(&iPtr->mathFuncTable);
1.1066 +
1.1067 + /*
1.1068 + * Invoke deletion callbacks; note that a callback can create new
1.1069 + * callbacks, so we iterate.
1.1070 + */
1.1071 +
1.1072 + while (iPtr->assocData != (Tcl_HashTable *) NULL) {
1.1073 + AssocData *dPtr;
1.1074 +
1.1075 + hTablePtr = iPtr->assocData;
1.1076 + iPtr->assocData = (Tcl_HashTable *) NULL;
1.1077 + for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
1.1078 + hPtr != NULL;
1.1079 + hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
1.1080 + dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
1.1081 + Tcl_DeleteHashEntry(hPtr);
1.1082 + if (dPtr->proc != NULL) {
1.1083 + (*dPtr->proc)(dPtr->clientData, interp);
1.1084 + }
1.1085 + ckfree((char *) dPtr);
1.1086 + }
1.1087 + Tcl_DeleteHashTable(hTablePtr);
1.1088 + ckfree((char *) hTablePtr);
1.1089 + }
1.1090 +
1.1091 + /*
1.1092 + * Finish deleting the global namespace.
1.1093 + */
1.1094 +
1.1095 + Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);
1.1096 +
1.1097 + /*
1.1098 + * Free up the result *after* deleting variables, since variable
1.1099 + * deletion could have transferred ownership of the result string
1.1100 + * to Tcl.
1.1101 + */
1.1102 +
1.1103 + Tcl_FreeResult(interp);
1.1104 + interp->result = NULL;
1.1105 + Tcl_DecrRefCount(iPtr->objResultPtr);
1.1106 + iPtr->objResultPtr = NULL;
1.1107 + if (iPtr->errorInfo != NULL) {
1.1108 + ckfree(iPtr->errorInfo);
1.1109 + iPtr->errorInfo = NULL;
1.1110 + }
1.1111 + if (iPtr->errorCode != NULL) {
1.1112 + ckfree(iPtr->errorCode);
1.1113 + iPtr->errorCode = NULL;
1.1114 + }
1.1115 + if (iPtr->appendResult != NULL) {
1.1116 + ckfree(iPtr->appendResult);
1.1117 + iPtr->appendResult = NULL;
1.1118 + }
1.1119 + TclFreePackageInfo(iPtr);
1.1120 + while (iPtr->tracePtr != NULL) {
1.1121 + Tcl_DeleteTrace((Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr);
1.1122 + }
1.1123 + if (iPtr->execEnvPtr != NULL) {
1.1124 + TclDeleteExecEnv(iPtr->execEnvPtr);
1.1125 + }
1.1126 + Tcl_DecrRefCount(iPtr->emptyObjPtr);
1.1127 + iPtr->emptyObjPtr = NULL;
1.1128 +
1.1129 + resPtr = iPtr->resolverPtr;
1.1130 + while (resPtr) {
1.1131 + nextResPtr = resPtr->nextPtr;
1.1132 + ckfree(resPtr->name);
1.1133 + ckfree((char *) resPtr);
1.1134 + resPtr = nextResPtr;
1.1135 + }
1.1136 +
1.1137 + /*
1.1138 + * Free up literal objects created for scripts compiled by the
1.1139 + * interpreter.
1.1140 + */
1.1141 +
1.1142 + TclDeleteLiteralTable(interp, &(iPtr->literalTable));
1.1143 +
1.1144 +#ifdef TCL_TIP280
1.1145 + /* TIP #280 - Release the arrays for ByteCode/Proc extension, and contents.
1.1146 + */
1.1147 + {
1.1148 + Tcl_HashEntry *hPtr;
1.1149 + Tcl_HashSearch hSearch;
1.1150 + CmdFrame* cfPtr;
1.1151 + ExtCmdLoc* eclPtr;
1.1152 + int i;
1.1153 +
1.1154 + for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &hSearch);
1.1155 + hPtr != NULL;
1.1156 + hPtr = Tcl_NextHashEntry(&hSearch)) {
1.1157 +
1.1158 + cfPtr = (CmdFrame*) Tcl_GetHashValue (hPtr);
1.1159 +
1.1160 + if (cfPtr->type == TCL_LOCATION_SOURCE) {
1.1161 + Tcl_DecrRefCount (cfPtr->data.eval.path);
1.1162 + }
1.1163 + ckfree ((char*) cfPtr->line);
1.1164 + ckfree ((char*) cfPtr);
1.1165 + Tcl_DeleteHashEntry (hPtr);
1.1166 +
1.1167 + }
1.1168 + Tcl_DeleteHashTable (iPtr->linePBodyPtr);
1.1169 + ckfree ((char*) iPtr->linePBodyPtr);
1.1170 + iPtr->linePBodyPtr = NULL;
1.1171 +
1.1172 + /* See also tclCompile.c, TclCleanupByteCode */
1.1173 +
1.1174 + for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &hSearch);
1.1175 + hPtr != NULL;
1.1176 + hPtr = Tcl_NextHashEntry(&hSearch)) {
1.1177 +
1.1178 + eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hPtr);
1.1179 +
1.1180 + if (eclPtr->type == TCL_LOCATION_SOURCE) {
1.1181 + Tcl_DecrRefCount (eclPtr->path);
1.1182 + }
1.1183 + for (i=0; i< eclPtr->nuloc; i++) {
1.1184 + ckfree ((char*) eclPtr->loc[i].line);
1.1185 + }
1.1186 +
1.1187 + if (eclPtr->loc != NULL) {
1.1188 + ckfree ((char*) eclPtr->loc);
1.1189 + }
1.1190 +
1.1191 + ckfree ((char*) eclPtr);
1.1192 + Tcl_DeleteHashEntry (hPtr);
1.1193 + }
1.1194 + Tcl_DeleteHashTable (iPtr->lineBCPtr);
1.1195 + ckfree((char*) iPtr->lineBCPtr);
1.1196 + iPtr->lineBCPtr = NULL;
1.1197 + }
1.1198 +#endif
1.1199 + ckfree((char *) iPtr);
1.1200 +}
1.1201 +
1.1202 +/*
1.1203 + *---------------------------------------------------------------------------
1.1204 + *
1.1205 + * Tcl_HideCommand --
1.1206 + *
1.1207 + * Makes a command hidden so that it cannot be invoked from within
1.1208 + * an interpreter, only from within an ancestor.
1.1209 + *
1.1210 + * Results:
1.1211 + * A standard Tcl result; also leaves a message in the interp's result
1.1212 + * if an error occurs.
1.1213 + *
1.1214 + * Side effects:
1.1215 + * Removes a command from the command table and create an entry
1.1216 + * into the hidden command table under the specified token name.
1.1217 + *
1.1218 + *---------------------------------------------------------------------------
1.1219 + */
1.1220 +
1.1221 +EXPORT_C int
1.1222 +Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
1.1223 + Tcl_Interp *interp; /* Interpreter in which to hide command. */
1.1224 + CONST char *cmdName; /* Name of command to hide. */
1.1225 + CONST char *hiddenCmdToken; /* Token name of the to-be-hidden command. */
1.1226 +{
1.1227 + Interp *iPtr = (Interp *) interp;
1.1228 + Tcl_Command cmd;
1.1229 + Command *cmdPtr;
1.1230 + Tcl_HashTable *hiddenCmdTablePtr;
1.1231 + Tcl_HashEntry *hPtr;
1.1232 + int new;
1.1233 +
1.1234 + if (iPtr->flags & DELETED) {
1.1235 +
1.1236 + /*
1.1237 + * The interpreter is being deleted. Do not create any new
1.1238 + * structures, because it is not safe to modify the interpreter.
1.1239 + */
1.1240 +
1.1241 + return TCL_ERROR;
1.1242 + }
1.1243 +
1.1244 + /*
1.1245 + * Disallow hiding of commands that are currently in a namespace or
1.1246 + * renaming (as part of hiding) into a namespace.
1.1247 + *
1.1248 + * (because the current implementation with a single global table
1.1249 + * and the needed uniqueness of names cause problems with namespaces)
1.1250 + *
1.1251 + * we don't need to check for "::" in cmdName because the real check is
1.1252 + * on the nsPtr below.
1.1253 + *
1.1254 + * hiddenCmdToken is just a string which is not interpreted in any way.
1.1255 + * It may contain :: but the string is not interpreted as a namespace
1.1256 + * qualifier command name. Thus, hiding foo::bar to foo::bar and then
1.1257 + * trying to expose or invoke ::foo::bar will NOT work; but if the
1.1258 + * application always uses the same strings it will get consistent
1.1259 + * behaviour.
1.1260 + *
1.1261 + * But as we currently limit ourselves to the global namespace only
1.1262 + * for the source, in order to avoid potential confusion,
1.1263 + * lets prevent "::" in the token too. --dl
1.1264 + */
1.1265 +
1.1266 + if (strstr(hiddenCmdToken, "::") != NULL) {
1.1267 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1268 + "cannot use namespace qualifiers in hidden command",
1.1269 + " token (rename)", (char *) NULL);
1.1270 + return TCL_ERROR;
1.1271 + }
1.1272 +
1.1273 + /*
1.1274 + * Find the command to hide. An error is returned if cmdName can't
1.1275 + * be found. Look up the command only from the global namespace.
1.1276 + * Full path of the command must be given if using namespaces.
1.1277 + */
1.1278 +
1.1279 + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
1.1280 + /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);
1.1281 + if (cmd == (Tcl_Command) NULL) {
1.1282 + return TCL_ERROR;
1.1283 + }
1.1284 + cmdPtr = (Command *) cmd;
1.1285 +
1.1286 + /*
1.1287 + * Check that the command is really in global namespace
1.1288 + */
1.1289 +
1.1290 + if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
1.1291 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1292 + "can only hide global namespace commands",
1.1293 + " (use rename then hide)", (char *) NULL);
1.1294 + return TCL_ERROR;
1.1295 + }
1.1296 +
1.1297 + /*
1.1298 + * Initialize the hidden command table if necessary.
1.1299 + */
1.1300 +
1.1301 + hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
1.1302 + if (hiddenCmdTablePtr == NULL) {
1.1303 + hiddenCmdTablePtr = (Tcl_HashTable *)
1.1304 + ckalloc((unsigned) sizeof(Tcl_HashTable));
1.1305 + Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
1.1306 + iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
1.1307 + }
1.1308 +
1.1309 + /*
1.1310 + * It is an error to move an exposed command to a hidden command with
1.1311 + * hiddenCmdToken if a hidden command with the name hiddenCmdToken already
1.1312 + * exists.
1.1313 + */
1.1314 +
1.1315 + hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new);
1.1316 + if (!new) {
1.1317 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1318 + "hidden command named \"", hiddenCmdToken, "\" already exists",
1.1319 + (char *) NULL);
1.1320 + return TCL_ERROR;
1.1321 + }
1.1322 +
1.1323 + /*
1.1324 + * Nb : This code is currently 'like' a rename to a specialy set apart
1.1325 + * name table. Changes here and in TclRenameCommand must
1.1326 + * be kept in synch untill the common parts are actually
1.1327 + * factorized out.
1.1328 + */
1.1329 +
1.1330 + /*
1.1331 + * Remove the hash entry for the command from the interpreter command
1.1332 + * table. This is like deleting the command, so bump its command epoch;
1.1333 + * this invalidates any cached references that point to the command.
1.1334 + */
1.1335 +
1.1336 + if (cmdPtr->hPtr != NULL) {
1.1337 + Tcl_DeleteHashEntry(cmdPtr->hPtr);
1.1338 + cmdPtr->hPtr = (Tcl_HashEntry *) NULL;
1.1339 + cmdPtr->cmdEpoch++;
1.1340 + }
1.1341 +
1.1342 + /*
1.1343 + * Now link the hash table entry with the command structure.
1.1344 + * We ensured above that the nsPtr was right.
1.1345 + */
1.1346 +
1.1347 + cmdPtr->hPtr = hPtr;
1.1348 + Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
1.1349 +
1.1350 + /*
1.1351 + * If the command being hidden has a compile procedure, increment the
1.1352 + * interpreter's compileEpoch to invalidate its compiled code. This
1.1353 + * makes sure that we don't later try to execute old code compiled with
1.1354 + * command-specific (i.e., inline) bytecodes for the now-hidden
1.1355 + * command. This field is checked in Tcl_EvalObj and ObjInterpProc,
1.1356 + * and code whose compilation epoch doesn't match is recompiled.
1.1357 + */
1.1358 +
1.1359 + if (cmdPtr->compileProc != NULL) {
1.1360 + iPtr->compileEpoch++;
1.1361 + }
1.1362 + return TCL_OK;
1.1363 +}
1.1364 +
1.1365 +/*
1.1366 + *----------------------------------------------------------------------
1.1367 + *
1.1368 + * Tcl_ExposeCommand --
1.1369 + *
1.1370 + * Makes a previously hidden command callable from inside the
1.1371 + * interpreter instead of only by its ancestors.
1.1372 + *
1.1373 + * Results:
1.1374 + * A standard Tcl result. If an error occurs, a message is left
1.1375 + * in the interp's result.
1.1376 + *
1.1377 + * Side effects:
1.1378 + * Moves commands from one hash table to another.
1.1379 + *
1.1380 + *----------------------------------------------------------------------
1.1381 + */
1.1382 +
1.1383 +EXPORT_C int
1.1384 +Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
1.1385 + Tcl_Interp *interp; /* Interpreter in which to make command
1.1386 + * callable. */
1.1387 + CONST char *hiddenCmdToken; /* Name of hidden command. */
1.1388 + CONST char *cmdName; /* Name of to-be-exposed command. */
1.1389 +{
1.1390 + Interp *iPtr = (Interp *) interp;
1.1391 + Command *cmdPtr;
1.1392 + Namespace *nsPtr;
1.1393 + Tcl_HashEntry *hPtr;
1.1394 + Tcl_HashTable *hiddenCmdTablePtr;
1.1395 + int new;
1.1396 +
1.1397 + if (iPtr->flags & DELETED) {
1.1398 + /*
1.1399 + * The interpreter is being deleted. Do not create any new
1.1400 + * structures, because it is not safe to modify the interpreter.
1.1401 + */
1.1402 +
1.1403 + return TCL_ERROR;
1.1404 + }
1.1405 +
1.1406 + /*
1.1407 + * Check that we have a regular name for the command
1.1408 + * (that the user is not trying to do an expose and a rename
1.1409 + * (to another namespace) at the same time)
1.1410 + */
1.1411 +
1.1412 + if (strstr(cmdName, "::") != NULL) {
1.1413 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1414 + "can not expose to a namespace ",
1.1415 + "(use expose to toplevel, then rename)",
1.1416 + (char *) NULL);
1.1417 + return TCL_ERROR;
1.1418 + }
1.1419 +
1.1420 + /*
1.1421 + * Get the command from the hidden command table:
1.1422 + */
1.1423 +
1.1424 + hPtr = NULL;
1.1425 + hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
1.1426 + if (hiddenCmdTablePtr != NULL) {
1.1427 + hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken);
1.1428 + }
1.1429 + if (hPtr == (Tcl_HashEntry *) NULL) {
1.1430 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1431 + "unknown hidden command \"", hiddenCmdToken,
1.1432 + "\"", (char *) NULL);
1.1433 + return TCL_ERROR;
1.1434 + }
1.1435 + cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
1.1436 +
1.1437 +
1.1438 + /*
1.1439 + * Check that we have a true global namespace
1.1440 + * command (enforced by Tcl_HideCommand() but let's double
1.1441 + * check. (If it was not, we would not really know how to
1.1442 + * handle it).
1.1443 + */
1.1444 + if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
1.1445 + /*
1.1446 + * This case is theoritically impossible,
1.1447 + * we might rather panic() than 'nicely' erroring out ?
1.1448 + */
1.1449 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1450 + "trying to expose a non global command name space command",
1.1451 + (char *) NULL);
1.1452 + return TCL_ERROR;
1.1453 + }
1.1454 +
1.1455 + /* This is the global table */
1.1456 + nsPtr = cmdPtr->nsPtr;
1.1457 +
1.1458 + /*
1.1459 + * It is an error to overwrite an existing exposed command as a result
1.1460 + * of exposing a previously hidden command.
1.1461 + */
1.1462 +
1.1463 + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new);
1.1464 + if (!new) {
1.1465 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1466 + "exposed command \"", cmdName,
1.1467 + "\" already exists", (char *) NULL);
1.1468 + return TCL_ERROR;
1.1469 + }
1.1470 +
1.1471 + /*
1.1472 + * Remove the hash entry for the command from the interpreter hidden
1.1473 + * command table.
1.1474 + */
1.1475 +
1.1476 + if (cmdPtr->hPtr != NULL) {
1.1477 + Tcl_DeleteHashEntry(cmdPtr->hPtr);
1.1478 + cmdPtr->hPtr = NULL;
1.1479 + }
1.1480 +
1.1481 + /*
1.1482 + * Now link the hash table entry with the command structure.
1.1483 + * This is like creating a new command, so deal with any shadowing
1.1484 + * of commands in the global namespace.
1.1485 + */
1.1486 +
1.1487 + cmdPtr->hPtr = hPtr;
1.1488 +
1.1489 + Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
1.1490 +
1.1491 + /*
1.1492 + * Not needed as we are only in the global namespace
1.1493 + * (but would be needed again if we supported namespace command hiding)
1.1494 + *
1.1495 + * TclResetShadowedCmdRefs(interp, cmdPtr);
1.1496 + */
1.1497 +
1.1498 +
1.1499 + /*
1.1500 + * If the command being exposed has a compile procedure, increment
1.1501 + * interpreter's compileEpoch to invalidate its compiled code. This
1.1502 + * makes sure that we don't later try to execute old code compiled
1.1503 + * assuming the command is hidden. This field is checked in Tcl_EvalObj
1.1504 + * and ObjInterpProc, and code whose compilation epoch doesn't match is
1.1505 + * recompiled.
1.1506 + */
1.1507 +
1.1508 + if (cmdPtr->compileProc != NULL) {
1.1509 + iPtr->compileEpoch++;
1.1510 + }
1.1511 + return TCL_OK;
1.1512 +}
1.1513 +
1.1514 +/*
1.1515 + *----------------------------------------------------------------------
1.1516 + *
1.1517 + * Tcl_CreateCommand --
1.1518 + *
1.1519 + * Define a new command in a command table.
1.1520 + *
1.1521 + * Results:
1.1522 + * The return value is a token for the command, which can
1.1523 + * be used in future calls to Tcl_GetCommandName.
1.1524 + *
1.1525 + * Side effects:
1.1526 + * If a command named cmdName already exists for interp, it is deleted.
1.1527 + * In the future, when cmdName is seen as the name of a command by
1.1528 + * Tcl_Eval, proc will be called. To support the bytecode interpreter,
1.1529 + * the command is created with a wrapper Tcl_ObjCmdProc
1.1530 + * (TclInvokeStringCommand) that eventially calls proc. When the
1.1531 + * command is deleted from the table, deleteProc will be called.
1.1532 + * See the manual entry for details on the calling sequence.
1.1533 + *
1.1534 + *----------------------------------------------------------------------
1.1535 + */
1.1536 +
1.1537 +EXPORT_C Tcl_Command
1.1538 +Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
1.1539 + Tcl_Interp *interp; /* Token for command interpreter returned by
1.1540 + * a previous call to Tcl_CreateInterp. */
1.1541 + CONST char *cmdName; /* Name of command. If it contains namespace
1.1542 + * qualifiers, the new command is put in the
1.1543 + * specified namespace; otherwise it is put
1.1544 + * in the global namespace. */
1.1545 + Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */
1.1546 + ClientData clientData; /* Arbitrary value passed to string proc. */
1.1547 + Tcl_CmdDeleteProc *deleteProc;
1.1548 + /* If not NULL, gives a procedure to call
1.1549 + * when this command is deleted. */
1.1550 +{
1.1551 + Interp *iPtr = (Interp *) interp;
1.1552 + ImportRef *oldRefPtr = NULL;
1.1553 + Namespace *nsPtr, *dummy1, *dummy2;
1.1554 + Command *cmdPtr, *refCmdPtr;
1.1555 + Tcl_HashEntry *hPtr;
1.1556 + CONST char *tail;
1.1557 + int new;
1.1558 + ImportedCmdData *dataPtr;
1.1559 +
1.1560 + if (iPtr->flags & DELETED) {
1.1561 + /*
1.1562 + * The interpreter is being deleted. Don't create any new
1.1563 + * commands; it's not safe to muck with the interpreter anymore.
1.1564 + */
1.1565 +
1.1566 + return (Tcl_Command) NULL;
1.1567 + }
1.1568 +
1.1569 + /*
1.1570 + * Determine where the command should reside. If its name contains
1.1571 + * namespace qualifiers, we put it in the specified namespace;
1.1572 + * otherwise, we always put it in the global namespace.
1.1573 + */
1.1574 +
1.1575 + if (strstr(cmdName, "::") != NULL) {
1.1576 + TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,
1.1577 + CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
1.1578 + if ((nsPtr == NULL) || (tail == NULL)) {
1.1579 + return (Tcl_Command) NULL;
1.1580 + }
1.1581 + } else {
1.1582 + nsPtr = iPtr->globalNsPtr;
1.1583 + tail = cmdName;
1.1584 + }
1.1585 +
1.1586 + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
1.1587 + if (!new) {
1.1588 + /*
1.1589 + * Command already exists. Delete the old one.
1.1590 + * Be careful to preserve any existing import links so we can
1.1591 + * restore them down below. That way, you can redefine a
1.1592 + * command and its import status will remain intact.
1.1593 + */
1.1594 +
1.1595 + cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
1.1596 + oldRefPtr = cmdPtr->importRefPtr;
1.1597 + cmdPtr->importRefPtr = NULL;
1.1598 +
1.1599 + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
1.1600 + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
1.1601 + if (!new) {
1.1602 + /*
1.1603 + * If the deletion callback recreated the command, just throw
1.1604 + * away the new command (if we try to delete it again, we
1.1605 + * could get stuck in an infinite loop).
1.1606 + */
1.1607 +
1.1608 + ckfree((char*) Tcl_GetHashValue(hPtr));
1.1609 + }
1.1610 + }
1.1611 + cmdPtr = (Command *) ckalloc(sizeof(Command));
1.1612 + Tcl_SetHashValue(hPtr, cmdPtr);
1.1613 + cmdPtr->hPtr = hPtr;
1.1614 + cmdPtr->nsPtr = nsPtr;
1.1615 + cmdPtr->refCount = 1;
1.1616 + cmdPtr->cmdEpoch = 0;
1.1617 + cmdPtr->compileProc = (CompileProc *) NULL;
1.1618 + cmdPtr->objProc = TclInvokeStringCommand;
1.1619 + cmdPtr->objClientData = (ClientData) cmdPtr;
1.1620 + cmdPtr->proc = proc;
1.1621 + cmdPtr->clientData = clientData;
1.1622 + cmdPtr->deleteProc = deleteProc;
1.1623 + cmdPtr->deleteData = clientData;
1.1624 + cmdPtr->flags = 0;
1.1625 + cmdPtr->importRefPtr = NULL;
1.1626 + cmdPtr->tracePtr = NULL;
1.1627 +
1.1628 + /*
1.1629 + * Plug in any existing import references found above. Be sure
1.1630 + * to update all of these references to point to the new command.
1.1631 + */
1.1632 +
1.1633 + if (oldRefPtr != NULL) {
1.1634 + cmdPtr->importRefPtr = oldRefPtr;
1.1635 + while (oldRefPtr != NULL) {
1.1636 + refCmdPtr = oldRefPtr->importedCmdPtr;
1.1637 + dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
1.1638 + dataPtr->realCmdPtr = cmdPtr;
1.1639 + oldRefPtr = oldRefPtr->nextPtr;
1.1640 + }
1.1641 + }
1.1642 +
1.1643 + /*
1.1644 + * We just created a command, so in its namespace and all of its parent
1.1645 + * namespaces, it may shadow global commands with the same name. If any
1.1646 + * shadowed commands are found, invalidate all cached command references
1.1647 + * in the affected namespaces.
1.1648 + */
1.1649 +
1.1650 + TclResetShadowedCmdRefs(interp, cmdPtr);
1.1651 + return (Tcl_Command) cmdPtr;
1.1652 +}
1.1653 +
1.1654 +/*
1.1655 + *----------------------------------------------------------------------
1.1656 + *
1.1657 + * Tcl_CreateObjCommand --
1.1658 + *
1.1659 + * Define a new object-based command in a command table.
1.1660 + *
1.1661 + * Results:
1.1662 + * The return value is a token for the command, which can
1.1663 + * be used in future calls to Tcl_GetCommandName.
1.1664 + *
1.1665 + * Side effects:
1.1666 + * If no command named "cmdName" already exists for interp, one is
1.1667 + * created. Otherwise, if a command does exist, then if the
1.1668 + * object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume
1.1669 + * Tcl_CreateCommand was called previously for the same command and
1.1670 + * just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we
1.1671 + * delete the old command.
1.1672 + *
1.1673 + * In the future, during bytecode evaluation when "cmdName" is seen as
1.1674 + * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based
1.1675 + * Tcl_ObjCmdProc proc will be called. When the command is deleted from
1.1676 + * the table, deleteProc will be called. See the manual entry for
1.1677 + * details on the calling sequence.
1.1678 + *
1.1679 + *----------------------------------------------------------------------
1.1680 + */
1.1681 +
1.1682 +EXPORT_C Tcl_Command
1.1683 +Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
1.1684 + Tcl_Interp *interp; /* Token for command interpreter (returned
1.1685 + * by previous call to Tcl_CreateInterp). */
1.1686 + CONST char *cmdName; /* Name of command. If it contains namespace
1.1687 + * qualifiers, the new command is put in the
1.1688 + * specified namespace; otherwise it is put
1.1689 + * in the global namespace. */
1.1690 + Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with
1.1691 + * name. */
1.1692 + ClientData clientData; /* Arbitrary value to pass to object
1.1693 + * procedure. */
1.1694 + Tcl_CmdDeleteProc *deleteProc;
1.1695 + /* If not NULL, gives a procedure to call
1.1696 + * when this command is deleted. */
1.1697 +{
1.1698 + Interp *iPtr = (Interp *) interp;
1.1699 + ImportRef *oldRefPtr = NULL;
1.1700 + Namespace *nsPtr, *dummy1, *dummy2;
1.1701 + Command *cmdPtr, *refCmdPtr;
1.1702 + Tcl_HashEntry *hPtr;
1.1703 + CONST char *tail;
1.1704 + int new;
1.1705 + ImportedCmdData *dataPtr;
1.1706 +
1.1707 + if (iPtr->flags & DELETED) {
1.1708 + /*
1.1709 + * The interpreter is being deleted. Don't create any new
1.1710 + * commands; it's not safe to muck with the interpreter anymore.
1.1711 + */
1.1712 +
1.1713 + return (Tcl_Command) NULL;
1.1714 + }
1.1715 +
1.1716 + /*
1.1717 + * Determine where the command should reside. If its name contains
1.1718 + * namespace qualifiers, we put it in the specified namespace;
1.1719 + * otherwise, we always put it in the global namespace.
1.1720 + */
1.1721 +
1.1722 + if (strstr(cmdName, "::") != NULL) {
1.1723 + TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,
1.1724 + CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
1.1725 + if ((nsPtr == NULL) || (tail == NULL)) {
1.1726 + return (Tcl_Command) NULL;
1.1727 + }
1.1728 + } else {
1.1729 + nsPtr = iPtr->globalNsPtr;
1.1730 + tail = cmdName;
1.1731 + }
1.1732 +
1.1733 + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
1.1734 + if (!new) {
1.1735 + cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
1.1736 +
1.1737 + /*
1.1738 + * Command already exists. If its object-based Tcl_ObjCmdProc is
1.1739 + * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the
1.1740 + * argument "proc". Otherwise, we delete the old command.
1.1741 + */
1.1742 +
1.1743 + if (cmdPtr->objProc == TclInvokeStringCommand) {
1.1744 + cmdPtr->objProc = proc;
1.1745 + cmdPtr->objClientData = clientData;
1.1746 + cmdPtr->deleteProc = deleteProc;
1.1747 + cmdPtr->deleteData = clientData;
1.1748 + return (Tcl_Command) cmdPtr;
1.1749 + }
1.1750 +
1.1751 + /*
1.1752 + * Otherwise, we delete the old command. Be careful to preserve
1.1753 + * any existing import links so we can restore them down below.
1.1754 + * That way, you can redefine a command and its import status
1.1755 + * will remain intact.
1.1756 + */
1.1757 +
1.1758 + oldRefPtr = cmdPtr->importRefPtr;
1.1759 + cmdPtr->importRefPtr = NULL;
1.1760 +
1.1761 + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
1.1762 + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
1.1763 + if (!new) {
1.1764 + /*
1.1765 + * If the deletion callback recreated the command, just throw
1.1766 + * away the new command (if we try to delete it again, we
1.1767 + * could get stuck in an infinite loop).
1.1768 + */
1.1769 +
1.1770 + ckfree((char *) Tcl_GetHashValue(hPtr));
1.1771 + }
1.1772 + }
1.1773 + cmdPtr = (Command *) ckalloc(sizeof(Command));
1.1774 + Tcl_SetHashValue(hPtr, cmdPtr);
1.1775 + cmdPtr->hPtr = hPtr;
1.1776 + cmdPtr->nsPtr = nsPtr;
1.1777 + cmdPtr->refCount = 1;
1.1778 + cmdPtr->cmdEpoch = 0;
1.1779 + cmdPtr->compileProc = (CompileProc *) NULL;
1.1780 + cmdPtr->objProc = proc;
1.1781 + cmdPtr->objClientData = clientData;
1.1782 + cmdPtr->proc = TclInvokeObjectCommand;
1.1783 + cmdPtr->clientData = (ClientData) cmdPtr;
1.1784 + cmdPtr->deleteProc = deleteProc;
1.1785 + cmdPtr->deleteData = clientData;
1.1786 + cmdPtr->flags = 0;
1.1787 + cmdPtr->importRefPtr = NULL;
1.1788 + cmdPtr->tracePtr = NULL;
1.1789 +
1.1790 + /*
1.1791 + * Plug in any existing import references found above. Be sure
1.1792 + * to update all of these references to point to the new command.
1.1793 + */
1.1794 +
1.1795 + if (oldRefPtr != NULL) {
1.1796 + cmdPtr->importRefPtr = oldRefPtr;
1.1797 + while (oldRefPtr != NULL) {
1.1798 + refCmdPtr = oldRefPtr->importedCmdPtr;
1.1799 + dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
1.1800 + dataPtr->realCmdPtr = cmdPtr;
1.1801 + oldRefPtr = oldRefPtr->nextPtr;
1.1802 + }
1.1803 + }
1.1804 +
1.1805 + /*
1.1806 + * We just created a command, so in its namespace and all of its parent
1.1807 + * namespaces, it may shadow global commands with the same name. If any
1.1808 + * shadowed commands are found, invalidate all cached command references
1.1809 + * in the affected namespaces.
1.1810 + */
1.1811 +
1.1812 + TclResetShadowedCmdRefs(interp, cmdPtr);
1.1813 + return (Tcl_Command) cmdPtr;
1.1814 +}
1.1815 +
1.1816 +/*
1.1817 + *----------------------------------------------------------------------
1.1818 + *
1.1819 + * TclInvokeStringCommand --
1.1820 + *
1.1821 + * "Wrapper" Tcl_ObjCmdProc used to call an existing string-based
1.1822 + * Tcl_CmdProc if no object-based procedure exists for a command. A
1.1823 + * pointer to this procedure is stored as the Tcl_ObjCmdProc in a
1.1824 + * Command structure. It simply turns around and calls the string
1.1825 + * Tcl_CmdProc in the Command structure.
1.1826 + *
1.1827 + * Results:
1.1828 + * A standard Tcl object result value.
1.1829 + *
1.1830 + * Side effects:
1.1831 + * Besides those side effects of the called Tcl_CmdProc,
1.1832 + * TclInvokeStringCommand allocates and frees storage.
1.1833 + *
1.1834 + *----------------------------------------------------------------------
1.1835 + */
1.1836 +
1.1837 +int
1.1838 +TclInvokeStringCommand(clientData, interp, objc, objv)
1.1839 + ClientData clientData; /* Points to command's Command structure. */
1.1840 + Tcl_Interp *interp; /* Current interpreter. */
1.1841 + register int objc; /* Number of arguments. */
1.1842 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1843 +{
1.1844 + register Command *cmdPtr = (Command *) clientData;
1.1845 + register int i;
1.1846 + int result;
1.1847 +
1.1848 + /*
1.1849 + * This procedure generates an argv array for the string arguments. It
1.1850 + * starts out with stack-allocated space but uses dynamically-allocated
1.1851 + * storage if needed.
1.1852 + */
1.1853 +
1.1854 +#define NUM_ARGS 20
1.1855 + CONST char *(argStorage[NUM_ARGS]);
1.1856 + CONST char **argv = argStorage;
1.1857 +
1.1858 + /*
1.1859 + * Create the string argument array "argv". Make sure argv is large
1.1860 + * enough to hold the objc arguments plus 1 extra for the zero
1.1861 + * end-of-argv word.
1.1862 + */
1.1863 +
1.1864 + if ((objc + 1) > NUM_ARGS) {
1.1865 + argv = (CONST char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
1.1866 + }
1.1867 +
1.1868 + for (i = 0; i < objc; i++) {
1.1869 + argv[i] = Tcl_GetString(objv[i]);
1.1870 + }
1.1871 + argv[objc] = 0;
1.1872 +
1.1873 + /*
1.1874 + * Invoke the command's string-based Tcl_CmdProc.
1.1875 + */
1.1876 +
1.1877 + result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv);
1.1878 +
1.1879 + /*
1.1880 + * Free the argv array if malloc'ed storage was used.
1.1881 + */
1.1882 +
1.1883 + if (argv != argStorage) {
1.1884 + ckfree((char *) argv);
1.1885 + }
1.1886 + return result;
1.1887 +#undef NUM_ARGS
1.1888 +}
1.1889 +
1.1890 +/*
1.1891 + *----------------------------------------------------------------------
1.1892 + *
1.1893 + * TclInvokeObjectCommand --
1.1894 + *
1.1895 + * "Wrapper" Tcl_CmdProc used to call an existing object-based
1.1896 + * Tcl_ObjCmdProc if no string-based procedure exists for a command.
1.1897 + * A pointer to this procedure is stored as the Tcl_CmdProc in a
1.1898 + * Command structure. It simply turns around and calls the object
1.1899 + * Tcl_ObjCmdProc in the Command structure.
1.1900 + *
1.1901 + * Results:
1.1902 + * A standard Tcl string result value.
1.1903 + *
1.1904 + * Side effects:
1.1905 + * Besides those side effects of the called Tcl_CmdProc,
1.1906 + * TclInvokeStringCommand allocates and frees storage.
1.1907 + *
1.1908 + *----------------------------------------------------------------------
1.1909 + */
1.1910 +
1.1911 +int
1.1912 +TclInvokeObjectCommand(clientData, interp, argc, argv)
1.1913 + ClientData clientData; /* Points to command's Command structure. */
1.1914 + Tcl_Interp *interp; /* Current interpreter. */
1.1915 + int argc; /* Number of arguments. */
1.1916 + register CONST char **argv; /* Argument strings. */
1.1917 +{
1.1918 + Command *cmdPtr = (Command *) clientData;
1.1919 + register Tcl_Obj *objPtr;
1.1920 + register int i;
1.1921 + int length, result;
1.1922 +
1.1923 + /*
1.1924 + * This procedure generates an objv array for object arguments that hold
1.1925 + * the argv strings. It starts out with stack-allocated space but uses
1.1926 + * dynamically-allocated storage if needed.
1.1927 + */
1.1928 +
1.1929 +#define NUM_ARGS 20
1.1930 + Tcl_Obj *(argStorage[NUM_ARGS]);
1.1931 + register Tcl_Obj **objv = argStorage;
1.1932 +
1.1933 + /*
1.1934 + * Create the object argument array "objv". Make sure objv is large
1.1935 + * enough to hold the objc arguments plus 1 extra for the zero
1.1936 + * end-of-objv word.
1.1937 + */
1.1938 +
1.1939 + if (argc > NUM_ARGS) {
1.1940 + objv = (Tcl_Obj **)
1.1941 + ckalloc((unsigned)(argc * sizeof(Tcl_Obj *)));
1.1942 + }
1.1943 +
1.1944 + for (i = 0; i < argc; i++) {
1.1945 + length = strlen(argv[i]);
1.1946 + TclNewObj(objPtr);
1.1947 + TclInitStringRep(objPtr, argv[i], length);
1.1948 + Tcl_IncrRefCount(objPtr);
1.1949 + objv[i] = objPtr;
1.1950 + }
1.1951 +
1.1952 + /*
1.1953 + * Invoke the command's object-based Tcl_ObjCmdProc.
1.1954 + */
1.1955 +
1.1956 + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv);
1.1957 +
1.1958 + /*
1.1959 + * Move the interpreter's object result to the string result,
1.1960 + * then reset the object result.
1.1961 + */
1.1962 +
1.1963 + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
1.1964 + TCL_VOLATILE);
1.1965 +
1.1966 + /*
1.1967 + * Decrement the ref counts for the argument objects created above,
1.1968 + * then free the objv array if malloc'ed storage was used.
1.1969 + */
1.1970 +
1.1971 + for (i = 0; i < argc; i++) {
1.1972 + objPtr = objv[i];
1.1973 + Tcl_DecrRefCount(objPtr);
1.1974 + }
1.1975 + if (objv != argStorage) {
1.1976 + ckfree((char *) objv);
1.1977 + }
1.1978 + return result;
1.1979 +#undef NUM_ARGS
1.1980 +}
1.1981 +
1.1982 +/*
1.1983 + *----------------------------------------------------------------------
1.1984 + *
1.1985 + * TclRenameCommand --
1.1986 + *
1.1987 + * Called to give an existing Tcl command a different name. Both the
1.1988 + * old command name and the new command name can have "::" namespace
1.1989 + * qualifiers. If the new command has a different namespace context,
1.1990 + * the command will be moved to that namespace and will execute in
1.1991 + * the context of that new namespace.
1.1992 + *
1.1993 + * If the new command name is NULL or the null string, the command is
1.1994 + * deleted.
1.1995 + *
1.1996 + * Results:
1.1997 + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1.1998 + *
1.1999 + * Side effects:
1.2000 + * If anything goes wrong, an error message is returned in the
1.2001 + * interpreter's result object.
1.2002 + *
1.2003 + *----------------------------------------------------------------------
1.2004 + */
1.2005 +
1.2006 +int
1.2007 +TclRenameCommand(interp, oldName, newName)
1.2008 + Tcl_Interp *interp; /* Current interpreter. */
1.2009 + char *oldName; /* Existing command name. */
1.2010 + char *newName; /* New command name. */
1.2011 +{
1.2012 + Interp *iPtr = (Interp *) interp;
1.2013 + CONST char *newTail;
1.2014 + Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
1.2015 + Tcl_Command cmd;
1.2016 + Command *cmdPtr;
1.2017 + Tcl_HashEntry *hPtr, *oldHPtr;
1.2018 + int new, result;
1.2019 + Tcl_Obj* oldFullName;
1.2020 + Tcl_DString newFullName;
1.2021 +
1.2022 + /*
1.2023 + * Find the existing command. An error is returned if cmdName can't
1.2024 + * be found.
1.2025 + */
1.2026 +
1.2027 + cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL,
1.2028 + /*flags*/ 0);
1.2029 + cmdPtr = (Command *) cmd;
1.2030 + if (cmdPtr == NULL) {
1.2031 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ",
1.2032 + ((newName == NULL)||(*newName == '\0'))? "delete":"rename",
1.2033 + " \"", oldName, "\": command doesn't exist", (char *) NULL);
1.2034 + return TCL_ERROR;
1.2035 + }
1.2036 + cmdNsPtr = cmdPtr->nsPtr;
1.2037 + oldFullName = Tcl_NewObj();
1.2038 + Tcl_IncrRefCount( oldFullName );
1.2039 + Tcl_GetCommandFullName( interp, cmd, oldFullName );
1.2040 +
1.2041 + /*
1.2042 + * If the new command name is NULL or empty, delete the command. Do this
1.2043 + * with Tcl_DeleteCommandFromToken, since we already have the command.
1.2044 + */
1.2045 +
1.2046 + if ((newName == NULL) || (*newName == '\0')) {
1.2047 + Tcl_DeleteCommandFromToken(interp, cmd);
1.2048 + result = TCL_OK;
1.2049 + goto done;
1.2050 + }
1.2051 +
1.2052 + /*
1.2053 + * Make sure that the destination command does not already exist.
1.2054 + * The rename operation is like creating a command, so we should
1.2055 + * automatically create the containing namespaces just like
1.2056 + * Tcl_CreateCommand would.
1.2057 + */
1.2058 +
1.2059 + TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL,
1.2060 + CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);
1.2061 +
1.2062 + if ((newNsPtr == NULL) || (newTail == NULL)) {
1.2063 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.2064 + "can't rename to \"", newName, "\": bad command name",
1.2065 + (char *) NULL);
1.2066 + result = TCL_ERROR;
1.2067 + goto done;
1.2068 + }
1.2069 + if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
1.2070 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.2071 + "can't rename to \"", newName,
1.2072 + "\": command already exists", (char *) NULL);
1.2073 + result = TCL_ERROR;
1.2074 + goto done;
1.2075 + }
1.2076 +
1.2077 + /*
1.2078 + * Warning: any changes done in the code here are likely
1.2079 + * to be needed in Tcl_HideCommand() code too.
1.2080 + * (until the common parts are extracted out) --dl
1.2081 + */
1.2082 +
1.2083 + /*
1.2084 + * Put the command in the new namespace so we can check for an alias
1.2085 + * loop. Since we are adding a new command to a namespace, we must
1.2086 + * handle any shadowing of the global commands that this might create.
1.2087 + */
1.2088 +
1.2089 + oldHPtr = cmdPtr->hPtr;
1.2090 + hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new);
1.2091 + Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
1.2092 + cmdPtr->hPtr = hPtr;
1.2093 + cmdPtr->nsPtr = newNsPtr;
1.2094 + TclResetShadowedCmdRefs(interp, cmdPtr);
1.2095 +
1.2096 + /*
1.2097 + * Now check for an alias loop. If we detect one, put everything back
1.2098 + * the way it was and report the error.
1.2099 + */
1.2100 +
1.2101 + result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);
1.2102 + if (result != TCL_OK) {
1.2103 + Tcl_DeleteHashEntry(cmdPtr->hPtr);
1.2104 + cmdPtr->hPtr = oldHPtr;
1.2105 + cmdPtr->nsPtr = cmdNsPtr;
1.2106 + goto done;
1.2107 + }
1.2108 +
1.2109 + /*
1.2110 + * Script for rename traces can delete the command "oldName".
1.2111 + * Therefore increment the reference count for cmdPtr so that
1.2112 + * it's Command structure is freed only towards the end of this
1.2113 + * function by calling TclCleanupCommand.
1.2114 + *
1.2115 + * The trace procedure needs to get a fully qualified name for
1.2116 + * old and new commands [Tcl bug #651271], or else there's no way
1.2117 + * for the trace procedure to get the namespace from which the old
1.2118 + * command is being renamed!
1.2119 + */
1.2120 +
1.2121 + Tcl_DStringInit( &newFullName );
1.2122 + Tcl_DStringAppend( &newFullName, newNsPtr->fullName, -1 );
1.2123 + if ( newNsPtr != iPtr->globalNsPtr ) {
1.2124 + Tcl_DStringAppend( &newFullName, "::", 2 );
1.2125 + }
1.2126 + Tcl_DStringAppend( &newFullName, newTail, -1 );
1.2127 + cmdPtr->refCount++;
1.2128 + CallCommandTraces( iPtr, cmdPtr,
1.2129 + Tcl_GetString( oldFullName ),
1.2130 + Tcl_DStringValue( &newFullName ),
1.2131 + TCL_TRACE_RENAME);
1.2132 + Tcl_DStringFree( &newFullName );
1.2133 +
1.2134 + /*
1.2135 + * The new command name is okay, so remove the command from its
1.2136 + * current namespace. This is like deleting the command, so bump
1.2137 + * the cmdEpoch to invalidate any cached references to the command.
1.2138 + */
1.2139 +
1.2140 + Tcl_DeleteHashEntry(oldHPtr);
1.2141 + cmdPtr->cmdEpoch++;
1.2142 +
1.2143 + /*
1.2144 + * If the command being renamed has a compile procedure, increment the
1.2145 + * interpreter's compileEpoch to invalidate its compiled code. This
1.2146 + * makes sure that we don't later try to execute old code compiled for
1.2147 + * the now-renamed command.
1.2148 + */
1.2149 +
1.2150 + if (cmdPtr->compileProc != NULL) {
1.2151 + iPtr->compileEpoch++;
1.2152 + }
1.2153 +
1.2154 + /*
1.2155 + * Now free the Command structure, if the "oldName" command has
1.2156 + * been deleted by invocation of rename traces.
1.2157 + */
1.2158 + TclCleanupCommand(cmdPtr);
1.2159 + result = TCL_OK;
1.2160 +
1.2161 + done:
1.2162 + TclDecrRefCount( oldFullName );
1.2163 + return result;
1.2164 +}
1.2165 +
1.2166 +/*
1.2167 + *----------------------------------------------------------------------
1.2168 + *
1.2169 + * Tcl_SetCommandInfo --
1.2170 + *
1.2171 + * Modifies various information about a Tcl command. Note that
1.2172 + * this procedure will not change a command's namespace; use
1.2173 + * Tcl_RenameCommand to do that. Also, the isNativeObjectProc
1.2174 + * member of *infoPtr is ignored.
1.2175 + *
1.2176 + * Results:
1.2177 + * If cmdName exists in interp, then the information at *infoPtr
1.2178 + * is stored with the command in place of the current information
1.2179 + * and 1 is returned. If the command doesn't exist then 0 is
1.2180 + * returned.
1.2181 + *
1.2182 + * Side effects:
1.2183 + * None.
1.2184 + *
1.2185 + *----------------------------------------------------------------------
1.2186 + */
1.2187 +
1.2188 +EXPORT_C int
1.2189 +Tcl_SetCommandInfo(interp, cmdName, infoPtr)
1.2190 + Tcl_Interp *interp; /* Interpreter in which to look
1.2191 + * for command. */
1.2192 + CONST char *cmdName; /* Name of desired command. */
1.2193 + CONST Tcl_CmdInfo *infoPtr; /* Where to find information
1.2194 + * to store in the command. */
1.2195 +{
1.2196 + Tcl_Command cmd;
1.2197 +
1.2198 + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
1.2199 + /*flags*/ 0);
1.2200 +
1.2201 + return Tcl_SetCommandInfoFromToken( cmd, infoPtr );
1.2202 +
1.2203 +}
1.2204 +
1.2205 +/*
1.2206 + *----------------------------------------------------------------------
1.2207 + *
1.2208 + * Tcl_SetCommandInfoFromToken --
1.2209 + *
1.2210 + * Modifies various information about a Tcl command. Note that
1.2211 + * this procedure will not change a command's namespace; use
1.2212 + * Tcl_RenameCommand to do that. Also, the isNativeObjectProc
1.2213 + * member of *infoPtr is ignored.
1.2214 + *
1.2215 + * Results:
1.2216 + * If cmdName exists in interp, then the information at *infoPtr
1.2217 + * is stored with the command in place of the current information
1.2218 + * and 1 is returned. If the command doesn't exist then 0 is
1.2219 + * returned.
1.2220 + *
1.2221 + * Side effects:
1.2222 + * None.
1.2223 + *
1.2224 + *----------------------------------------------------------------------
1.2225 + */
1.2226 +
1.2227 +EXPORT_C int
1.2228 +Tcl_SetCommandInfoFromToken( cmd, infoPtr )
1.2229 + Tcl_Command cmd;
1.2230 + CONST Tcl_CmdInfo* infoPtr;
1.2231 +{
1.2232 + Command* cmdPtr; /* Internal representation of the command */
1.2233 +
1.2234 + if (cmd == (Tcl_Command) NULL) {
1.2235 + return 0;
1.2236 + }
1.2237 +
1.2238 + /*
1.2239 + * The isNativeObjectProc and nsPtr members of *infoPtr are ignored.
1.2240 + */
1.2241 +
1.2242 + cmdPtr = (Command *) cmd;
1.2243 + cmdPtr->proc = infoPtr->proc;
1.2244 + cmdPtr->clientData = infoPtr->clientData;
1.2245 + if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
1.2246 + cmdPtr->objProc = TclInvokeStringCommand;
1.2247 + cmdPtr->objClientData = (ClientData) cmdPtr;
1.2248 + } else {
1.2249 + cmdPtr->objProc = infoPtr->objProc;
1.2250 + cmdPtr->objClientData = infoPtr->objClientData;
1.2251 + }
1.2252 + cmdPtr->deleteProc = infoPtr->deleteProc;
1.2253 + cmdPtr->deleteData = infoPtr->deleteData;
1.2254 + return 1;
1.2255 +}
1.2256 +
1.2257 +/*
1.2258 + *----------------------------------------------------------------------
1.2259 + *
1.2260 + * Tcl_GetCommandInfo --
1.2261 + *
1.2262 + * Returns various information about a Tcl command.
1.2263 + *
1.2264 + * Results:
1.2265 + * If cmdName exists in interp, then *infoPtr is modified to
1.2266 + * hold information about cmdName and 1 is returned. If the
1.2267 + * command doesn't exist then 0 is returned and *infoPtr isn't
1.2268 + * modified.
1.2269 + *
1.2270 + * Side effects:
1.2271 + * None.
1.2272 + *
1.2273 + *----------------------------------------------------------------------
1.2274 + */
1.2275 +
1.2276 +EXPORT_C int
1.2277 +Tcl_GetCommandInfo(interp, cmdName, infoPtr)
1.2278 + Tcl_Interp *interp; /* Interpreter in which to look
1.2279 + * for command. */
1.2280 + CONST char *cmdName; /* Name of desired command. */
1.2281 + Tcl_CmdInfo *infoPtr; /* Where to store information about
1.2282 + * command. */
1.2283 +{
1.2284 + Tcl_Command cmd;
1.2285 +
1.2286 + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
1.2287 + /*flags*/ 0);
1.2288 +
1.2289 + return Tcl_GetCommandInfoFromToken( cmd, infoPtr );
1.2290 +
1.2291 +}
1.2292 +
1.2293 +/*
1.2294 + *----------------------------------------------------------------------
1.2295 + *
1.2296 + * Tcl_GetCommandInfoFromToken --
1.2297 + *
1.2298 + * Returns various information about a Tcl command.
1.2299 + *
1.2300 + * Results:
1.2301 + * Copies information from the command identified by 'cmd' into
1.2302 + * a caller-supplied structure and returns 1. If the 'cmd' is
1.2303 + * NULL, leaves the structure untouched and returns 0.
1.2304 + *
1.2305 + * Side effects:
1.2306 + * None.
1.2307 + *
1.2308 + *----------------------------------------------------------------------
1.2309 + */
1.2310 +
1.2311 +EXPORT_C int
1.2312 +Tcl_GetCommandInfoFromToken( cmd, infoPtr )
1.2313 + Tcl_Command cmd;
1.2314 + Tcl_CmdInfo* infoPtr;
1.2315 +{
1.2316 +
1.2317 + Command* cmdPtr; /* Internal representation of the command */
1.2318 +
1.2319 + if ( cmd == (Tcl_Command) NULL ) {
1.2320 + return 0;
1.2321 + }
1.2322 +
1.2323 + /*
1.2324 + * Set isNativeObjectProc 1 if objProc was registered by a call to
1.2325 + * Tcl_CreateObjCommand. Otherwise set it to 0.
1.2326 + */
1.2327 +
1.2328 + cmdPtr = (Command *) cmd;
1.2329 + infoPtr->isNativeObjectProc =
1.2330 + (cmdPtr->objProc != TclInvokeStringCommand);
1.2331 + infoPtr->objProc = cmdPtr->objProc;
1.2332 + infoPtr->objClientData = cmdPtr->objClientData;
1.2333 + infoPtr->proc = cmdPtr->proc;
1.2334 + infoPtr->clientData = cmdPtr->clientData;
1.2335 + infoPtr->deleteProc = cmdPtr->deleteProc;
1.2336 + infoPtr->deleteData = cmdPtr->deleteData;
1.2337 + infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
1.2338 +
1.2339 + return 1;
1.2340 +
1.2341 +}
1.2342 +
1.2343 +/*
1.2344 + *----------------------------------------------------------------------
1.2345 + *
1.2346 + * Tcl_GetCommandName --
1.2347 + *
1.2348 + * Given a token returned by Tcl_CreateCommand, this procedure
1.2349 + * returns the current name of the command (which may have changed
1.2350 + * due to renaming).
1.2351 + *
1.2352 + * Results:
1.2353 + * The return value is the name of the given command.
1.2354 + *
1.2355 + * Side effects:
1.2356 + * None.
1.2357 + *
1.2358 + *----------------------------------------------------------------------
1.2359 + */
1.2360 +
1.2361 +EXPORT_C CONST char *
1.2362 +Tcl_GetCommandName(interp, command)
1.2363 + Tcl_Interp *interp; /* Interpreter containing the command. */
1.2364 + Tcl_Command command; /* Token for command returned by a previous
1.2365 + * call to Tcl_CreateCommand. The command
1.2366 + * must not have been deleted. */
1.2367 +{
1.2368 + Command *cmdPtr = (Command *) command;
1.2369 +
1.2370 + if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {
1.2371 +
1.2372 + /*
1.2373 + * This should only happen if command was "created" after the
1.2374 + * interpreter began to be deleted, so there isn't really any
1.2375 + * command. Just return an empty string.
1.2376 + */
1.2377 +
1.2378 + return "";
1.2379 + }
1.2380 + return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
1.2381 +}
1.2382 +
1.2383 +/*
1.2384 + *----------------------------------------------------------------------
1.2385 + *
1.2386 + * Tcl_GetCommandFullName --
1.2387 + *
1.2388 + * Given a token returned by, e.g., Tcl_CreateCommand or
1.2389 + * Tcl_FindCommand, this procedure appends to an object the command's
1.2390 + * full name, qualified by a sequence of parent namespace names. The
1.2391 + * command's fully-qualified name may have changed due to renaming.
1.2392 + *
1.2393 + * Results:
1.2394 + * None.
1.2395 + *
1.2396 + * Side effects:
1.2397 + * The command's fully-qualified name is appended to the string
1.2398 + * representation of objPtr.
1.2399 + *
1.2400 + *----------------------------------------------------------------------
1.2401 + */
1.2402 +
1.2403 +void
1.2404 +Tcl_GetCommandFullName(interp, command, objPtr)
1.2405 + Tcl_Interp *interp; /* Interpreter containing the command. */
1.2406 + Tcl_Command command; /* Token for command returned by a previous
1.2407 + * call to Tcl_CreateCommand. The command
1.2408 + * must not have been deleted. */
1.2409 + Tcl_Obj *objPtr; /* Points to the object onto which the
1.2410 + * command's full name is appended. */
1.2411 +
1.2412 +{
1.2413 + Interp *iPtr = (Interp *) interp;
1.2414 + register Command *cmdPtr = (Command *) command;
1.2415 + char *name;
1.2416 +
1.2417 + /*
1.2418 + * Add the full name of the containing namespace, followed by the "::"
1.2419 + * separator, and the command name.
1.2420 + */
1.2421 +
1.2422 + if (cmdPtr != NULL) {
1.2423 + if (cmdPtr->nsPtr != NULL) {
1.2424 + Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
1.2425 + if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
1.2426 + Tcl_AppendToObj(objPtr, "::", 2);
1.2427 + }
1.2428 + }
1.2429 + if (cmdPtr->hPtr != NULL) {
1.2430 + name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
1.2431 + Tcl_AppendToObj(objPtr, name, -1);
1.2432 + }
1.2433 + }
1.2434 +}
1.2435 +
1.2436 +/*
1.2437 + *----------------------------------------------------------------------
1.2438 + *
1.2439 + * Tcl_DeleteCommand --
1.2440 + *
1.2441 + * Remove the given command from the given interpreter.
1.2442 + *
1.2443 + * Results:
1.2444 + * 0 is returned if the command was deleted successfully.
1.2445 + * -1 is returned if there didn't exist a command by that name.
1.2446 + *
1.2447 + * Side effects:
1.2448 + * cmdName will no longer be recognized as a valid command for
1.2449 + * interp.
1.2450 + *
1.2451 + *----------------------------------------------------------------------
1.2452 + */
1.2453 +
1.2454 +EXPORT_C int
1.2455 +Tcl_DeleteCommand(interp, cmdName)
1.2456 + Tcl_Interp *interp; /* Token for command interpreter (returned
1.2457 + * by a previous Tcl_CreateInterp call). */
1.2458 + CONST char *cmdName; /* Name of command to remove. */
1.2459 +{
1.2460 + Tcl_Command cmd;
1.2461 +
1.2462 + /*
1.2463 + * Find the desired command and delete it.
1.2464 + */
1.2465 +
1.2466 + cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
1.2467 + /*flags*/ 0);
1.2468 + if (cmd == (Tcl_Command) NULL) {
1.2469 + return -1;
1.2470 + }
1.2471 + return Tcl_DeleteCommandFromToken(interp, cmd);
1.2472 +}
1.2473 +
1.2474 +/*
1.2475 + *----------------------------------------------------------------------
1.2476 + *
1.2477 + * Tcl_DeleteCommandFromToken --
1.2478 + *
1.2479 + * Removes the given command from the given interpreter. This procedure
1.2480 + * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead
1.2481 + * of a command name for efficiency.
1.2482 + *
1.2483 + * Results:
1.2484 + * 0 is returned if the command was deleted successfully.
1.2485 + * -1 is returned if there didn't exist a command by that name.
1.2486 + *
1.2487 + * Side effects:
1.2488 + * The command specified by "cmd" will no longer be recognized as a
1.2489 + * valid command for "interp".
1.2490 + *
1.2491 + *----------------------------------------------------------------------
1.2492 + */
1.2493 +
1.2494 +EXPORT_C int
1.2495 +Tcl_DeleteCommandFromToken(interp, cmd)
1.2496 + Tcl_Interp *interp; /* Token for command interpreter returned by
1.2497 + * a previous call to Tcl_CreateInterp. */
1.2498 + Tcl_Command cmd; /* Token for command to delete. */
1.2499 +{
1.2500 + Interp *iPtr = (Interp *) interp;
1.2501 + Command *cmdPtr = (Command *) cmd;
1.2502 + ImportRef *refPtr, *nextRefPtr;
1.2503 + Tcl_Command importCmd;
1.2504 +
1.2505 + /*
1.2506 + * The code here is tricky. We can't delete the hash table entry
1.2507 + * before invoking the deletion callback because there are cases
1.2508 + * where the deletion callback needs to invoke the command (e.g.
1.2509 + * object systems such as OTcl). However, this means that the
1.2510 + * callback could try to delete or rename the command. The deleted
1.2511 + * flag allows us to detect these cases and skip nested deletes.
1.2512 + */
1.2513 +
1.2514 + if (cmdPtr->flags & CMD_IS_DELETED) {
1.2515 + /*
1.2516 + * Another deletion is already in progress. Remove the hash
1.2517 + * table entry now, but don't invoke a callback or free the
1.2518 + * command structure.
1.2519 + */
1.2520 +
1.2521 + Tcl_DeleteHashEntry(cmdPtr->hPtr);
1.2522 + cmdPtr->hPtr = NULL;
1.2523 + return 0;
1.2524 + }
1.2525 +
1.2526 + /*
1.2527 + * We must delete this command, even though both traces and
1.2528 + * delete procs may try to avoid this (renaming the command etc).
1.2529 + * Also traces and delete procs may try to delete the command
1.2530 + * themsevles. This flag declares that a delete is in progress
1.2531 + * and that recursive deletes should be ignored.
1.2532 + */
1.2533 + cmdPtr->flags |= CMD_IS_DELETED;
1.2534 +
1.2535 + /*
1.2536 + * Bump the command epoch counter. This will invalidate all cached
1.2537 + * references that point to this command.
1.2538 + */
1.2539 +
1.2540 + cmdPtr->cmdEpoch++;
1.2541 +
1.2542 + /*
1.2543 + * Call trace procedures for the command being deleted. Then delete
1.2544 + * its traces.
1.2545 + */
1.2546 +
1.2547 + if (cmdPtr->tracePtr != NULL) {
1.2548 + CommandTrace *tracePtr;
1.2549 + CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);
1.2550 + /* Now delete these traces */
1.2551 + tracePtr = cmdPtr->tracePtr;
1.2552 + while (tracePtr != NULL) {
1.2553 + CommandTrace *nextPtr = tracePtr->nextPtr;
1.2554 + if ((--tracePtr->refCount) <= 0) {
1.2555 + ckfree((char*)tracePtr);
1.2556 + }
1.2557 + tracePtr = nextPtr;
1.2558 + }
1.2559 + cmdPtr->tracePtr = NULL;
1.2560 + }
1.2561 +
1.2562 + /*
1.2563 + * If the command being deleted has a compile procedure, increment the
1.2564 + * interpreter's compileEpoch to invalidate its compiled code. This
1.2565 + * makes sure that we don't later try to execute old code compiled with
1.2566 + * command-specific (i.e., inline) bytecodes for the now-deleted
1.2567 + * command. This field is checked in Tcl_EvalObj and ObjInterpProc, and
1.2568 + * code whose compilation epoch doesn't match is recompiled.
1.2569 + */
1.2570 +
1.2571 + if (cmdPtr->compileProc != NULL) {
1.2572 + iPtr->compileEpoch++;
1.2573 + }
1.2574 +
1.2575 + if (cmdPtr->deleteProc != NULL) {
1.2576 + /*
1.2577 + * Delete the command's client data. If this was an imported command
1.2578 + * created when a command was imported into a namespace, this client
1.2579 + * data will be a pointer to a ImportedCmdData structure describing
1.2580 + * the "real" command that this imported command refers to.
1.2581 + */
1.2582 +
1.2583 + /*
1.2584 + * If you are getting a crash during the call to deleteProc and
1.2585 + * cmdPtr->deleteProc is a pointer to the function free(), the
1.2586 + * most likely cause is that your extension allocated memory
1.2587 + * for the clientData argument to Tcl_CreateObjCommand() with
1.2588 + * the ckalloc() macro and you are now trying to deallocate
1.2589 + * this memory with free() instead of ckfree(). You should
1.2590 + * pass a pointer to your own method that calls ckfree().
1.2591 + */
1.2592 +
1.2593 + (*cmdPtr->deleteProc)(cmdPtr->deleteData);
1.2594 + }
1.2595 +
1.2596 + /*
1.2597 + * If this command was imported into other namespaces, then imported
1.2598 + * commands were created that refer back to this command. Delete these
1.2599 + * imported commands now.
1.2600 + */
1.2601 +
1.2602 + for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
1.2603 + refPtr = nextRefPtr) {
1.2604 + nextRefPtr = refPtr->nextPtr;
1.2605 + importCmd = (Tcl_Command) refPtr->importedCmdPtr;
1.2606 + Tcl_DeleteCommandFromToken(interp, importCmd);
1.2607 + }
1.2608 +
1.2609 + /*
1.2610 + * Don't use hPtr to delete the hash entry here, because it's
1.2611 + * possible that the deletion callback renamed the command.
1.2612 + * Instead, use cmdPtr->hptr, and make sure that no-one else
1.2613 + * has already deleted the hash entry.
1.2614 + */
1.2615 +
1.2616 + if (cmdPtr->hPtr != NULL) {
1.2617 + Tcl_DeleteHashEntry(cmdPtr->hPtr);
1.2618 + }
1.2619 +
1.2620 + /*
1.2621 + * Mark the Command structure as no longer valid. This allows
1.2622 + * TclExecuteByteCode to recognize when a Command has logically been
1.2623 + * deleted and a pointer to this Command structure cached in a CmdName
1.2624 + * object is invalid. TclExecuteByteCode will look up the command again
1.2625 + * in the interpreter's command hashtable.
1.2626 + */
1.2627 +
1.2628 + cmdPtr->objProc = NULL;
1.2629 +
1.2630 + /*
1.2631 + * Now free the Command structure, unless there is another reference to
1.2632 + * it from a CmdName Tcl object in some ByteCode code sequence. In that
1.2633 + * case, delay the cleanup until all references are either discarded
1.2634 + * (when a ByteCode is freed) or replaced by a new reference (when a
1.2635 + * cached CmdName Command reference is found to be invalid and
1.2636 + * TclExecuteByteCode looks up the command in the command hashtable).
1.2637 + */
1.2638 +
1.2639 + TclCleanupCommand(cmdPtr);
1.2640 + return 0;
1.2641 +}
1.2642 +
1.2643 +static char *
1.2644 +CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags)
1.2645 + Interp *iPtr; /* Interpreter containing command. */
1.2646 + Command *cmdPtr; /* Command whose traces are to be
1.2647 + * invoked. */
1.2648 + CONST char *oldName; /* Command's old name, or NULL if we
1.2649 + * must get the name from cmdPtr */
1.2650 + CONST char *newName; /* Command's new name, or NULL if
1.2651 + * the command is not being renamed */
1.2652 + int flags; /* Flags indicating the type of traces
1.2653 + * to trigger, either TCL_TRACE_DELETE
1.2654 + * or TCL_TRACE_RENAME. */
1.2655 +{
1.2656 + register CommandTrace *tracePtr;
1.2657 + ActiveCommandTrace active;
1.2658 + char *result;
1.2659 + Tcl_Obj *oldNamePtr = NULL;
1.2660 + int mask = (TCL_TRACE_DELETE | TCL_TRACE_RENAME); /* Safety */
1.2661 +
1.2662 + flags &= mask;
1.2663 +
1.2664 + if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
1.2665 + /*
1.2666 + * While a rename trace is active, we will not process any more
1.2667 + * rename traces; while a delete trace is active we will never
1.2668 + * reach here -- because Tcl_DeleteCommandFromToken checks for the
1.2669 + * condition (cmdPtr->flags & CMD_IS_DELETED) and returns immediately
1.2670 + * when a command deletion is in progress. For all other traces,
1.2671 + * delete traces will not be invoked but a call to TraceCommandProc
1.2672 + * will ensure that tracePtr->clientData is freed whenever the
1.2673 + * command "oldName" is deleted.
1.2674 + */
1.2675 + if (cmdPtr->flags & TCL_TRACE_RENAME) {
1.2676 + flags &= ~TCL_TRACE_RENAME;
1.2677 + }
1.2678 + if (flags == 0) {
1.2679 + return NULL;
1.2680 + }
1.2681 + }
1.2682 + cmdPtr->flags |= CMD_TRACE_ACTIVE;
1.2683 + cmdPtr->refCount++;
1.2684 +
1.2685 + result = NULL;
1.2686 + active.nextPtr = iPtr->activeCmdTracePtr;
1.2687 + active.reverseScan = 0;
1.2688 + iPtr->activeCmdTracePtr = &active;
1.2689 +
1.2690 + if (flags & TCL_TRACE_DELETE) {
1.2691 + flags |= TCL_TRACE_DESTROYED;
1.2692 + }
1.2693 + active.cmdPtr = cmdPtr;
1.2694 +
1.2695 + Tcl_Preserve((ClientData) iPtr);
1.2696 +
1.2697 + for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL;
1.2698 + tracePtr = active.nextTracePtr) {
1.2699 + int traceFlags = (tracePtr->flags & mask);
1.2700 +
1.2701 + active.nextTracePtr = tracePtr->nextPtr;
1.2702 + if (!(traceFlags & flags)) {
1.2703 + continue;
1.2704 + }
1.2705 + cmdPtr->flags |= traceFlags;
1.2706 + if (oldName == NULL) {
1.2707 + TclNewObj(oldNamePtr);
1.2708 + Tcl_IncrRefCount(oldNamePtr);
1.2709 + Tcl_GetCommandFullName((Tcl_Interp *) iPtr,
1.2710 + (Tcl_Command) cmdPtr, oldNamePtr);
1.2711 + oldName = TclGetString(oldNamePtr);
1.2712 + }
1.2713 + tracePtr->refCount++;
1.2714 + (*tracePtr->traceProc)(tracePtr->clientData,
1.2715 + (Tcl_Interp *) iPtr, oldName, newName, flags);
1.2716 + cmdPtr->flags &= ~traceFlags;
1.2717 + if ((--tracePtr->refCount) <= 0) {
1.2718 + ckfree((char*)tracePtr);
1.2719 + }
1.2720 + }
1.2721 +
1.2722 + /*
1.2723 + * If a new object was created to hold the full oldName,
1.2724 + * free it now.
1.2725 + */
1.2726 +
1.2727 + if (oldNamePtr != NULL) {
1.2728 + TclDecrRefCount(oldNamePtr);
1.2729 + }
1.2730 +
1.2731 + /*
1.2732 + * Restore the variable's flags, remove the record of our active
1.2733 + * traces, and then return.
1.2734 + */
1.2735 +
1.2736 + cmdPtr->flags &= ~CMD_TRACE_ACTIVE;
1.2737 + cmdPtr->refCount--;
1.2738 + iPtr->activeCmdTracePtr = active.nextPtr;
1.2739 + Tcl_Release((ClientData) iPtr);
1.2740 + return result;
1.2741 +}
1.2742 +
1.2743 +/*
1.2744 + *----------------------------------------------------------------------
1.2745 + *
1.2746 + * TclCleanupCommand --
1.2747 + *
1.2748 + * This procedure frees up a Command structure unless it is still
1.2749 + * referenced from an interpreter's command hashtable or from a CmdName
1.2750 + * Tcl object representing the name of a command in a ByteCode
1.2751 + * instruction sequence.
1.2752 + *
1.2753 + * Results:
1.2754 + * None.
1.2755 + *
1.2756 + * Side effects:
1.2757 + * Memory gets freed unless a reference to the Command structure still
1.2758 + * exists. In that case the cleanup is delayed until the command is
1.2759 + * deleted or when the last ByteCode referring to it is freed.
1.2760 + *
1.2761 + *----------------------------------------------------------------------
1.2762 + */
1.2763 +
1.2764 +void
1.2765 +TclCleanupCommand(cmdPtr)
1.2766 + register Command *cmdPtr; /* Points to the Command structure to
1.2767 + * be freed. */
1.2768 +{
1.2769 + cmdPtr->refCount--;
1.2770 + if (cmdPtr->refCount <= 0) {
1.2771 + ckfree((char *) cmdPtr);
1.2772 + }
1.2773 +}
1.2774 +
1.2775 +/*
1.2776 + *----------------------------------------------------------------------
1.2777 + *
1.2778 + * Tcl_CreateMathFunc --
1.2779 + *
1.2780 + * Creates a new math function for expressions in a given
1.2781 + * interpreter.
1.2782 + *
1.2783 + * Results:
1.2784 + * None.
1.2785 + *
1.2786 + * Side effects:
1.2787 + * The function defined by "name" is created or redefined. If the
1.2788 + * function already exists then its definition is replaced; this
1.2789 + * includes the builtin functions. Redefining a builtin function forces
1.2790 + * all existing code to be invalidated since that code may be compiled
1.2791 + * using an instruction specific to the replaced function. In addition,
1.2792 + * redefioning a non-builtin function will force existing code to be
1.2793 + * invalidated if the number of arguments has changed.
1.2794 + *
1.2795 + *----------------------------------------------------------------------
1.2796 + */
1.2797 +
1.2798 +EXPORT_C void
1.2799 +Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
1.2800 + Tcl_Interp *interp; /* Interpreter in which function is
1.2801 + * to be available. */
1.2802 + CONST char *name; /* Name of function (e.g. "sin"). */
1.2803 + int numArgs; /* Nnumber of arguments required by
1.2804 + * function. */
1.2805 + Tcl_ValueType *argTypes; /* Array of types acceptable for
1.2806 + * each argument. */
1.2807 + Tcl_MathProc *proc; /* Procedure that implements the
1.2808 + * math function. */
1.2809 + ClientData clientData; /* Additional value to pass to the
1.2810 + * function. */
1.2811 +{
1.2812 + Interp *iPtr = (Interp *) interp;
1.2813 + Tcl_HashEntry *hPtr;
1.2814 + MathFunc *mathFuncPtr;
1.2815 + int new, i;
1.2816 +
1.2817 + hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
1.2818 + if (new) {
1.2819 + Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
1.2820 + }
1.2821 + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
1.2822 +
1.2823 + if (!new) {
1.2824 + if (mathFuncPtr->builtinFuncIndex >= 0) {
1.2825 + /*
1.2826 + * We are redefining a builtin math function. Invalidate the
1.2827 + * interpreter's existing code by incrementing its
1.2828 + * compileEpoch member. This field is checked in Tcl_EvalObj
1.2829 + * and ObjInterpProc, and code whose compilation epoch doesn't
1.2830 + * match is recompiled. Newly compiled code will no longer
1.2831 + * treat the function as builtin.
1.2832 + */
1.2833 +
1.2834 + iPtr->compileEpoch++;
1.2835 + } else {
1.2836 + /*
1.2837 + * A non-builtin function is being redefined. We must invalidate
1.2838 + * existing code if the number of arguments has changed. This
1.2839 + * is because existing code was compiled assuming that number.
1.2840 + */
1.2841 +
1.2842 + if (numArgs != mathFuncPtr->numArgs) {
1.2843 + iPtr->compileEpoch++;
1.2844 + }
1.2845 + }
1.2846 + }
1.2847 +
1.2848 + mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */
1.2849 + if (numArgs > MAX_MATH_ARGS) {
1.2850 + numArgs = MAX_MATH_ARGS;
1.2851 + }
1.2852 + mathFuncPtr->numArgs = numArgs;
1.2853 + for (i = 0; i < numArgs; i++) {
1.2854 + mathFuncPtr->argTypes[i] = argTypes[i];
1.2855 + }
1.2856 + mathFuncPtr->proc = proc;
1.2857 + mathFuncPtr->clientData = clientData;
1.2858 +}
1.2859 +
1.2860 +/*
1.2861 + *----------------------------------------------------------------------
1.2862 + *
1.2863 + * Tcl_GetMathFuncInfo --
1.2864 + *
1.2865 + * Discovers how a particular math function was created in a given
1.2866 + * interpreter.
1.2867 + *
1.2868 + * Results:
1.2869 + * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message
1.2870 + * in the interpreter result if that happens.)
1.2871 + *
1.2872 + * Side effects:
1.2873 + * If this function succeeds, the variables pointed to by the
1.2874 + * numArgsPtr and argTypePtr arguments will be updated to detail the
1.2875 + * arguments allowed by the function. The variable pointed to by the
1.2876 + * procPtr argument will be set to NULL if the function is a builtin
1.2877 + * function, and will be set to the address of the C function used to
1.2878 + * implement the math function otherwise (in which case the variable
1.2879 + * pointed to by the clientDataPtr argument will also be updated.)
1.2880 + *
1.2881 + *----------------------------------------------------------------------
1.2882 + */
1.2883 +
1.2884 +EXPORT_C int
1.2885 +Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr,
1.2886 + clientDataPtr)
1.2887 + Tcl_Interp *interp;
1.2888 + CONST char *name;
1.2889 + int *numArgsPtr;
1.2890 + Tcl_ValueType **argTypesPtr;
1.2891 + Tcl_MathProc **procPtr;
1.2892 + ClientData *clientDataPtr;
1.2893 +{
1.2894 + Interp *iPtr = (Interp *) interp;
1.2895 + Tcl_HashEntry *hPtr;
1.2896 + MathFunc *mathFuncPtr;
1.2897 + Tcl_ValueType *argTypes;
1.2898 + int i,numArgs;
1.2899 +
1.2900 + hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, name);
1.2901 + if (hPtr == NULL) {
1.2902 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.2903 + "math function \"", name, "\" not known in this interpreter",
1.2904 + (char *) NULL);
1.2905 + return TCL_ERROR;
1.2906 + }
1.2907 + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
1.2908 +
1.2909 + *numArgsPtr = numArgs = mathFuncPtr->numArgs;
1.2910 + if (numArgs == 0) {
1.2911 + /* Avoid doing zero-sized allocs... */
1.2912 + numArgs = 1;
1.2913 + }
1.2914 + *argTypesPtr = argTypes =
1.2915 + (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType));
1.2916 + for (i = 0; i < mathFuncPtr->numArgs; i++) {
1.2917 + argTypes[i] = mathFuncPtr->argTypes[i];
1.2918 + }
1.2919 +
1.2920 + if (mathFuncPtr->builtinFuncIndex == -1) {
1.2921 + *procPtr = (Tcl_MathProc *) NULL;
1.2922 + } else {
1.2923 + *procPtr = mathFuncPtr->proc;
1.2924 + *clientDataPtr = mathFuncPtr->clientData;
1.2925 + }
1.2926 +
1.2927 + return TCL_OK;
1.2928 +}
1.2929 +
1.2930 +/*
1.2931 + *----------------------------------------------------------------------
1.2932 + *
1.2933 + * Tcl_ListMathFuncs --
1.2934 + *
1.2935 + * Produces a list of all the math functions defined in a given
1.2936 + * interpreter.
1.2937 + *
1.2938 + * Results:
1.2939 + * A pointer to a Tcl_Obj structure with a reference count of zero,
1.2940 + * or NULL in the case of an error (in which case a suitable error
1.2941 + * message will be left in the interpreter result.)
1.2942 + *
1.2943 + * Side effects:
1.2944 + * None.
1.2945 + *
1.2946 + *----------------------------------------------------------------------
1.2947 + */
1.2948 +
1.2949 +EXPORT_C Tcl_Obj *
1.2950 +Tcl_ListMathFuncs(interp, pattern)
1.2951 + Tcl_Interp *interp;
1.2952 + CONST char *pattern;
1.2953 +{
1.2954 + Interp *iPtr = (Interp *) interp;
1.2955 + Tcl_Obj *resultList = Tcl_NewObj();
1.2956 + register Tcl_HashEntry *hPtr;
1.2957 + Tcl_HashSearch hSearch;
1.2958 + CONST char *name;
1.2959 +
1.2960 + for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &hSearch);
1.2961 + hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
1.2962 + name = Tcl_GetHashKey(&iPtr->mathFuncTable, hPtr);
1.2963 + if ((pattern == NULL || Tcl_StringMatch(name, pattern)) &&
1.2964 + /* I don't expect this to fail, but... */
1.2965 + Tcl_ListObjAppendElement(interp, resultList,
1.2966 + Tcl_NewStringObj(name,-1)) != TCL_OK) {
1.2967 + Tcl_DecrRefCount(resultList);
1.2968 + return NULL;
1.2969 + }
1.2970 + }
1.2971 + return resultList;
1.2972 +}
1.2973 +
1.2974 +/*
1.2975 + *----------------------------------------------------------------------
1.2976 + *
1.2977 + * TclInterpReady --
1.2978 + *
1.2979 + * Check if an interpreter is ready to eval commands or scripts,
1.2980 + * i.e., if it was not deleted and if the nesting level is not
1.2981 + * too high.
1.2982 + *
1.2983 + * Results:
1.2984 + * The return value is TCL_OK if it the interpreter is ready,
1.2985 + * TCL_ERROR otherwise.
1.2986 + *
1.2987 + * Side effects:
1.2988 + * The interpreters object and string results are cleared.
1.2989 + *
1.2990 + *----------------------------------------------------------------------
1.2991 + */
1.2992 +
1.2993 +int
1.2994 +TclInterpReady(interp)
1.2995 + Tcl_Interp *interp;
1.2996 +{
1.2997 + register Interp *iPtr = (Interp *) interp;
1.2998 +
1.2999 + /*
1.3000 + * Reset both the interpreter's string and object results and clear
1.3001 + * out any previous error information.
1.3002 + */
1.3003 +
1.3004 + Tcl_ResetResult(interp);
1.3005 +
1.3006 + /*
1.3007 + * If the interpreter has been deleted, return an error.
1.3008 + */
1.3009 +
1.3010 + if (iPtr->flags & DELETED) {
1.3011 + Tcl_ResetResult(interp);
1.3012 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.3013 + "attempt to call eval in deleted interpreter", -1);
1.3014 + Tcl_SetErrorCode(interp, "CORE", "IDELETE",
1.3015 + "attempt to call eval in deleted interpreter",
1.3016 + (char *) NULL);
1.3017 + return TCL_ERROR;
1.3018 + }
1.3019 +
1.3020 + /*
1.3021 + * Check depth of nested calls to Tcl_Eval: if this gets too large,
1.3022 + * it's probably because of an infinite loop somewhere.
1.3023 + */
1.3024 +
1.3025 + if (((iPtr->numLevels) > iPtr->maxNestingDepth)
1.3026 + || (TclpCheckStackSpace() == 0)) {
1.3027 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.3028 + "too many nested evaluations (infinite loop?)", -1);
1.3029 + return TCL_ERROR;
1.3030 + }
1.3031 +
1.3032 + return TCL_OK;
1.3033 +}
1.3034 +
1.3035 +/*
1.3036 + *----------------------------------------------------------------------
1.3037 + *
1.3038 + * TclEvalObjvInternal --
1.3039 + *
1.3040 + * This procedure evaluates a Tcl command that has already been
1.3041 + * parsed into words, with one Tcl_Obj holding each word. The caller
1.3042 + * is responsible for managing the iPtr->numLevels.
1.3043 + *
1.3044 + * Results:
1.3045 + * The return value is a standard Tcl completion code such as
1.3046 + * TCL_OK or TCL_ERROR. A result or error message is left in
1.3047 + * interp's result. If an error occurs, this procedure does
1.3048 + * NOT add any information to the errorInfo variable.
1.3049 + *
1.3050 + * Side effects:
1.3051 + * Depends on the command.
1.3052 + *
1.3053 + *----------------------------------------------------------------------
1.3054 + */
1.3055 +
1.3056 +int
1.3057 +TclEvalObjvInternal(interp, objc, objv, command, length, flags)
1.3058 + Tcl_Interp *interp; /* Interpreter in which to evaluate the
1.3059 + * command. Also used for error
1.3060 + * reporting. */
1.3061 + int objc; /* Number of words in command. */
1.3062 + Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are
1.3063 + * the words that make up the command. */
1.3064 + CONST char *command; /* Points to the beginning of the string
1.3065 + * representation of the command; this
1.3066 + * is used for traces. If the string
1.3067 + * representation of the command is
1.3068 + * unknown, an empty string should be
1.3069 + * supplied. If it is NULL, no traces will
1.3070 + * be called. */
1.3071 + int length; /* Number of bytes in command; if -1, all
1.3072 + * characters up to the first null byte are
1.3073 + * used. */
1.3074 + int flags; /* Collection of OR-ed bits that control
1.3075 + * the evaluation of the script. Only
1.3076 + * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are
1.3077 + * currently supported. */
1.3078 +
1.3079 +{
1.3080 + Command *cmdPtr;
1.3081 + Interp *iPtr = (Interp *) interp;
1.3082 + Tcl_Obj **newObjv;
1.3083 + int i;
1.3084 + CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
1.3085 + * in case TCL_EVAL_GLOBAL was set. */
1.3086 + int code = TCL_OK;
1.3087 + int traceCode = TCL_OK;
1.3088 + int checkTraces = 1;
1.3089 + Namespace *savedNsPtr = NULL;
1.3090 +
1.3091 + if (TclInterpReady(interp) == TCL_ERROR) {
1.3092 + return TCL_ERROR;
1.3093 + }
1.3094 +
1.3095 + if (objc == 0) {
1.3096 + return TCL_OK;
1.3097 + }
1.3098 +
1.3099 +
1.3100 + /*
1.3101 + * If any execution traces rename or delete the current command,
1.3102 + * we may need (at most) two passes here.
1.3103 + */
1.3104 +
1.3105 + savedVarFramePtr = iPtr->varFramePtr;
1.3106 + while (1) {
1.3107 +
1.3108 + /* Configure evaluation context to match the requested flags */
1.3109 + if (flags & TCL_EVAL_GLOBAL) {
1.3110 + iPtr->varFramePtr = NULL;
1.3111 + } else if ((flags & TCL_EVAL_INVOKE) && iPtr->varFramePtr) {
1.3112 + savedNsPtr = iPtr->varFramePtr->nsPtr;
1.3113 + iPtr->varFramePtr->nsPtr = iPtr->globalNsPtr;
1.3114 + }
1.3115 +
1.3116 + /*
1.3117 + * Find the procedure to execute this command. If there isn't one,
1.3118 + * then see if there is a command "unknown". If so, create a new
1.3119 + * word array with "unknown" as the first word and the original
1.3120 + * command words as arguments. Then call ourselves recursively
1.3121 + * to execute it.
1.3122 + */
1.3123 + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
1.3124 + if (cmdPtr == NULL) {
1.3125 + newObjv = (Tcl_Obj **) ckalloc((unsigned)
1.3126 + ((objc + 1) * sizeof (Tcl_Obj *)));
1.3127 + for (i = objc-1; i >= 0; i--) {
1.3128 + newObjv[i+1] = objv[i];
1.3129 + }
1.3130 + newObjv[0] = Tcl_NewStringObj("::unknown", -1);
1.3131 + Tcl_IncrRefCount(newObjv[0]);
1.3132 + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
1.3133 + if (cmdPtr == NULL) {
1.3134 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.3135 + "invalid command name \"", Tcl_GetString(objv[0]), "\"",
1.3136 + (char *) NULL);
1.3137 + code = TCL_ERROR;
1.3138 + } else {
1.3139 + iPtr->numLevels++;
1.3140 + code = TclEvalObjvInternal(interp, objc+1, newObjv,
1.3141 + command, length, 0);
1.3142 + iPtr->numLevels--;
1.3143 + }
1.3144 + Tcl_DecrRefCount(newObjv[0]);
1.3145 + ckfree((char *) newObjv);
1.3146 + if (savedNsPtr) {
1.3147 + iPtr->varFramePtr->nsPtr = savedNsPtr;
1.3148 + }
1.3149 + goto done;
1.3150 + }
1.3151 + if (savedNsPtr) {
1.3152 + iPtr->varFramePtr->nsPtr = savedNsPtr;
1.3153 + }
1.3154 +
1.3155 + /*
1.3156 + * Call trace procedures if needed.
1.3157 + */
1.3158 + if ((checkTraces) && (command != NULL)) {
1.3159 + int cmdEpoch = cmdPtr->cmdEpoch;
1.3160 + int newEpoch;
1.3161 +
1.3162 + cmdPtr->refCount++;
1.3163 + /*
1.3164 + * If the first set of traces modifies/deletes the command or
1.3165 + * any existing traces, then the set checkTraces to 0 and
1.3166 + * go through this while loop one more time.
1.3167 + */
1.3168 + if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
1.3169 + traceCode = TclCheckInterpTraces(interp, command, length,
1.3170 + cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
1.3171 + }
1.3172 + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES)
1.3173 + && (traceCode == TCL_OK)) {
1.3174 + traceCode = TclCheckExecutionTraces(interp, command, length,
1.3175 + cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
1.3176 + }
1.3177 + newEpoch = cmdPtr->cmdEpoch;
1.3178 + TclCleanupCommand(cmdPtr);
1.3179 + if (cmdEpoch != newEpoch) {
1.3180 + /* The command has been modified in some way */
1.3181 + checkTraces = 0;
1.3182 + continue;
1.3183 + }
1.3184 + }
1.3185 + break;
1.3186 + }
1.3187 +
1.3188 + /*
1.3189 + * Finally, invoke the command's Tcl_ObjCmdProc.
1.3190 + */
1.3191 + cmdPtr->refCount++;
1.3192 + iPtr->cmdCount++;
1.3193 + if ( code == TCL_OK && traceCode == TCL_OK) {
1.3194 + code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
1.3195 + }
1.3196 + if (Tcl_AsyncReady()) {
1.3197 + code = Tcl_AsyncInvoke(interp, code);
1.3198 + }
1.3199 +
1.3200 + /*
1.3201 + * Call 'leave' command traces
1.3202 + */
1.3203 + if (!(cmdPtr->flags & CMD_IS_DELETED)) {
1.3204 + int saveErrFlags = iPtr->flags
1.3205 + & (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET);
1.3206 + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
1.3207 + traceCode = TclCheckExecutionTraces (interp, command, length,
1.3208 + cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
1.3209 + }
1.3210 + if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
1.3211 + traceCode = TclCheckInterpTraces(interp, command, length,
1.3212 + cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
1.3213 + }
1.3214 + if (traceCode == TCL_OK) {
1.3215 + iPtr->flags |= saveErrFlags;
1.3216 + }
1.3217 + }
1.3218 + TclCleanupCommand(cmdPtr);
1.3219 +
1.3220 + /*
1.3221 + * If one of the trace invocation resulted in error, then
1.3222 + * change the result code accordingly. Note, that the
1.3223 + * interp->result should already be set correctly by the
1.3224 + * call to TraceExecutionProc.
1.3225 + */
1.3226 +
1.3227 + if (traceCode != TCL_OK) {
1.3228 + code = traceCode;
1.3229 + }
1.3230 +
1.3231 + /*
1.3232 + * If the interpreter has a non-empty string result, the result
1.3233 + * object is either empty or stale because some procedure set
1.3234 + * interp->result directly. If so, move the string result to the
1.3235 + * result object, then reset the string result.
1.3236 + */
1.3237 +
1.3238 + if (*(iPtr->result) != 0) {
1.3239 + (void) Tcl_GetObjResult(interp);
1.3240 + }
1.3241 +
1.3242 + done:
1.3243 + iPtr->varFramePtr = savedVarFramePtr;
1.3244 + return code;
1.3245 +}
1.3246 +
1.3247 +/*
1.3248 + *----------------------------------------------------------------------
1.3249 + *
1.3250 + * Tcl_EvalObjv --
1.3251 + *
1.3252 + * This procedure evaluates a Tcl command that has already been
1.3253 + * parsed into words, with one Tcl_Obj holding each word.
1.3254 + *
1.3255 + * Results:
1.3256 + * The return value is a standard Tcl completion code such as
1.3257 + * TCL_OK or TCL_ERROR. A result or error message is left in
1.3258 + * interp's result.
1.3259 + *
1.3260 + * Side effects:
1.3261 + * Depends on the command.
1.3262 + *
1.3263 + *----------------------------------------------------------------------
1.3264 + */
1.3265 +
1.3266 +EXPORT_C int
1.3267 +Tcl_EvalObjv(interp, objc, objv, flags)
1.3268 + Tcl_Interp *interp; /* Interpreter in which to evaluate the
1.3269 + * command. Also used for error
1.3270 + * reporting. */
1.3271 + int objc; /* Number of words in command. */
1.3272 + Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are
1.3273 + * the words that make up the command. */
1.3274 + int flags; /* Collection of OR-ed bits that control
1.3275 + * the evaluation of the script. Only
1.3276 + * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE
1.3277 + * are currently supported. */
1.3278 +{
1.3279 + Interp *iPtr = (Interp *)interp;
1.3280 + Trace *tracePtr;
1.3281 + Tcl_DString cmdBuf;
1.3282 + char *cmdString = ""; /* A command string is only necessary for
1.3283 + * command traces or error logs; it will be
1.3284 + * generated to replace this default value if
1.3285 + * necessary. */
1.3286 + int cmdLen = 0; /* a non-zero value indicates that a command
1.3287 + * string was generated. */
1.3288 + int code = TCL_OK;
1.3289 + int i;
1.3290 + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
1.3291 +
1.3292 + for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) {
1.3293 + if ((tracePtr->level == 0) || (iPtr->numLevels <= tracePtr->level)) {
1.3294 + /*
1.3295 + * The command may be needed for an execution trace. Generate a
1.3296 + * command string.
1.3297 + */
1.3298 +
1.3299 + Tcl_DStringInit(&cmdBuf);
1.3300 + for (i = 0; i < objc; i++) {
1.3301 + Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
1.3302 + }
1.3303 + cmdString = Tcl_DStringValue(&cmdBuf);
1.3304 + cmdLen = Tcl_DStringLength(&cmdBuf);
1.3305 + break;
1.3306 + }
1.3307 + }
1.3308 +
1.3309 + iPtr->numLevels++;
1.3310 + code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags);
1.3311 + iPtr->numLevels--;
1.3312 +
1.3313 + /*
1.3314 + * If we are again at the top level, process any unusual
1.3315 + * return code returned by the evaluated code.
1.3316 + */
1.3317 +
1.3318 + if (iPtr->numLevels == 0) {
1.3319 + if (code == TCL_RETURN) {
1.3320 + code = TclUpdateReturnInfo(iPtr);
1.3321 + }
1.3322 + if ((code != TCL_OK) && (code != TCL_ERROR)
1.3323 + && !allowExceptions) {
1.3324 + ProcessUnexpectedResult(interp, code);
1.3325 + code = TCL_ERROR;
1.3326 + }
1.3327 + }
1.3328 +
1.3329 + if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) {
1.3330 +
1.3331 + /*
1.3332 + * If there was an error, a command string will be needed for the
1.3333 + * error log: generate it now if it was not done previously.
1.3334 + */
1.3335 +
1.3336 + if (cmdLen == 0) {
1.3337 + Tcl_DStringInit(&cmdBuf);
1.3338 + for (i = 0; i < objc; i++) {
1.3339 + Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
1.3340 + }
1.3341 + cmdString = Tcl_DStringValue(&cmdBuf);
1.3342 + cmdLen = Tcl_DStringLength(&cmdBuf);
1.3343 + }
1.3344 + Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
1.3345 + }
1.3346 +
1.3347 + if (cmdLen != 0) {
1.3348 + Tcl_DStringFree(&cmdBuf);
1.3349 + }
1.3350 + return code;
1.3351 +}
1.3352 +
1.3353 +/*
1.3354 + *----------------------------------------------------------------------
1.3355 + *
1.3356 + * Tcl_LogCommandInfo --
1.3357 + *
1.3358 + * This procedure is invoked after an error occurs in an interpreter.
1.3359 + * It adds information to the "errorInfo" variable to describe the
1.3360 + * command that was being executed when the error occurred.
1.3361 + *
1.3362 + * Results:
1.3363 + * None.
1.3364 + *
1.3365 + * Side effects:
1.3366 + * Information about the command is added to errorInfo and the
1.3367 + * line number stored internally in the interpreter is set. If this
1.3368 + * is the first call to this procedure or Tcl_AddObjErrorInfo since
1.3369 + * an error occurred, then old information in errorInfo is
1.3370 + * deleted.
1.3371 + *
1.3372 + *----------------------------------------------------------------------
1.3373 + */
1.3374 +
1.3375 +EXPORT_C void
1.3376 +Tcl_LogCommandInfo(interp, script, command, length)
1.3377 + Tcl_Interp *interp; /* Interpreter in which to log information. */
1.3378 + CONST char *script; /* First character in script containing
1.3379 + * command (must be <= command). */
1.3380 + CONST char *command; /* First character in command that
1.3381 + * generated the error. */
1.3382 + int length; /* Number of bytes in command (-1 means
1.3383 + * use all bytes up to first null byte). */
1.3384 +{
1.3385 + char buffer[200];
1.3386 + register CONST char *p;
1.3387 + char *ellipsis = "";
1.3388 + Interp *iPtr = (Interp *) interp;
1.3389 +
1.3390 + if (iPtr->flags & ERR_ALREADY_LOGGED) {
1.3391 + /*
1.3392 + * Someone else has already logged error information for this
1.3393 + * command; we shouldn't add anything more.
1.3394 + */
1.3395 +
1.3396 + return;
1.3397 + }
1.3398 +
1.3399 + /*
1.3400 + * Compute the line number where the error occurred.
1.3401 + */
1.3402 +
1.3403 + iPtr->errorLine = 1;
1.3404 + for (p = script; p != command; p++) {
1.3405 + if (*p == '\n') {
1.3406 + iPtr->errorLine++;
1.3407 + }
1.3408 + }
1.3409 +
1.3410 + /*
1.3411 + * Create an error message to add to errorInfo, including up to a
1.3412 + * maximum number of characters of the command.
1.3413 + */
1.3414 +
1.3415 + if (length < 0) {
1.3416 + length = strlen(command);
1.3417 + }
1.3418 + if (length > 150) {
1.3419 + length = 150;
1.3420 + ellipsis = "...";
1.3421 + }
1.3422 + while ( (command[length] & 0xC0) == 0x80 ) {
1.3423 + /*
1.3424 + * Back up truncation point so that we don't truncate in the
1.3425 + * middle of a multi-byte character (in UTF-8)
1.3426 + */
1.3427 + length--;
1.3428 + ellipsis = "...";
1.3429 + }
1.3430 + if (!(iPtr->flags & ERR_IN_PROGRESS)) {
1.3431 + sprintf(buffer, "\n while executing\n\"%.*s%s\"",
1.3432 + length, command, ellipsis);
1.3433 + } else {
1.3434 + sprintf(buffer, "\n invoked from within\n\"%.*s%s\"",
1.3435 + length, command, ellipsis);
1.3436 + }
1.3437 + Tcl_AddObjErrorInfo(interp, buffer, -1);
1.3438 + iPtr->flags &= ~ERR_ALREADY_LOGGED;
1.3439 +}
1.3440 +
1.3441 +/*
1.3442 + *----------------------------------------------------------------------
1.3443 + *
1.3444 + * Tcl_EvalTokensStandard, EvalTokensStandard --
1.3445 + *
1.3446 + * Given an array of tokens parsed from a Tcl command (e.g., the
1.3447 + * tokens that make up a word or the index for an array variable)
1.3448 + * this procedure evaluates the tokens and concatenates their
1.3449 + * values to form a single result value.
1.3450 + *
1.3451 + * Results:
1.3452 + * The return value is a standard Tcl completion code such as
1.3453 + * TCL_OK or TCL_ERROR. A result or error message is left in
1.3454 + * interp's result.
1.3455 + *
1.3456 + * Side effects:
1.3457 + * Depends on the array of tokens being evaled.
1.3458 + *
1.3459 + * TIP #280 : Keep public API, internally extended API.
1.3460 + *----------------------------------------------------------------------
1.3461 + */
1.3462 +
1.3463 +EXPORT_C int
1.3464 +Tcl_EvalTokensStandard(interp, tokenPtr, count)
1.3465 + Tcl_Interp *interp; /* Interpreter in which to lookup
1.3466 + * variables, execute nested commands,
1.3467 + * and report errors. */
1.3468 + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
1.3469 + * to evaluate and concatenate. */
1.3470 + int count; /* Number of tokens to consider at tokenPtr.
1.3471 + * Must be at least 1. */
1.3472 +{
1.3473 +#ifdef TCL_TIP280
1.3474 + return EvalTokensStandard (interp, tokenPtr, count, 1);
1.3475 +}
1.3476 +
1.3477 +static int
1.3478 +EvalTokensStandard(interp, tokenPtr, count, line)
1.3479 + Tcl_Interp *interp; /* Interpreter in which to lookup
1.3480 + * variables, execute nested commands,
1.3481 + * and report errors. */
1.3482 + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
1.3483 + * to evaluate and concatenate. */
1.3484 + int count; /* Number of tokens to consider at tokenPtr.
1.3485 + * Must be at least 1. */
1.3486 + int line; /* The line the script starts on. */
1.3487 +{
1.3488 +#endif
1.3489 + Tcl_Obj *resultPtr, *indexPtr, *valuePtr;
1.3490 + char buffer[TCL_UTF_MAX];
1.3491 +#ifdef TCL_MEM_DEBUG
1.3492 +# define MAX_VAR_CHARS 5
1.3493 +#else
1.3494 +# define MAX_VAR_CHARS 30
1.3495 +#endif
1.3496 + char nameBuffer[MAX_VAR_CHARS+1];
1.3497 + char *varName, *index;
1.3498 + CONST char *p = NULL; /* Initialized to avoid compiler warning. */
1.3499 + int length, code;
1.3500 +
1.3501 + /*
1.3502 + * The only tricky thing about this procedure is that it attempts to
1.3503 + * avoid object creation and string copying whenever possible. For
1.3504 + * example, if the value is just a nested command, then use the
1.3505 + * command's result object directly.
1.3506 + */
1.3507 +
1.3508 + code = TCL_OK;
1.3509 + resultPtr = NULL;
1.3510 + Tcl_ResetResult(interp);
1.3511 + for ( ; count > 0; count--, tokenPtr++) {
1.3512 + valuePtr = NULL;
1.3513 +
1.3514 + /*
1.3515 + * The switch statement below computes the next value to be
1.3516 + * concat to the result, as either a range of text or an
1.3517 + * object.
1.3518 + */
1.3519 +
1.3520 + switch (tokenPtr->type) {
1.3521 + case TCL_TOKEN_TEXT:
1.3522 + p = tokenPtr->start;
1.3523 + length = tokenPtr->size;
1.3524 + break;
1.3525 +
1.3526 + case TCL_TOKEN_BS:
1.3527 + length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
1.3528 + buffer);
1.3529 + p = buffer;
1.3530 + break;
1.3531 +
1.3532 + case TCL_TOKEN_COMMAND: {
1.3533 + Interp *iPtr = (Interp *) interp;
1.3534 + iPtr->numLevels++;
1.3535 + code = TclInterpReady(interp);
1.3536 + if (code == TCL_OK) {
1.3537 +#ifndef TCL_TIP280
1.3538 + code = Tcl_EvalEx(interp,
1.3539 + tokenPtr->start+1, tokenPtr->size-2, 0);
1.3540 +#else
1.3541 + /* TIP #280: Transfer line information to nested command */
1.3542 + code = EvalEx(interp,
1.3543 + tokenPtr->start+1, tokenPtr->size-2, 0, line);
1.3544 +#endif
1.3545 + }
1.3546 + iPtr->numLevels--;
1.3547 + if (code != TCL_OK) {
1.3548 + goto done;
1.3549 + }
1.3550 + valuePtr = Tcl_GetObjResult(interp);
1.3551 + break;
1.3552 + }
1.3553 +
1.3554 + case TCL_TOKEN_VARIABLE:
1.3555 + if (tokenPtr->numComponents == 1) {
1.3556 + indexPtr = NULL;
1.3557 + index = NULL;
1.3558 + } else {
1.3559 +#ifndef TCL_TIP280
1.3560 + code = Tcl_EvalTokensStandard(interp, tokenPtr+2,
1.3561 + tokenPtr->numComponents - 1);
1.3562 +#else
1.3563 + /* TIP #280: Transfer line information to nested command */
1.3564 + code = EvalTokensStandard(interp, tokenPtr+2,
1.3565 + tokenPtr->numComponents - 1, line);
1.3566 +#endif
1.3567 + if (code != TCL_OK) {
1.3568 + goto done;
1.3569 + }
1.3570 + indexPtr = Tcl_GetObjResult(interp);
1.3571 + Tcl_IncrRefCount(indexPtr);
1.3572 + index = Tcl_GetString(indexPtr);
1.3573 + }
1.3574 +
1.3575 + /*
1.3576 + * We have to make a copy of the variable name in order
1.3577 + * to have a null-terminated string. We can't make a
1.3578 + * temporary modification to the script to null-terminate
1.3579 + * the name, because a trace callback might potentially
1.3580 + * reuse the script and be affected by the null character.
1.3581 + */
1.3582 +
1.3583 + if (tokenPtr[1].size <= MAX_VAR_CHARS) {
1.3584 + varName = nameBuffer;
1.3585 + } else {
1.3586 + varName = ckalloc((unsigned) (tokenPtr[1].size + 1));
1.3587 + }
1.3588 + strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size);
1.3589 + varName[tokenPtr[1].size] = 0;
1.3590 + valuePtr = Tcl_GetVar2Ex(interp, varName, index,
1.3591 + TCL_LEAVE_ERR_MSG);
1.3592 + if (varName != nameBuffer) {
1.3593 + ckfree(varName);
1.3594 + }
1.3595 + if (indexPtr != NULL) {
1.3596 + Tcl_DecrRefCount(indexPtr);
1.3597 + }
1.3598 + if (valuePtr == NULL) {
1.3599 + code = TCL_ERROR;
1.3600 + goto done;
1.3601 + }
1.3602 + count -= tokenPtr->numComponents;
1.3603 + tokenPtr += tokenPtr->numComponents;
1.3604 + break;
1.3605 +
1.3606 + default:
1.3607 + panic("unexpected token type in Tcl_EvalTokensStandard");
1.3608 + }
1.3609 +
1.3610 + /*
1.3611 + * If valuePtr isn't NULL, the next piece of text comes from that
1.3612 + * object; otherwise, take length bytes starting at p.
1.3613 + */
1.3614 +
1.3615 + if (resultPtr == NULL) {
1.3616 + if (valuePtr != NULL) {
1.3617 + resultPtr = valuePtr;
1.3618 + } else {
1.3619 + resultPtr = Tcl_NewStringObj(p, length);
1.3620 + }
1.3621 + Tcl_IncrRefCount(resultPtr);
1.3622 + } else {
1.3623 + if (Tcl_IsShared(resultPtr)) {
1.3624 + Tcl_DecrRefCount(resultPtr);
1.3625 + resultPtr = Tcl_DuplicateObj(resultPtr);
1.3626 + Tcl_IncrRefCount(resultPtr);
1.3627 + }
1.3628 + if (valuePtr != NULL) {
1.3629 + p = Tcl_GetStringFromObj(valuePtr, &length);
1.3630 + }
1.3631 + Tcl_AppendToObj(resultPtr, p, length);
1.3632 + }
1.3633 + }
1.3634 + if (resultPtr != NULL) {
1.3635 + Tcl_SetObjResult(interp, resultPtr);
1.3636 + } else {
1.3637 + code = TCL_ERROR;
1.3638 + }
1.3639 +
1.3640 + done:
1.3641 + if (resultPtr != NULL) {
1.3642 + Tcl_DecrRefCount(resultPtr);
1.3643 + }
1.3644 + return code;
1.3645 +}
1.3646 +
1.3647 +/*
1.3648 + *----------------------------------------------------------------------
1.3649 + *
1.3650 + * Tcl_EvalTokens --
1.3651 + *
1.3652 + * Given an array of tokens parsed from a Tcl command (e.g., the
1.3653 + * tokens that make up a word or the index for an array variable)
1.3654 + * this procedure evaluates the tokens and concatenates their
1.3655 + * values to form a single result value.
1.3656 + *
1.3657 + * Results:
1.3658 + * The return value is a pointer to a newly allocated Tcl_Obj
1.3659 + * containing the value of the array of tokens. The reference
1.3660 + * count of the returned object has been incremented. If an error
1.3661 + * occurs in evaluating the tokens then a NULL value is returned
1.3662 + * and an error message is left in interp's result.
1.3663 + *
1.3664 + * Side effects:
1.3665 + * A new object is allocated to hold the result.
1.3666 + *
1.3667 + *----------------------------------------------------------------------
1.3668 + *
1.3669 + * This uses a non-standard return convention; its use is now deprecated.
1.3670 + * It is a wrapper for the new function Tcl_EvalTokensStandard, and is not
1.3671 + * used in the core any longer. It is only kept for backward compatibility.
1.3672 + */
1.3673 +
1.3674 +EXPORT_C Tcl_Obj *
1.3675 +Tcl_EvalTokens(interp, tokenPtr, count)
1.3676 + Tcl_Interp *interp; /* Interpreter in which to lookup
1.3677 + * variables, execute nested commands,
1.3678 + * and report errors. */
1.3679 + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
1.3680 + * to evaluate and concatenate. */
1.3681 + int count; /* Number of tokens to consider at tokenPtr.
1.3682 + * Must be at least 1. */
1.3683 +{
1.3684 + int code;
1.3685 + Tcl_Obj *resPtr;
1.3686 +
1.3687 + code = Tcl_EvalTokensStandard(interp, tokenPtr, count);
1.3688 + if (code == TCL_OK) {
1.3689 + resPtr = Tcl_GetObjResult(interp);
1.3690 + Tcl_IncrRefCount(resPtr);
1.3691 + Tcl_ResetResult(interp);
1.3692 + return resPtr;
1.3693 + } else {
1.3694 + return NULL;
1.3695 + }
1.3696 +}
1.3697 +
1.3698 +
1.3699 +/*
1.3700 + *----------------------------------------------------------------------
1.3701 + *
1.3702 + * Tcl_EvalEx, EvalEx --
1.3703 + *
1.3704 + * This procedure evaluates a Tcl script without using the compiler
1.3705 + * or byte-code interpreter. It just parses the script, creates
1.3706 + * values for each word of each command, then calls EvalObjv
1.3707 + * to execute each command.
1.3708 + *
1.3709 + * Results:
1.3710 + * The return value is a standard Tcl completion code such as
1.3711 + * TCL_OK or TCL_ERROR. A result or error message is left in
1.3712 + * interp's result.
1.3713 + *
1.3714 + * Side effects:
1.3715 + * Depends on the script.
1.3716 + *
1.3717 + * TIP #280 : Keep public API, internally extended API.
1.3718 + *----------------------------------------------------------------------
1.3719 + */
1.3720 +
1.3721 +EXPORT_C int
1.3722 +Tcl_EvalEx(interp, script, numBytes, flags)
1.3723 + Tcl_Interp *interp; /* Interpreter in which to evaluate the
1.3724 + * script. Also used for error reporting. */
1.3725 + CONST char *script; /* First character of script to evaluate. */
1.3726 + int numBytes; /* Number of bytes in script. If < 0, the
1.3727 + * script consists of all bytes up to the
1.3728 + * first null character. */
1.3729 + int flags; /* Collection of OR-ed bits that control
1.3730 + * the evaluation of the script. Only
1.3731 + * TCL_EVAL_GLOBAL is currently
1.3732 + * supported. */
1.3733 +{
1.3734 +#ifdef TCL_TIP280
1.3735 + return EvalEx (interp, script, numBytes, flags, 1);
1.3736 +}
1.3737 +
1.3738 +static int
1.3739 +EvalEx(interp, script, numBytes, flags, line)
1.3740 + Tcl_Interp *interp; /* Interpreter in which to evaluate the
1.3741 + * script. Also used for error reporting. */
1.3742 + CONST char *script; /* First character of script to evaluate. */
1.3743 + int numBytes; /* Number of bytes in script. If < 0, the
1.3744 + * script consists of all bytes up to the
1.3745 + * first null character. */
1.3746 + int flags; /* Collection of OR-ed bits that control
1.3747 + * the evaluation of the script. Only
1.3748 + * TCL_EVAL_GLOBAL is currently
1.3749 + * supported. */
1.3750 + int line; /* The line the script starts on. */
1.3751 +{
1.3752 +#endif
1.3753 + Interp *iPtr = (Interp *) interp;
1.3754 + CONST char *p, *next;
1.3755 + Tcl_Parse parse;
1.3756 +#define NUM_STATIC_OBJS 20
1.3757 + Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;
1.3758 + Tcl_Token *tokenPtr;
1.3759 + int code = TCL_OK;
1.3760 + int i, commandLength, bytesLeft, nested;
1.3761 + CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
1.3762 + * in case TCL_EVAL_GLOBAL was set. */
1.3763 + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
1.3764 +
1.3765 + /*
1.3766 + * The variables below keep track of how much state has been
1.3767 + * allocated while evaluating the script, so that it can be freed
1.3768 + * properly if an error occurs.
1.3769 + */
1.3770 +
1.3771 + int gotParse = 0, objectsUsed = 0;
1.3772 +
1.3773 +#ifdef TCL_TIP280
1.3774 + /* TIP #280 Structures for tracking of command locations. */
1.3775 + CmdFrame eeFrame;
1.3776 +#endif
1.3777 +
1.3778 + if (numBytes < 0) {
1.3779 + numBytes = strlen(script);
1.3780 + }
1.3781 + Tcl_ResetResult(interp);
1.3782 +
1.3783 + savedVarFramePtr = iPtr->varFramePtr;
1.3784 + if (flags & TCL_EVAL_GLOBAL) {
1.3785 + iPtr->varFramePtr = NULL;
1.3786 + }
1.3787 +
1.3788 + /*
1.3789 + * Each iteration through the following loop parses the next
1.3790 + * command from the script and then executes it.
1.3791 + */
1.3792 +
1.3793 + objv = staticObjArray;
1.3794 + p = script;
1.3795 + bytesLeft = numBytes;
1.3796 + if (iPtr->evalFlags & TCL_BRACKET_TERM) {
1.3797 + nested = 1;
1.3798 + } else {
1.3799 + nested = 0;
1.3800 + }
1.3801 +
1.3802 +#ifdef TCL_TIP280
1.3803 + /* TIP #280 Initialize tracking. Do not push on the frame stack yet. */
1.3804 + /*
1.3805 + * We may cont. counting based on a specific context (CTX), or open a new
1.3806 + * context, either for a sourced script, or 'eval'. For sourced files we
1.3807 + * always have a path object, even if nothing was specified in the interp
1.3808 + * itself. That makes code using it simpler as NULL checks can be left
1.3809 + * out. Sourced file without path in the 'scriptFile' is possible during
1.3810 + * Tcl initialization.
1.3811 + */
1.3812 +
1.3813 + if (iPtr->evalFlags & TCL_EVAL_CTX) {
1.3814 + /* Path information comes out of the context. */
1.3815 +
1.3816 + eeFrame.type = TCL_LOCATION_SOURCE;
1.3817 + eeFrame.data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path;
1.3818 + Tcl_IncrRefCount (eeFrame.data.eval.path);
1.3819 + } else if (iPtr->evalFlags & TCL_EVAL_FILE) {
1.3820 + /* Set up for a sourced file */
1.3821 +
1.3822 + eeFrame.type = TCL_LOCATION_SOURCE;
1.3823 +
1.3824 + if (iPtr->scriptFile) {
1.3825 + /* Normalization here, to have the correct pwd. Should have
1.3826 + * negligible impact on performance, as the norm should have been
1.3827 + * done already by the 'source' invoking us, and it caches the
1.3828 + * result
1.3829 + */
1.3830 +
1.3831 + Tcl_Obj* norm = Tcl_FSGetNormalizedPath (interp, iPtr->scriptFile);
1.3832 + if (!norm) {
1.3833 + /* Error message in the interp result */
1.3834 + return TCL_ERROR;
1.3835 + }
1.3836 + eeFrame.data.eval.path = norm;
1.3837 + Tcl_IncrRefCount (eeFrame.data.eval.path);
1.3838 + } else {
1.3839 + eeFrame.data.eval.path = Tcl_NewStringObj ("",-1);
1.3840 + }
1.3841 + } else {
1.3842 + /* Set up for plain eval */
1.3843 +
1.3844 + eeFrame.type = TCL_LOCATION_EVAL;
1.3845 + eeFrame.data.eval.path = NULL;
1.3846 + }
1.3847 +
1.3848 + eeFrame.level = (iPtr->cmdFramePtr == NULL
1.3849 + ? 1
1.3850 + : iPtr->cmdFramePtr->level + 1);
1.3851 + eeFrame.framePtr = iPtr->framePtr;
1.3852 + eeFrame.nextPtr = iPtr->cmdFramePtr;
1.3853 + eeFrame.nline = 0;
1.3854 + eeFrame.line = NULL;
1.3855 +#endif
1.3856 +
1.3857 + iPtr->evalFlags = 0;
1.3858 + do {
1.3859 + if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse)
1.3860 + != TCL_OK) {
1.3861 + code = TCL_ERROR;
1.3862 + goto error;
1.3863 + }
1.3864 + gotParse = 1;
1.3865 +
1.3866 + if (nested && parse.term == (script + numBytes)) {
1.3867 + /*
1.3868 + * A nested script can only terminate in ']'. If
1.3869 + * the parsing got terminated at the end of the script,
1.3870 + * there was no closing ']'. Report the syntax error.
1.3871 + */
1.3872 +
1.3873 + code = TCL_ERROR;
1.3874 + goto error;
1.3875 + }
1.3876 +
1.3877 +#ifdef TCL_TIP280
1.3878 + /*
1.3879 + * TIP #280 Track lines. The parser may have skipped text till it
1.3880 + * found the command we are now at. We have count the lines in this
1.3881 + * block.
1.3882 + */
1.3883 +
1.3884 + TclAdvanceLines (&line, p, parse.commandStart);
1.3885 +#endif
1.3886 +
1.3887 + if (parse.numWords > 0) {
1.3888 +#ifdef TCL_TIP280
1.3889 + /*
1.3890 + * TIP #280. Track lines within the words of the current
1.3891 + * command.
1.3892 + */
1.3893 +
1.3894 + int wordLine = line;
1.3895 + CONST char* wordStart = parse.commandStart;
1.3896 +#endif
1.3897 +
1.3898 + /*
1.3899 + * Generate an array of objects for the words of the command.
1.3900 + */
1.3901 +
1.3902 + if (parse.numWords <= NUM_STATIC_OBJS) {
1.3903 + objv = staticObjArray;
1.3904 + } else {
1.3905 + objv = (Tcl_Obj **) ckalloc((unsigned)
1.3906 + (parse.numWords * sizeof (Tcl_Obj *)));
1.3907 + }
1.3908 +
1.3909 +#ifdef TCL_TIP280
1.3910 + eeFrame.nline = parse.numWords;
1.3911 + eeFrame.line = (int*) ckalloc((unsigned)
1.3912 + (parse.numWords * sizeof (int)));
1.3913 +#endif
1.3914 +
1.3915 + for (objectsUsed = 0, tokenPtr = parse.tokenPtr;
1.3916 + objectsUsed < parse.numWords;
1.3917 + objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) {
1.3918 +#ifndef TCL_TIP280
1.3919 + code = Tcl_EvalTokensStandard(interp, tokenPtr+1,
1.3920 + tokenPtr->numComponents);
1.3921 +#else
1.3922 + /*
1.3923 + * TIP #280. Track lines to current word. Save the
1.3924 + * information on a per-word basis, signaling dynamic words as
1.3925 + * needed. Make the information available to the recursively
1.3926 + * called evaluator as well, including the type of context
1.3927 + * (source vs. eval).
1.3928 + */
1.3929 +
1.3930 + TclAdvanceLines (&wordLine, wordStart, tokenPtr->start);
1.3931 + wordStart = tokenPtr->start;
1.3932 +
1.3933 + eeFrame.line [objectsUsed] = (TclWordKnownAtCompileTime (tokenPtr)
1.3934 + ? wordLine
1.3935 + : -1);
1.3936 +
1.3937 + if (eeFrame.type == TCL_LOCATION_SOURCE) {
1.3938 + iPtr->evalFlags |= TCL_EVAL_FILE;
1.3939 + }
1.3940 +
1.3941 + code = EvalTokensStandard(interp, tokenPtr+1,
1.3942 + tokenPtr->numComponents, wordLine);
1.3943 +
1.3944 + iPtr->evalFlags = 0;
1.3945 +#endif
1.3946 +
1.3947 + if (code == TCL_OK) {
1.3948 + objv[objectsUsed] = Tcl_GetObjResult(interp);
1.3949 + Tcl_IncrRefCount(objv[objectsUsed]);
1.3950 + } else {
1.3951 + goto error;
1.3952 + }
1.3953 + }
1.3954 +
1.3955 + /*
1.3956 + * Execute the command and free the objects for its words.
1.3957 + *
1.3958 + * TIP #280: Remember the command itself for 'info frame'. We
1.3959 + * shorten the visible command by one char to exclude the
1.3960 + * termination character, if necessary. Here is where we put our
1.3961 + * frame on the stack of frames too. _After_ the nested commands
1.3962 + * have been executed.
1.3963 + */
1.3964 +
1.3965 +#ifdef TCL_TIP280
1.3966 + eeFrame.cmd.str.cmd = parse.commandStart;
1.3967 + eeFrame.cmd.str.len = parse.commandSize;
1.3968 +
1.3969 + if (parse.term == parse.commandStart + parse.commandSize - 1) {
1.3970 + eeFrame.cmd.str.len --;
1.3971 + }
1.3972 +
1.3973 + iPtr->cmdFramePtr = &eeFrame;
1.3974 +#endif
1.3975 + iPtr->numLevels++;
1.3976 + code = TclEvalObjvInternal(interp, objectsUsed, objv,
1.3977 + parse.commandStart, parse.commandSize, 0);
1.3978 + iPtr->numLevels--;
1.3979 +#ifdef TCL_TIP280
1.3980 + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
1.3981 +
1.3982 + ckfree ((char*) eeFrame.line);
1.3983 + eeFrame.line = NULL;
1.3984 + eeFrame.nline = 0;
1.3985 +#endif
1.3986 +
1.3987 + if (code != TCL_OK) {
1.3988 + goto error;
1.3989 + }
1.3990 + for (i = 0; i < objectsUsed; i++) {
1.3991 + Tcl_DecrRefCount(objv[i]);
1.3992 + }
1.3993 + objectsUsed = 0;
1.3994 + if (objv != staticObjArray) {
1.3995 + ckfree((char *) objv);
1.3996 + objv = staticObjArray;
1.3997 + }
1.3998 + }
1.3999 +
1.4000 + /*
1.4001 + * Advance to the next command in the script.
1.4002 + *
1.4003 + * TIP #280 Track Lines. Now we track how many lines were in the
1.4004 + * executed command.
1.4005 + */
1.4006 +
1.4007 + next = parse.commandStart + parse.commandSize;
1.4008 + bytesLeft -= next - p;
1.4009 + p = next;
1.4010 +#ifdef TCL_TIP280
1.4011 + TclAdvanceLines (&line, parse.commandStart, p);
1.4012 +#endif
1.4013 + Tcl_FreeParse(&parse);
1.4014 + gotParse = 0;
1.4015 + if (nested && (*parse.term == ']')) {
1.4016 + /*
1.4017 + * We get here in the special case where the TCL_BRACKET_TERM
1.4018 + * flag was set in the interpreter and the latest parsed command
1.4019 + * was terminated by the matching close-bracket we seek.
1.4020 + * Return immediately.
1.4021 + */
1.4022 +
1.4023 + iPtr->termOffset = (p - 1) - script;
1.4024 + iPtr->varFramePtr = savedVarFramePtr;
1.4025 +#ifndef TCL_TIP280
1.4026 + return TCL_OK;
1.4027 +#else
1.4028 + code = TCL_OK;
1.4029 + goto cleanup_return;
1.4030 +#endif
1.4031 + }
1.4032 + } while (bytesLeft > 0);
1.4033 +
1.4034 + if (nested) {
1.4035 + /*
1.4036 + * This nested script did not terminate in ']', it is an error.
1.4037 + */
1.4038 +
1.4039 + code = TCL_ERROR;
1.4040 + goto error;
1.4041 + }
1.4042 +
1.4043 + iPtr->termOffset = p - script;
1.4044 + iPtr->varFramePtr = savedVarFramePtr;
1.4045 +#ifndef TCL_TIP280
1.4046 + return TCL_OK;
1.4047 +#else
1.4048 + code = TCL_OK;
1.4049 + goto cleanup_return;
1.4050 +#endif
1.4051 +
1.4052 + error:
1.4053 + /*
1.4054 + * Generate various pieces of error information, such as the line
1.4055 + * number where the error occurred and information to add to the
1.4056 + * errorInfo variable. Then free resources that had been allocated
1.4057 + * to the command.
1.4058 + */
1.4059 +
1.4060 + if (iPtr->numLevels == 0) {
1.4061 + if (code == TCL_RETURN) {
1.4062 + code = TclUpdateReturnInfo(iPtr);
1.4063 + }
1.4064 + if ((code != TCL_OK) && (code != TCL_ERROR)
1.4065 + && !allowExceptions) {
1.4066 + ProcessUnexpectedResult(interp, code);
1.4067 + code = TCL_ERROR;
1.4068 + }
1.4069 + }
1.4070 + if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
1.4071 + commandLength = parse.commandSize;
1.4072 + if (parse.term == parse.commandStart + commandLength - 1) {
1.4073 + /*
1.4074 + * The terminator character (such as ; or ]) of the command where
1.4075 + * the error occurred is the last character in the parsed command.
1.4076 + * Reduce the length by one so that the error message doesn't
1.4077 + * include the terminator character.
1.4078 + */
1.4079 +
1.4080 + commandLength -= 1;
1.4081 + }
1.4082 + Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength);
1.4083 + }
1.4084 +
1.4085 + for (i = 0; i < objectsUsed; i++) {
1.4086 + Tcl_DecrRefCount(objv[i]);
1.4087 + }
1.4088 + if (gotParse) {
1.4089 + Tcl_FreeParse(&parse);
1.4090 + }
1.4091 + if (objv != staticObjArray) {
1.4092 + ckfree((char *) objv);
1.4093 + }
1.4094 + iPtr->varFramePtr = savedVarFramePtr;
1.4095 +
1.4096 + /*
1.4097 + * All that's left to do before returning is to set iPtr->termOffset
1.4098 + * to point past the end of the script we just evaluated.
1.4099 + */
1.4100 +
1.4101 + next = parse.commandStart + parse.commandSize;
1.4102 + bytesLeft -= next - p;
1.4103 + p = next;
1.4104 +
1.4105 + if (!nested) {
1.4106 + iPtr->termOffset = p - script;
1.4107 +#ifndef TCL_TIP280
1.4108 + return code;
1.4109 +#else
1.4110 + goto cleanup_return;
1.4111 +#endif
1.4112 + }
1.4113 +
1.4114 + /*
1.4115 + * When we are nested (the TCL_BRACKET_TERM flag was set in the
1.4116 + * interpreter), we must find the matching close-bracket to
1.4117 + * end the script we are evaluating.
1.4118 + *
1.4119 + * When our return code is TCL_CONTINUE or TCL_RETURN, we want
1.4120 + * to correctly set iPtr->termOffset to point to that matching
1.4121 + * close-bracket so our caller can move to the part of the
1.4122 + * string beyond the script we were asked to evaluate.
1.4123 + * So we try to parse past the rest of the commands.
1.4124 + */
1.4125 +
1.4126 + next = NULL;
1.4127 + while (bytesLeft && (*parse.term != ']')) {
1.4128 + if (TCL_OK != Tcl_ParseCommand(NULL, p, bytesLeft, 1, &parse)) {
1.4129 + /*
1.4130 + * Syntax error. Set the termOffset to the beginning of
1.4131 + * the last command parsed.
1.4132 + */
1.4133 +
1.4134 + if (next == NULL) {
1.4135 + iPtr->termOffset = (parse.commandStart - 1) - script;
1.4136 + } else {
1.4137 + iPtr->termOffset = (next - 1) - script;
1.4138 + }
1.4139 +#ifndef TCL_TIP280
1.4140 + return code;
1.4141 +#else
1.4142 + goto cleanup_return;
1.4143 +#endif
1.4144 + }
1.4145 + next = parse.commandStart + parse.commandSize;
1.4146 + bytesLeft -= next - p;
1.4147 + p = next;
1.4148 + next = parse.commandStart;
1.4149 + Tcl_FreeParse(&parse);
1.4150 + }
1.4151 +
1.4152 + if (bytesLeft) {
1.4153 + /*
1.4154 + * parse.term points to the close-bracket.
1.4155 + */
1.4156 +
1.4157 + iPtr->termOffset = parse.term - script;
1.4158 + } else if (parse.term == script + numBytes) {
1.4159 + /*
1.4160 + * There was no close-bracket. Syntax error.
1.4161 + */
1.4162 +
1.4163 + iPtr->termOffset = parse.term - script;
1.4164 + Tcl_SetObjResult(interp,
1.4165 + Tcl_NewStringObj("missing close-bracket", -1));
1.4166 +#ifndef TCL_TIP280
1.4167 + return TCL_ERROR;
1.4168 +#else
1.4169 + code = TCL_ERROR;
1.4170 + goto cleanup_return;
1.4171 +#endif
1.4172 + } else if (*parse.term != ']') {
1.4173 + /*
1.4174 + * There was no close-bracket. Syntax error.
1.4175 + */
1.4176 +
1.4177 + iPtr->termOffset = (parse.term + 1) - script;
1.4178 + Tcl_SetObjResult(interp,
1.4179 + Tcl_NewStringObj("missing close-bracket", -1));
1.4180 +#ifndef TCL_TIP280
1.4181 + return TCL_ERROR;
1.4182 +#else
1.4183 + code = TCL_ERROR;
1.4184 + goto cleanup_return;
1.4185 +#endif
1.4186 + } else {
1.4187 + /*
1.4188 + * parse.term points to the close-bracket.
1.4189 + */
1.4190 + iPtr->termOffset = parse.term - script;
1.4191 + }
1.4192 +
1.4193 +#ifdef TCL_TIP280
1.4194 + cleanup_return:
1.4195 + /* TIP #280. Release the local CmdFrame, and its contents. */
1.4196 +
1.4197 + if (eeFrame.line != NULL) {
1.4198 + ckfree ((char*) eeFrame.line);
1.4199 + }
1.4200 + if (eeFrame.type == TCL_LOCATION_SOURCE) {
1.4201 + Tcl_DecrRefCount (eeFrame.data.eval.path);
1.4202 + }
1.4203 +#endif
1.4204 + return code;
1.4205 +}
1.4206 +
1.4207 +#ifdef TCL_TIP280
1.4208 +/*
1.4209 + *----------------------------------------------------------------------
1.4210 + *
1.4211 + * TclAdvanceLines --
1.4212 + *
1.4213 + * This procedure is a helper which counts the number of lines
1.4214 + * in a block of text and advances an external counter.
1.4215 + *
1.4216 + * Results:
1.4217 + * None.
1.4218 + *
1.4219 + * Side effects:
1.4220 + * The specified counter is advanced per the number of lines found.
1.4221 + *
1.4222 + * TIP #280
1.4223 + *----------------------------------------------------------------------
1.4224 + */
1.4225 +
1.4226 +void
1.4227 +TclAdvanceLines (line,start,end)
1.4228 + int* line;
1.4229 + CONST char* start;
1.4230 + CONST char* end;
1.4231 +{
1.4232 + CONST char* p;
1.4233 + for (p = start; p < end; p++) {
1.4234 + if (*p == '\n') {
1.4235 + (*line) ++;
1.4236 + }
1.4237 + }
1.4238 +}
1.4239 +#endif
1.4240 +
1.4241 +/*
1.4242 + *----------------------------------------------------------------------
1.4243 + *
1.4244 + * Tcl_Eval --
1.4245 + *
1.4246 + * Execute a Tcl command in a string. This procedure executes the
1.4247 + * script directly, rather than compiling it to bytecodes. Before
1.4248 + * the arrival of the bytecode compiler in Tcl 8.0 Tcl_Eval was
1.4249 + * the main procedure used for executing Tcl commands, but nowadays
1.4250 + * it isn't used much.
1.4251 + *
1.4252 + * Results:
1.4253 + * The return value is one of the return codes defined in tcl.h
1.4254 + * (such as TCL_OK), and interp's result contains a value
1.4255 + * to supplement the return code. The value of the result
1.4256 + * will persist only until the next call to Tcl_Eval or Tcl_EvalObj:
1.4257 + * you must copy it or lose it!
1.4258 + *
1.4259 + * Side effects:
1.4260 + * Can be almost arbitrary, depending on the commands in the script.
1.4261 + *
1.4262 + *----------------------------------------------------------------------
1.4263 + */
1.4264 +
1.4265 +EXPORT_C int
1.4266 +Tcl_Eval(interp, string)
1.4267 + Tcl_Interp *interp; /* Token for command interpreter (returned
1.4268 + * by previous call to Tcl_CreateInterp). */
1.4269 + CONST char *string; /* Pointer to TCL command to execute. */
1.4270 +{
1.4271 + int code = Tcl_EvalEx(interp, string, -1, 0);
1.4272 +
1.4273 + /*
1.4274 + * For backwards compatibility with old C code that predates the
1.4275 + * object system in Tcl 8.0, we have to mirror the object result
1.4276 + * back into the string result (some callers may expect it there).
1.4277 + */
1.4278 +
1.4279 + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
1.4280 + TCL_VOLATILE);
1.4281 + return code;
1.4282 +}
1.4283 +
1.4284 +/*
1.4285 + *----------------------------------------------------------------------
1.4286 + *
1.4287 + * Tcl_EvalObj, Tcl_GlobalEvalObj --
1.4288 + *
1.4289 + * These functions are deprecated but we keep them around for backwards
1.4290 + * compatibility reasons.
1.4291 + *
1.4292 + * Results:
1.4293 + * See the functions they call.
1.4294 + *
1.4295 + * Side effects:
1.4296 + * See the functions they call.
1.4297 + *
1.4298 + *----------------------------------------------------------------------
1.4299 + */
1.4300 +
1.4301 +#undef Tcl_EvalObj
1.4302 +EXPORT_C int
1.4303 +Tcl_EvalObj(interp, objPtr)
1.4304 + Tcl_Interp * interp;
1.4305 + Tcl_Obj * objPtr;
1.4306 +{
1.4307 + return Tcl_EvalObjEx(interp, objPtr, 0);
1.4308 +}
1.4309 +
1.4310 +#undef Tcl_GlobalEvalObj
1.4311 +EXPORT_C int
1.4312 +Tcl_GlobalEvalObj(interp, objPtr)
1.4313 + Tcl_Interp * interp;
1.4314 + Tcl_Obj * objPtr;
1.4315 +{
1.4316 + return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
1.4317 +}
1.4318 +
1.4319 +/*
1.4320 + *----------------------------------------------------------------------
1.4321 + *
1.4322 + * Tcl_EvalObjEx, TclEvalObjEx --
1.4323 + *
1.4324 + * Execute Tcl commands stored in a Tcl object. These commands are
1.4325 + * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT
1.4326 + * is specified.
1.4327 + *
1.4328 + * Results:
1.4329 + * The return value is one of the return codes defined in tcl.h
1.4330 + * (such as TCL_OK), and the interpreter's result contains a value
1.4331 + * to supplement the return code.
1.4332 + *
1.4333 + * Side effects:
1.4334 + * The object is converted, if necessary, to a ByteCode object that
1.4335 + * holds the bytecode instructions for the commands. Executing the
1.4336 + * commands will almost certainly have side effects that depend
1.4337 + * on those commands.
1.4338 + *
1.4339 + * Just as in Tcl_Eval, interp->termOffset is set to the offset of the
1.4340 + * last character executed in the objPtr's string.
1.4341 + *
1.4342 + * TIP #280 : Keep public API, internally extended API.
1.4343 + *----------------------------------------------------------------------
1.4344 + */
1.4345 +
1.4346 +EXPORT_C int
1.4347 +Tcl_EvalObjEx(interp, objPtr, flags)
1.4348 + Tcl_Interp *interp; /* Token for command interpreter
1.4349 + * (returned by a previous call to
1.4350 + * Tcl_CreateInterp). */
1.4351 + register Tcl_Obj *objPtr; /* Pointer to object containing
1.4352 + * commands to execute. */
1.4353 + int flags; /* Collection of OR-ed bits that
1.4354 + * control the evaluation of the
1.4355 + * script. Supported values are
1.4356 + * TCL_EVAL_GLOBAL and
1.4357 + * TCL_EVAL_DIRECT. */
1.4358 +{
1.4359 +#ifdef TCL_TIP280
1.4360 + return TclEvalObjEx (interp, objPtr, flags, NULL, 0);
1.4361 +}
1.4362 +
1.4363 +int
1.4364 +TclEvalObjEx(interp, objPtr, flags, invoker, word)
1.4365 + Tcl_Interp *interp; /* Token for command interpreter
1.4366 + * (returned by a previous call to
1.4367 + * Tcl_CreateInterp). */
1.4368 + register Tcl_Obj *objPtr; /* Pointer to object containing
1.4369 + * commands to execute. */
1.4370 + int flags; /* Collection of OR-ed bits that
1.4371 + * control the evaluation of the
1.4372 + * script. Supported values are
1.4373 + * TCL_EVAL_GLOBAL and
1.4374 + * TCL_EVAL_DIRECT. */
1.4375 + CONST CmdFrame* invoker; /* Frame of the command doing the eval */
1.4376 + int word; /* Index of the word which is in objPtr */
1.4377 +{
1.4378 +#endif
1.4379 + register Interp *iPtr = (Interp *) interp;
1.4380 + char *script;
1.4381 + int numSrcBytes;
1.4382 + int result;
1.4383 + CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
1.4384 + * in case TCL_EVAL_GLOBAL was set. */
1.4385 + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
1.4386 +
1.4387 + Tcl_IncrRefCount(objPtr);
1.4388 +
1.4389 + if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) {
1.4390 + /*
1.4391 + * We're not supposed to use the compiler or byte-code interpreter.
1.4392 + * Let Tcl_EvalEx evaluate the command directly (and probably
1.4393 + * more slowly).
1.4394 + *
1.4395 + * Pure List Optimization (no string representation). In this
1.4396 + * case, we can safely use Tcl_EvalObjv instead and get an
1.4397 + * appreciable improvement in execution speed. This is because it
1.4398 + * allows us to avoid a setFromAny step that would just pack
1.4399 + * everything into a string and back out again.
1.4400 + *
1.4401 + * USE_EVAL_DIRECT is a special flag used for testing purpose only
1.4402 + * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt)
1.4403 + */
1.4404 + if (!(iPtr->flags & USE_EVAL_DIRECT) &&
1.4405 + (objPtr->typePtr == &tclListType) && /* is a list... */
1.4406 + (objPtr->bytes == NULL) /* ...without a string rep */) {
1.4407 + register List *listRepPtr =
1.4408 + (List *) objPtr->internalRep.twoPtrValue.ptr1;
1.4409 + int i, objc = listRepPtr->elemCount;
1.4410 +
1.4411 +#define TEOE_PREALLOC 10
1.4412 + Tcl_Obj *staticObjv[TEOE_PREALLOC], **objv = staticObjv;
1.4413 +
1.4414 +#ifdef TCL_TIP280
1.4415 + /* TIP #280 Structures for tracking lines.
1.4416 + * As we know that this is dynamic execution we ignore the
1.4417 + * invoker, even if known.
1.4418 + */
1.4419 + int line;
1.4420 + CmdFrame eoFrame;
1.4421 +
1.4422 + eoFrame.type = TCL_LOCATION_EVAL_LIST;
1.4423 + eoFrame.level = (iPtr->cmdFramePtr == NULL ?
1.4424 + 1 :
1.4425 + iPtr->cmdFramePtr->level + 1);
1.4426 + eoFrame.framePtr = iPtr->framePtr;
1.4427 + eoFrame.nextPtr = iPtr->cmdFramePtr;
1.4428 + eoFrame.nline = objc;
1.4429 + eoFrame.line = (int*) ckalloc (objc * sizeof (int));
1.4430 +
1.4431 + /* NOTE: Getting the string rep of the list to eval to fill the
1.4432 + * command information required by 'info frame' implies that
1.4433 + * further calls for the same list would not be optimized, as it
1.4434 + * would not be 'pure' anymore. It would also be a waste of time
1.4435 + * as most of the time this information is not needed at all. What
1.4436 + * we do instead is to keep the list obj itself around and have
1.4437 + * 'info frame' sort it out.
1.4438 + */
1.4439 +
1.4440 + eoFrame.cmd.listPtr = objPtr;
1.4441 + Tcl_IncrRefCount (eoFrame.cmd.listPtr);
1.4442 + eoFrame.data.eval.path = NULL;
1.4443 +#endif
1.4444 + if (objc > TEOE_PREALLOC) {
1.4445 + objv = (Tcl_Obj **) ckalloc(objc*sizeof(Tcl_Obj *));
1.4446 + }
1.4447 +#undef TEOE_PREALLOC
1.4448 + /*
1.4449 + * Copy the list elements here, to avoid a segfault if
1.4450 + * objPtr loses its List internal rep [Bug 1119369].
1.4451 + *
1.4452 + * TIP #280 Computes all the line numbers for the
1.4453 + * words in the command.
1.4454 + */
1.4455 +
1.4456 +#ifdef TCL_TIP280
1.4457 + line = 1;
1.4458 +#endif
1.4459 + for (i=0; i < objc; i++) {
1.4460 + objv[i] = listRepPtr->elements[i];
1.4461 + Tcl_IncrRefCount(objv[i]);
1.4462 +#ifdef TCL_TIP280
1.4463 + eoFrame.line [i] = line;
1.4464 + {
1.4465 + char* w = Tcl_GetString (objv [i]);
1.4466 + TclAdvanceLines (&line, w, w+ strlen(w));
1.4467 + }
1.4468 +#endif
1.4469 + }
1.4470 +
1.4471 +#ifdef TCL_TIP280
1.4472 + iPtr->cmdFramePtr = &eoFrame;
1.4473 +#endif
1.4474 + result = Tcl_EvalObjv(interp, objc, objv, flags);
1.4475 +#ifdef TCL_TIP280
1.4476 + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
1.4477 + Tcl_DecrRefCount (eoFrame.cmd.listPtr);
1.4478 +#endif
1.4479 +
1.4480 + for (i=0; i < objc; i++) {
1.4481 + TclDecrRefCount(objv[i]);
1.4482 + }
1.4483 + if (objv != staticObjv) {
1.4484 + ckfree((char *) objv);
1.4485 + }
1.4486 +#ifdef TCL_TIP280
1.4487 + ckfree ((char*) eoFrame.line);
1.4488 + eoFrame.line = NULL;
1.4489 + eoFrame.nline = 0;
1.4490 +#endif
1.4491 + } else {
1.4492 +#ifndef TCL_TIP280
1.4493 + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
1.4494 + result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
1.4495 +#else
1.4496 + /*
1.4497 + * TIP #280. Propagate context as much as we can. Especially if
1.4498 + * the script to evaluate is a single literal it makes sense to
1.4499 + * look if our context is one with absolute line numbers we can
1.4500 + * then track into the literal itself too.
1.4501 + *
1.4502 + * See also tclCompile.c, TclInitCompileEnv, for the equivalent
1.4503 + * code in the bytecode compiler.
1.4504 + */
1.4505 +
1.4506 + if (invoker == NULL) {
1.4507 + /* No context, force opening of our own */
1.4508 + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
1.4509 + result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
1.4510 + } else {
1.4511 + /* We have an invoker, describing the command asking for the
1.4512 + * evaluation of a subordinate script. This script may
1.4513 + * originate in a literal word, or from a variable, etc. Using
1.4514 + * the line array we now check if we have good line
1.4515 + * information for the relevant word. The type of context is
1.4516 + * relevant as well. In a non-'source' context we don't have
1.4517 + * to try tracking lines.
1.4518 + *
1.4519 + * First see if the word exists and is a literal. If not we go
1.4520 + * through the easy dynamic branch. No need to perform more
1.4521 + * complex invokations.
1.4522 + */
1.4523 +
1.4524 + if ((invoker->nline <= word) || (invoker->line[word] < 0)) {
1.4525 + /* Dynamic script, or dynamic context, force our own
1.4526 + * context */
1.4527 +
1.4528 + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
1.4529 + result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
1.4530 +
1.4531 + } else {
1.4532 + /* Try to get an absolute context for the evaluation
1.4533 + */
1.4534 +
1.4535 + CmdFrame ctx = *invoker;
1.4536 + int pc = 0;
1.4537 +
1.4538 + if (invoker->type == TCL_LOCATION_BC) {
1.4539 + /* Note: Type BC => ctx.data.eval.path is not used.
1.4540 + * ctx.data.tebc.codePtr is used instead.
1.4541 + */
1.4542 + TclGetSrcInfoForPc (&ctx);
1.4543 + pc = 1;
1.4544 + }
1.4545 +
1.4546 + if (ctx.type == TCL_LOCATION_SOURCE) {
1.4547 + /* Absolute context to reuse. */
1.4548 +
1.4549 + iPtr->invokeCmdFramePtr = &ctx;
1.4550 + iPtr->evalFlags |= TCL_EVAL_CTX;
1.4551 +
1.4552 + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
1.4553 + result = EvalEx(interp, script, numSrcBytes, flags, ctx.line [word]);
1.4554 +
1.4555 + if (pc) {
1.4556 + /* Death of SrcInfo reference */
1.4557 + Tcl_DecrRefCount (ctx.data.eval.path);
1.4558 + }
1.4559 + } else {
1.4560 + /* Dynamic context or script, easier to make our own as
1.4561 + * well */
1.4562 + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
1.4563 + result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
1.4564 + }
1.4565 + }
1.4566 + }
1.4567 +#endif
1.4568 + }
1.4569 + } else {
1.4570 + /*
1.4571 + * Let the compiler/engine subsystem do the evaluation.
1.4572 + *
1.4573 + * TIP #280 The invoker provides us with the context for the
1.4574 + * script. We transfer this to the byte code compiler.
1.4575 + */
1.4576 +
1.4577 + savedVarFramePtr = iPtr->varFramePtr;
1.4578 + if (flags & TCL_EVAL_GLOBAL) {
1.4579 + iPtr->varFramePtr = NULL;
1.4580 + }
1.4581 +
1.4582 +#ifndef TCL_TIP280
1.4583 + result = TclCompEvalObj(interp, objPtr);
1.4584 +#else
1.4585 + result = TclCompEvalObj(interp, objPtr, invoker, word);
1.4586 +#endif
1.4587 +
1.4588 + /*
1.4589 + * If we are again at the top level, process any unusual
1.4590 + * return code returned by the evaluated code.
1.4591 + */
1.4592 +
1.4593 + if (iPtr->numLevels == 0) {
1.4594 + if (result == TCL_RETURN) {
1.4595 + result = TclUpdateReturnInfo(iPtr);
1.4596 + }
1.4597 + if ((result != TCL_OK) && (result != TCL_ERROR)
1.4598 + && !allowExceptions) {
1.4599 + ProcessUnexpectedResult(interp, result);
1.4600 + result = TCL_ERROR;
1.4601 +
1.4602 + /*
1.4603 + * If an error was created here, record information about
1.4604 + * what was being executed when the error occurred. Remove
1.4605 + * the extra \n added by tclMain.c in the command sent to
1.4606 + * Tcl_LogCommandInfo [Bug 833150].
1.4607 + */
1.4608 +
1.4609 + if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
1.4610 + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
1.4611 + Tcl_LogCommandInfo(interp, script, script, --numSrcBytes);
1.4612 + iPtr->flags &= ~ERR_ALREADY_LOGGED;
1.4613 + }
1.4614 + }
1.4615 + }
1.4616 + iPtr->evalFlags = 0;
1.4617 + iPtr->varFramePtr = savedVarFramePtr;
1.4618 + }
1.4619 +
1.4620 + TclDecrRefCount(objPtr);
1.4621 + return result;
1.4622 +}
1.4623 +
1.4624 +/*
1.4625 + *----------------------------------------------------------------------
1.4626 + *
1.4627 + * ProcessUnexpectedResult --
1.4628 + *
1.4629 + * Procedure called by Tcl_EvalObj to set the interpreter's result
1.4630 + * value to an appropriate error message when the code it evaluates
1.4631 + * returns an unexpected result code (not TCL_OK and not TCL_ERROR) to
1.4632 + * the topmost evaluation level.
1.4633 + *
1.4634 + * Results:
1.4635 + * None.
1.4636 + *
1.4637 + * Side effects:
1.4638 + * The interpreter result is set to an error message appropriate to
1.4639 + * the result code.
1.4640 + *
1.4641 + *----------------------------------------------------------------------
1.4642 + */
1.4643 +
1.4644 +static void
1.4645 +ProcessUnexpectedResult(interp, returnCode)
1.4646 + Tcl_Interp *interp; /* The interpreter in which the unexpected
1.4647 + * result code was returned. */
1.4648 + int returnCode; /* The unexpected result code. */
1.4649 +{
1.4650 + Tcl_ResetResult(interp);
1.4651 + if (returnCode == TCL_BREAK) {
1.4652 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.4653 + "invoked \"break\" outside of a loop", -1);
1.4654 + } else if (returnCode == TCL_CONTINUE) {
1.4655 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.4656 + "invoked \"continue\" outside of a loop", -1);
1.4657 + } else {
1.4658 + char buf[30 + TCL_INTEGER_SPACE];
1.4659 +
1.4660 + sprintf(buf, "command returned bad code: %d", returnCode);
1.4661 + Tcl_SetResult(interp, buf, TCL_VOLATILE);
1.4662 + }
1.4663 +}
1.4664 +
1.4665 +/*
1.4666 + *---------------------------------------------------------------------------
1.4667 + *
1.4668 + * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
1.4669 + *
1.4670 + * Procedures to evaluate an expression and return its value in a
1.4671 + * particular form.
1.4672 + *
1.4673 + * Results:
1.4674 + * Each of the procedures below returns a standard Tcl result. If an
1.4675 + * error occurs then an error message is left in the interp's result.
1.4676 + * Otherwise the value of the expression, in the appropriate form,
1.4677 + * is stored at *ptr. If the expression had a result that was
1.4678 + * incompatible with the desired form then an error is returned.
1.4679 + *
1.4680 + * Side effects:
1.4681 + * None.
1.4682 + *
1.4683 + *---------------------------------------------------------------------------
1.4684 + */
1.4685 +
1.4686 +EXPORT_C int
1.4687 +Tcl_ExprLong(interp, string, ptr)
1.4688 + Tcl_Interp *interp; /* Context in which to evaluate the
1.4689 + * expression. */
1.4690 + CONST char *string; /* Expression to evaluate. */
1.4691 + long *ptr; /* Where to store result. */
1.4692 +{
1.4693 + register Tcl_Obj *exprPtr;
1.4694 + Tcl_Obj *resultPtr;
1.4695 + int length = strlen(string);
1.4696 + int result = TCL_OK;
1.4697 +
1.4698 + if (length > 0) {
1.4699 + exprPtr = Tcl_NewStringObj(string, length);
1.4700 + Tcl_IncrRefCount(exprPtr);
1.4701 + result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
1.4702 + if (result == TCL_OK) {
1.4703 + /*
1.4704 + * Store an integer based on the expression result.
1.4705 + */
1.4706 +
1.4707 + if (resultPtr->typePtr == &tclIntType) {
1.4708 + *ptr = resultPtr->internalRep.longValue;
1.4709 + } else if (resultPtr->typePtr == &tclDoubleType) {
1.4710 + *ptr = (long) resultPtr->internalRep.doubleValue;
1.4711 + } else if (resultPtr->typePtr == &tclWideIntType) {
1.4712 +#ifndef TCL_WIDE_INT_IS_LONG
1.4713 + /*
1.4714 + * See Tcl_GetIntFromObj for conversion comments.
1.4715 + */
1.4716 + Tcl_WideInt w = resultPtr->internalRep.wideValue;
1.4717 + if ((w >= -(Tcl_WideInt)(ULONG_MAX))
1.4718 + && (w <= (Tcl_WideInt)(ULONG_MAX))) {
1.4719 + *ptr = Tcl_WideAsLong(w);
1.4720 + } else {
1.4721 + Tcl_SetResult(interp,
1.4722 + "integer value too large to represent as non-long integer",
1.4723 + TCL_STATIC);
1.4724 + result = TCL_ERROR;
1.4725 + }
1.4726 +#else
1.4727 + *ptr = resultPtr->internalRep.longValue;
1.4728 +#endif
1.4729 + } else {
1.4730 + Tcl_SetResult(interp,
1.4731 + "expression didn't have numeric value", TCL_STATIC);
1.4732 + result = TCL_ERROR;
1.4733 + }
1.4734 + Tcl_DecrRefCount(resultPtr); /* discard the result object */
1.4735 + } else {
1.4736 + /*
1.4737 + * Move the interpreter's object result to the string result,
1.4738 + * then reset the object result.
1.4739 + */
1.4740 +
1.4741 + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
1.4742 + TCL_VOLATILE);
1.4743 + }
1.4744 + Tcl_DecrRefCount(exprPtr); /* discard the expression object */
1.4745 + } else {
1.4746 + /*
1.4747 + * An empty string. Just set the result integer to 0.
1.4748 + */
1.4749 +
1.4750 + *ptr = 0;
1.4751 + }
1.4752 + return result;
1.4753 +}
1.4754 +
1.4755 +EXPORT_C int
1.4756 +Tcl_ExprDouble(interp, string, ptr)
1.4757 + Tcl_Interp *interp; /* Context in which to evaluate the
1.4758 + * expression. */
1.4759 + CONST char *string; /* Expression to evaluate. */
1.4760 + double *ptr; /* Where to store result. */
1.4761 +{
1.4762 + register Tcl_Obj *exprPtr;
1.4763 + Tcl_Obj *resultPtr;
1.4764 + int length = strlen(string);
1.4765 + int result = TCL_OK;
1.4766 +
1.4767 + if (length > 0) {
1.4768 + exprPtr = Tcl_NewStringObj(string, length);
1.4769 + Tcl_IncrRefCount(exprPtr);
1.4770 + result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
1.4771 + if (result == TCL_OK) {
1.4772 + /*
1.4773 + * Store a double based on the expression result.
1.4774 + */
1.4775 +
1.4776 + if (resultPtr->typePtr == &tclIntType) {
1.4777 + *ptr = (double) resultPtr->internalRep.longValue;
1.4778 + } else if (resultPtr->typePtr == &tclDoubleType) {
1.4779 + *ptr = resultPtr->internalRep.doubleValue;
1.4780 + } else if (resultPtr->typePtr == &tclWideIntType) {
1.4781 +#ifndef TCL_WIDE_INT_IS_LONG
1.4782 + /*
1.4783 + * See Tcl_GetIntFromObj for conversion comments.
1.4784 + */
1.4785 + Tcl_WideInt w = resultPtr->internalRep.wideValue;
1.4786 + if ((w >= -(Tcl_WideInt)(ULONG_MAX))
1.4787 + && (w <= (Tcl_WideInt)(ULONG_MAX))) {
1.4788 + *ptr = (double) Tcl_WideAsLong(w);
1.4789 + } else {
1.4790 + Tcl_SetResult(interp,
1.4791 + "integer value too large to represent as non-long integer",
1.4792 + TCL_STATIC);
1.4793 + result = TCL_ERROR;
1.4794 + }
1.4795 +#else
1.4796 + *ptr = (double) resultPtr->internalRep.longValue;
1.4797 +#endif
1.4798 + } else {
1.4799 + Tcl_SetResult(interp,
1.4800 + "expression didn't have numeric value", TCL_STATIC);
1.4801 + result = TCL_ERROR;
1.4802 + }
1.4803 + Tcl_DecrRefCount(resultPtr); /* discard the result object */
1.4804 + } else {
1.4805 + /*
1.4806 + * Move the interpreter's object result to the string result,
1.4807 + * then reset the object result.
1.4808 + */
1.4809 +
1.4810 + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
1.4811 + TCL_VOLATILE);
1.4812 + }
1.4813 + Tcl_DecrRefCount(exprPtr); /* discard the expression object */
1.4814 + } else {
1.4815 + /*
1.4816 + * An empty string. Just set the result double to 0.0.
1.4817 + */
1.4818 +
1.4819 + *ptr = 0.0;
1.4820 + }
1.4821 + return result;
1.4822 +}
1.4823 +
1.4824 +EXPORT_C int
1.4825 +Tcl_ExprBoolean(interp, string, ptr)
1.4826 + Tcl_Interp *interp; /* Context in which to evaluate the
1.4827 + * expression. */
1.4828 + CONST char *string; /* Expression to evaluate. */
1.4829 + int *ptr; /* Where to store 0/1 result. */
1.4830 +{
1.4831 + register Tcl_Obj *exprPtr;
1.4832 + Tcl_Obj *resultPtr;
1.4833 + int length = strlen(string);
1.4834 + int result = TCL_OK;
1.4835 +
1.4836 + if (length > 0) {
1.4837 + exprPtr = Tcl_NewStringObj(string, length);
1.4838 + Tcl_IncrRefCount(exprPtr);
1.4839 + result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
1.4840 + if (result == TCL_OK) {
1.4841 + /*
1.4842 + * Store a boolean based on the expression result.
1.4843 + */
1.4844 +
1.4845 + if (resultPtr->typePtr == &tclIntType) {
1.4846 + *ptr = (resultPtr->internalRep.longValue != 0);
1.4847 + } else if (resultPtr->typePtr == &tclDoubleType) {
1.4848 + *ptr = (resultPtr->internalRep.doubleValue != 0.0);
1.4849 + } else if (resultPtr->typePtr == &tclWideIntType) {
1.4850 +#ifndef TCL_WIDE_INT_IS_LONG
1.4851 + *ptr = (resultPtr->internalRep.wideValue != 0);
1.4852 +#else
1.4853 + *ptr = (resultPtr->internalRep.longValue != 0);
1.4854 +#endif
1.4855 + } else {
1.4856 + result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
1.4857 + }
1.4858 + Tcl_DecrRefCount(resultPtr); /* discard the result object */
1.4859 + }
1.4860 + if (result != TCL_OK) {
1.4861 + /*
1.4862 + * Move the interpreter's object result to the string result,
1.4863 + * then reset the object result.
1.4864 + */
1.4865 +
1.4866 + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
1.4867 + TCL_VOLATILE);
1.4868 + }
1.4869 + Tcl_DecrRefCount(exprPtr); /* discard the expression object */
1.4870 + } else {
1.4871 + /*
1.4872 + * An empty string. Just set the result boolean to 0 (false).
1.4873 + */
1.4874 +
1.4875 + *ptr = 0;
1.4876 + }
1.4877 + return result;
1.4878 +}
1.4879 +
1.4880 +/*
1.4881 + *--------------------------------------------------------------
1.4882 + *
1.4883 + * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj --
1.4884 + *
1.4885 + * Procedures to evaluate an expression in an object and return its
1.4886 + * value in a particular form.
1.4887 + *
1.4888 + * Results:
1.4889 + * Each of the procedures below returns a standard Tcl result
1.4890 + * object. If an error occurs then an error message is left in the
1.4891 + * interpreter's result. Otherwise the value of the expression, in the
1.4892 + * appropriate form, is stored at *ptr. If the expression had a result
1.4893 + * that was incompatible with the desired form then an error is
1.4894 + * returned.
1.4895 + *
1.4896 + * Side effects:
1.4897 + * None.
1.4898 + *
1.4899 + *--------------------------------------------------------------
1.4900 + */
1.4901 +
1.4902 +EXPORT_C int
1.4903 +Tcl_ExprLongObj(interp, objPtr, ptr)
1.4904 + Tcl_Interp *interp; /* Context in which to evaluate the
1.4905 + * expression. */
1.4906 + register Tcl_Obj *objPtr; /* Expression to evaluate. */
1.4907 + long *ptr; /* Where to store long result. */
1.4908 +{
1.4909 + Tcl_Obj *resultPtr;
1.4910 + int result;
1.4911 +
1.4912 + result = Tcl_ExprObj(interp, objPtr, &resultPtr);
1.4913 + if (result == TCL_OK) {
1.4914 + if (resultPtr->typePtr == &tclIntType) {
1.4915 + *ptr = resultPtr->internalRep.longValue;
1.4916 + } else if (resultPtr->typePtr == &tclDoubleType) {
1.4917 + *ptr = (long) resultPtr->internalRep.doubleValue;
1.4918 + } else {
1.4919 + result = Tcl_GetLongFromObj(interp, resultPtr, ptr);
1.4920 + if (result != TCL_OK) {
1.4921 + return result;
1.4922 + }
1.4923 + }
1.4924 + Tcl_DecrRefCount(resultPtr); /* discard the result object */
1.4925 + }
1.4926 + return result;
1.4927 +}
1.4928 +
1.4929 +EXPORT_C int
1.4930 +Tcl_ExprDoubleObj(interp, objPtr, ptr)
1.4931 + Tcl_Interp *interp; /* Context in which to evaluate the
1.4932 + * expression. */
1.4933 + register Tcl_Obj *objPtr; /* Expression to evaluate. */
1.4934 + double *ptr; /* Where to store double result. */
1.4935 +{
1.4936 + Tcl_Obj *resultPtr;
1.4937 + int result;
1.4938 +
1.4939 + result = Tcl_ExprObj(interp, objPtr, &resultPtr);
1.4940 + if (result == TCL_OK) {
1.4941 + if (resultPtr->typePtr == &tclIntType) {
1.4942 + *ptr = (double) resultPtr->internalRep.longValue;
1.4943 + } else if (resultPtr->typePtr == &tclDoubleType) {
1.4944 + *ptr = resultPtr->internalRep.doubleValue;
1.4945 + } else {
1.4946 + result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr);
1.4947 + if (result != TCL_OK) {
1.4948 + return result;
1.4949 + }
1.4950 + }
1.4951 + Tcl_DecrRefCount(resultPtr); /* discard the result object */
1.4952 + }
1.4953 + return result;
1.4954 +}
1.4955 +
1.4956 +EXPORT_C int
1.4957 +Tcl_ExprBooleanObj(interp, objPtr, ptr)
1.4958 + Tcl_Interp *interp; /* Context in which to evaluate the
1.4959 + * expression. */
1.4960 + register Tcl_Obj *objPtr; /* Expression to evaluate. */
1.4961 + int *ptr; /* Where to store 0/1 result. */
1.4962 +{
1.4963 + Tcl_Obj *resultPtr;
1.4964 + int result;
1.4965 +
1.4966 + result = Tcl_ExprObj(interp, objPtr, &resultPtr);
1.4967 + if (result == TCL_OK) {
1.4968 + if (resultPtr->typePtr == &tclIntType) {
1.4969 + *ptr = (resultPtr->internalRep.longValue != 0);
1.4970 + } else if (resultPtr->typePtr == &tclDoubleType) {
1.4971 + *ptr = (resultPtr->internalRep.doubleValue != 0.0);
1.4972 + } else {
1.4973 + result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
1.4974 + }
1.4975 + Tcl_DecrRefCount(resultPtr); /* discard the result object */
1.4976 + }
1.4977 + return result;
1.4978 +}
1.4979 +
1.4980 +/*
1.4981 + *----------------------------------------------------------------------
1.4982 + *
1.4983 + * TclInvoke --
1.4984 + *
1.4985 + * Invokes a Tcl command, given an argv/argc, from either the
1.4986 + * exposed or the hidden sets of commands in the given interpreter.
1.4987 + * NOTE: The command is invoked in the current stack frame of
1.4988 + * the interpreter, thus it can modify local variables.
1.4989 + *
1.4990 + * Results:
1.4991 + * A standard Tcl result.
1.4992 + *
1.4993 + * Side effects:
1.4994 + * Whatever the command does.
1.4995 + *
1.4996 + *----------------------------------------------------------------------
1.4997 + */
1.4998 +
1.4999 +int
1.5000 +TclInvoke(interp, argc, argv, flags)
1.5001 + Tcl_Interp *interp; /* Where to invoke the command. */
1.5002 + int argc; /* Count of args. */
1.5003 + register CONST char **argv; /* The arg strings; argv[0] is the name of
1.5004 + * the command to invoke. */
1.5005 + int flags; /* Combination of flags controlling the
1.5006 + * call: TCL_INVOKE_HIDDEN and
1.5007 + * TCL_INVOKE_NO_UNKNOWN. */
1.5008 +{
1.5009 + register Tcl_Obj *objPtr;
1.5010 + register int i;
1.5011 + int length, result;
1.5012 +
1.5013 + /*
1.5014 + * This procedure generates an objv array for object arguments that hold
1.5015 + * the argv strings. It starts out with stack-allocated space but uses
1.5016 + * dynamically-allocated storage if needed.
1.5017 + */
1.5018 +
1.5019 +#define NUM_ARGS 20
1.5020 + Tcl_Obj *(objStorage[NUM_ARGS]);
1.5021 + register Tcl_Obj **objv = objStorage;
1.5022 +
1.5023 + /*
1.5024 + * Create the object argument array "objv". Make sure objv is large
1.5025 + * enough to hold the objc arguments plus 1 extra for the zero
1.5026 + * end-of-objv word.
1.5027 + */
1.5028 +
1.5029 + if ((argc + 1) > NUM_ARGS) {
1.5030 + objv = (Tcl_Obj **)
1.5031 + ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
1.5032 + }
1.5033 +
1.5034 + for (i = 0; i < argc; i++) {
1.5035 + length = strlen(argv[i]);
1.5036 + objv[i] = Tcl_NewStringObj(argv[i], length);
1.5037 + Tcl_IncrRefCount(objv[i]);
1.5038 + }
1.5039 + objv[argc] = 0;
1.5040 +
1.5041 + /*
1.5042 + * Use TclObjInterpProc to actually invoke the command.
1.5043 + */
1.5044 +
1.5045 + result = TclObjInvoke(interp, argc, objv, flags);
1.5046 +
1.5047 + /*
1.5048 + * Move the interpreter's object result to the string result,
1.5049 + * then reset the object result.
1.5050 + */
1.5051 +
1.5052 + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
1.5053 + TCL_VOLATILE);
1.5054 +
1.5055 + /*
1.5056 + * Decrement the ref counts on the objv elements since we are done
1.5057 + * with them.
1.5058 + */
1.5059 +
1.5060 + for (i = 0; i < argc; i++) {
1.5061 + objPtr = objv[i];
1.5062 + Tcl_DecrRefCount(objPtr);
1.5063 + }
1.5064 +
1.5065 + /*
1.5066 + * Free the objv array if malloc'ed storage was used.
1.5067 + */
1.5068 +
1.5069 + if (objv != objStorage) {
1.5070 + ckfree((char *) objv);
1.5071 + }
1.5072 + return result;
1.5073 +#undef NUM_ARGS
1.5074 +}
1.5075 +
1.5076 +/*
1.5077 + *----------------------------------------------------------------------
1.5078 + *
1.5079 + * TclGlobalInvoke --
1.5080 + *
1.5081 + * Invokes a Tcl command, given an argv/argc, from either the
1.5082 + * exposed or hidden sets of commands in the given interpreter.
1.5083 + * NOTE: The command is invoked in the global stack frame of
1.5084 + * the interpreter, thus it cannot see any current state on
1.5085 + * the stack for that interpreter.
1.5086 + *
1.5087 + * Results:
1.5088 + * A standard Tcl result.
1.5089 + *
1.5090 + * Side effects:
1.5091 + * Whatever the command does.
1.5092 + *
1.5093 + *----------------------------------------------------------------------
1.5094 + */
1.5095 +
1.5096 +int
1.5097 +TclGlobalInvoke(interp, argc, argv, flags)
1.5098 + Tcl_Interp *interp; /* Where to invoke the command. */
1.5099 + int argc; /* Count of args. */
1.5100 + register CONST char **argv; /* The arg strings; argv[0] is the name of
1.5101 + * the command to invoke. */
1.5102 + int flags; /* Combination of flags controlling the
1.5103 + * call: TCL_INVOKE_HIDDEN and
1.5104 + * TCL_INVOKE_NO_UNKNOWN. */
1.5105 +{
1.5106 + register Interp *iPtr = (Interp *) interp;
1.5107 + int result;
1.5108 + CallFrame *savedVarFramePtr;
1.5109 +
1.5110 + savedVarFramePtr = iPtr->varFramePtr;
1.5111 + iPtr->varFramePtr = NULL;
1.5112 + result = TclInvoke(interp, argc, argv, flags);
1.5113 + iPtr->varFramePtr = savedVarFramePtr;
1.5114 + return result;
1.5115 +}
1.5116 +
1.5117 +/*
1.5118 + *----------------------------------------------------------------------
1.5119 + *
1.5120 + * TclObjInvokeGlobal --
1.5121 + *
1.5122 + * Object version: Invokes a Tcl command, given an objv/objc, from
1.5123 + * either the exposed or hidden set of commands in the given
1.5124 + * interpreter.
1.5125 + * NOTE: The command is invoked in the global stack frame of the
1.5126 + * interpreter, thus it cannot see any current state on the
1.5127 + * stack of that interpreter.
1.5128 + *
1.5129 + * Results:
1.5130 + * A standard Tcl result.
1.5131 + *
1.5132 + * Side effects:
1.5133 + * Whatever the command does.
1.5134 + *
1.5135 + *----------------------------------------------------------------------
1.5136 + */
1.5137 +
1.5138 +int
1.5139 +TclObjInvokeGlobal(interp, objc, objv, flags)
1.5140 + Tcl_Interp *interp; /* Interpreter in which command is to be
1.5141 + * invoked. */
1.5142 + int objc; /* Count of arguments. */
1.5143 + Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the
1.5144 + * name of the command to invoke. */
1.5145 + int flags; /* Combination of flags controlling the
1.5146 + * call: TCL_INVOKE_HIDDEN,
1.5147 + * TCL_INVOKE_NO_UNKNOWN, or
1.5148 + * TCL_INVOKE_NO_TRACEBACK. */
1.5149 +{
1.5150 + register Interp *iPtr = (Interp *) interp;
1.5151 + int result;
1.5152 + CallFrame *savedVarFramePtr;
1.5153 +
1.5154 + savedVarFramePtr = iPtr->varFramePtr;
1.5155 + iPtr->varFramePtr = NULL;
1.5156 + result = TclObjInvoke(interp, objc, objv, flags);
1.5157 + iPtr->varFramePtr = savedVarFramePtr;
1.5158 + return result;
1.5159 +}
1.5160 +
1.5161 +/*
1.5162 + *----------------------------------------------------------------------
1.5163 + *
1.5164 + * TclObjInvoke --
1.5165 + *
1.5166 + * Invokes a Tcl command, given an objv/objc, from either the
1.5167 + * exposed or the hidden sets of commands in the given interpreter.
1.5168 + *
1.5169 + * Results:
1.5170 + * A standard Tcl object result.
1.5171 + *
1.5172 + * Side effects:
1.5173 + * Whatever the command does.
1.5174 + *
1.5175 + *----------------------------------------------------------------------
1.5176 + */
1.5177 +
1.5178 +int
1.5179 +TclObjInvoke(interp, objc, objv, flags)
1.5180 + Tcl_Interp *interp; /* Interpreter in which command is to be
1.5181 + * invoked. */
1.5182 + int objc; /* Count of arguments. */
1.5183 + Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the
1.5184 + * name of the command to invoke. */
1.5185 + int flags; /* Combination of flags controlling the
1.5186 + * call: TCL_INVOKE_HIDDEN,
1.5187 + * TCL_INVOKE_NO_UNKNOWN, or
1.5188 + * TCL_INVOKE_NO_TRACEBACK. */
1.5189 +{
1.5190 + register Interp *iPtr = (Interp *) interp;
1.5191 + Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
1.5192 + char *cmdName; /* Name of the command from objv[0]. */
1.5193 + register Tcl_HashEntry *hPtr;
1.5194 + Tcl_Command cmd;
1.5195 + Command *cmdPtr;
1.5196 + int localObjc; /* Used to invoke "unknown" if the */
1.5197 + Tcl_Obj **localObjv = NULL; /* command is not found. */
1.5198 + register int i;
1.5199 + int result;
1.5200 +
1.5201 + if (interp == (Tcl_Interp *) NULL) {
1.5202 + return TCL_ERROR;
1.5203 + }
1.5204 +
1.5205 + if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) {
1.5206 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.5207 + "illegal argument vector", -1);
1.5208 + return TCL_ERROR;
1.5209 + }
1.5210 +
1.5211 + cmdName = Tcl_GetString(objv[0]);
1.5212 + if (flags & TCL_INVOKE_HIDDEN) {
1.5213 + /*
1.5214 + * We never invoke "unknown" for hidden commands.
1.5215 + */
1.5216 +
1.5217 + hPtr = NULL;
1.5218 + hTblPtr = ((Interp *) interp)->hiddenCmdTablePtr;
1.5219 + if (hTblPtr != NULL) {
1.5220 + hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
1.5221 + }
1.5222 + if (hPtr == NULL) {
1.5223 + Tcl_ResetResult(interp);
1.5224 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.5225 + "invalid hidden command name \"", cmdName, "\"",
1.5226 + (char *) NULL);
1.5227 + return TCL_ERROR;
1.5228 + }
1.5229 + cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
1.5230 + } else {
1.5231 + cmdPtr = NULL;
1.5232 + cmd = Tcl_FindCommand(interp, cmdName,
1.5233 + (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
1.5234 + if (cmd != (Tcl_Command) NULL) {
1.5235 + cmdPtr = (Command *) cmd;
1.5236 + }
1.5237 + if (cmdPtr == NULL) {
1.5238 + if (!(flags & TCL_INVOKE_NO_UNKNOWN)) {
1.5239 + cmd = Tcl_FindCommand(interp, "unknown",
1.5240 + (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
1.5241 + if (cmd != (Tcl_Command) NULL) {
1.5242 + cmdPtr = (Command *) cmd;
1.5243 + }
1.5244 + if (cmdPtr != NULL) {
1.5245 + localObjc = (objc + 1);
1.5246 + localObjv = (Tcl_Obj **)
1.5247 + ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc));
1.5248 + localObjv[0] = Tcl_NewStringObj("unknown", -1);
1.5249 + Tcl_IncrRefCount(localObjv[0]);
1.5250 + for (i = 0; i < objc; i++) {
1.5251 + localObjv[i+1] = objv[i];
1.5252 + }
1.5253 + objc = localObjc;
1.5254 + objv = localObjv;
1.5255 + }
1.5256 + }
1.5257 +
1.5258 + /*
1.5259 + * Check again if we found the command. If not, "unknown" is
1.5260 + * not present and we cannot help, or the caller said not to
1.5261 + * call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN).
1.5262 + */
1.5263 +
1.5264 + if (cmdPtr == NULL) {
1.5265 + Tcl_ResetResult(interp);
1.5266 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.5267 + "invalid command name \"", cmdName, "\"",
1.5268 + (char *) NULL);
1.5269 + return TCL_ERROR;
1.5270 + }
1.5271 + }
1.5272 + }
1.5273 +
1.5274 + /*
1.5275 + * Invoke the command procedure. First reset the interpreter's string
1.5276 + * and object results to their default empty values since they could
1.5277 + * have gotten changed by earlier invocations.
1.5278 + */
1.5279 +
1.5280 + Tcl_ResetResult(interp);
1.5281 + iPtr->cmdCount++;
1.5282 + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
1.5283 +
1.5284 + /*
1.5285 + * If an error occurred, record information about what was being
1.5286 + * executed when the error occurred.
1.5287 + */
1.5288 +
1.5289 + if ((result == TCL_ERROR)
1.5290 + && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0)
1.5291 + && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) {
1.5292 + Tcl_Obj *msg;
1.5293 +
1.5294 + if (!(iPtr->flags & ERR_IN_PROGRESS)) {
1.5295 + msg = Tcl_NewStringObj("\n while invoking\n\"", -1);
1.5296 + } else {
1.5297 + msg = Tcl_NewStringObj("\n invoked from within\n\"", -1);
1.5298 + }
1.5299 + Tcl_IncrRefCount(msg);
1.5300 + for (i = 0; i < objc; i++) {
1.5301 + CONST char *bytes;
1.5302 + int length;
1.5303 +
1.5304 + Tcl_AppendObjToObj(msg, objv[i]);
1.5305 + bytes = Tcl_GetStringFromObj(msg, &length);
1.5306 + if (length > 100) {
1.5307 + /*
1.5308 + * Back up truncation point so that we don't truncate
1.5309 + * in the middle of a multi-byte character.
1.5310 + */
1.5311 + length = 100;
1.5312 + while ( (bytes[length] & 0xC0) == 0x80 ) {
1.5313 + length--;
1.5314 + }
1.5315 + Tcl_SetObjLength(msg, length);
1.5316 + Tcl_AppendToObj(msg, "...", -1);
1.5317 + break;
1.5318 + }
1.5319 + if (i != (objc - 1)) {
1.5320 + Tcl_AppendToObj(msg, " ", -1);
1.5321 + }
1.5322 + }
1.5323 +
1.5324 + Tcl_AppendToObj(msg, "\"", -1);
1.5325 + Tcl_AddObjErrorInfo(interp, Tcl_GetString(msg), -1);
1.5326 + Tcl_DecrRefCount(msg);
1.5327 + iPtr->flags &= ~ERR_ALREADY_LOGGED;
1.5328 + }
1.5329 +
1.5330 + /*
1.5331 + * Free any locally allocated storage used to call "unknown".
1.5332 + */
1.5333 +
1.5334 + if (localObjv != (Tcl_Obj **) NULL) {
1.5335 + Tcl_DecrRefCount(localObjv[0]);
1.5336 + ckfree((char *) localObjv);
1.5337 + }
1.5338 + return result;
1.5339 +}
1.5340 +
1.5341 +/*
1.5342 + *---------------------------------------------------------------------------
1.5343 + *
1.5344 + * Tcl_ExprString --
1.5345 + *
1.5346 + * Evaluate an expression in a string and return its value in string
1.5347 + * form.
1.5348 + *
1.5349 + * Results:
1.5350 + * A standard Tcl result. If the result is TCL_OK, then the interp's
1.5351 + * result is set to the string value of the expression. If the result
1.5352 + * is TCL_ERROR, then the interp's result contains an error message.
1.5353 + *
1.5354 + * Side effects:
1.5355 + * A Tcl object is allocated to hold a copy of the expression string.
1.5356 + * This expression object is passed to Tcl_ExprObj and then
1.5357 + * deallocated.
1.5358 + *
1.5359 + *---------------------------------------------------------------------------
1.5360 + */
1.5361 +
1.5362 +EXPORT_C int
1.5363 +Tcl_ExprString(interp, string)
1.5364 + Tcl_Interp *interp; /* Context in which to evaluate the
1.5365 + * expression. */
1.5366 + CONST char *string; /* Expression to evaluate. */
1.5367 +{
1.5368 + register Tcl_Obj *exprPtr;
1.5369 + Tcl_Obj *resultPtr;
1.5370 + int length = strlen(string);
1.5371 + char buf[TCL_DOUBLE_SPACE];
1.5372 + int result = TCL_OK;
1.5373 +
1.5374 + if (length > 0) {
1.5375 + TclNewObj(exprPtr);
1.5376 + TclInitStringRep(exprPtr, string, length);
1.5377 + Tcl_IncrRefCount(exprPtr);
1.5378 +
1.5379 + result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
1.5380 + if (result == TCL_OK) {
1.5381 + /*
1.5382 + * Set the interpreter's string result from the result object.
1.5383 + */
1.5384 +
1.5385 + if (resultPtr->typePtr == &tclIntType) {
1.5386 + sprintf(buf, "%ld", resultPtr->internalRep.longValue);
1.5387 + Tcl_SetResult(interp, buf, TCL_VOLATILE);
1.5388 + } else if (resultPtr->typePtr == &tclDoubleType) {
1.5389 + Tcl_PrintDouble((Tcl_Interp *) NULL,
1.5390 + resultPtr->internalRep.doubleValue, buf);
1.5391 + Tcl_SetResult(interp, buf, TCL_VOLATILE);
1.5392 + } else {
1.5393 + /*
1.5394 + * Set interpreter's string result from the result object.
1.5395 + */
1.5396 +
1.5397 + Tcl_SetResult(interp, TclGetString(resultPtr),
1.5398 + TCL_VOLATILE);
1.5399 + }
1.5400 + Tcl_DecrRefCount(resultPtr); /* discard the result object */
1.5401 + } else {
1.5402 + /*
1.5403 + * Move the interpreter's object result to the string result,
1.5404 + * then reset the object result.
1.5405 + */
1.5406 +
1.5407 + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
1.5408 + TCL_VOLATILE);
1.5409 + }
1.5410 + Tcl_DecrRefCount(exprPtr); /* discard the expression object */
1.5411 + } else {
1.5412 + /*
1.5413 + * An empty string. Just set the interpreter's result to 0.
1.5414 + */
1.5415 +
1.5416 + Tcl_SetResult(interp, "0", TCL_VOLATILE);
1.5417 + }
1.5418 + return result;
1.5419 +}
1.5420 +
1.5421 +/*
1.5422 + *----------------------------------------------------------------------
1.5423 + *
1.5424 + * Tcl_CreateObjTrace --
1.5425 + *
1.5426 + * Arrange for a procedure to be called to trace command execution.
1.5427 + *
1.5428 + * Results:
1.5429 + * The return value is a token for the trace, which may be passed
1.5430 + * to Tcl_DeleteTrace to eliminate the trace.
1.5431 + *
1.5432 + * Side effects:
1.5433 + * From now on, proc will be called just before a command procedure
1.5434 + * is called to execute a Tcl command. Calls to proc will have the
1.5435 + * following form:
1.5436 + *
1.5437 + * void proc( ClientData clientData,
1.5438 + * Tcl_Interp* interp,
1.5439 + * int level,
1.5440 + * CONST char* command,
1.5441 + * Tcl_Command commandInfo,
1.5442 + * int objc,
1.5443 + * Tcl_Obj *CONST objv[] );
1.5444 + *
1.5445 + * The 'clientData' and 'interp' arguments to 'proc' will be the
1.5446 + * same as the arguments to Tcl_CreateObjTrace. The 'level'
1.5447 + * argument gives the nesting depth of command interpretation within
1.5448 + * the interpreter. The 'command' argument is the ASCII text of
1.5449 + * the command being evaluated -- before any substitutions are
1.5450 + * performed. The 'commandInfo' argument gives a handle to the
1.5451 + * command procedure that will be evaluated. The 'objc' and 'objv'
1.5452 + * parameters give the parameter vector that will be passed to the
1.5453 + * command procedure. proc does not return a value.
1.5454 + *
1.5455 + * It is permissible for 'proc' to call Tcl_SetCommandTokenInfo
1.5456 + * to change the command procedure or client data for the command
1.5457 + * being evaluated, and these changes will take effect with the
1.5458 + * current evaluation.
1.5459 + *
1.5460 + * The 'level' argument specifies the maximum nesting level of calls
1.5461 + * to be traced. If the execution depth of the interpreter exceeds
1.5462 + * 'level', the trace callback is not executed.
1.5463 + *
1.5464 + * The 'flags' argument is either zero or the value,
1.5465 + * TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION
1.5466 + * flag is not present, the bytecode compiler will not generate inline
1.5467 + * code for Tcl's built-in commands. This behavior will have a significant
1.5468 + * impact on performance, but will ensure that all command evaluations are
1.5469 + * traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the
1.5470 + * bytecode compiler will have its normal behavior of compiling in-line
1.5471 + * code for some of Tcl's built-in commands. In this case, the tracing
1.5472 + * will be imprecise -- in-line code will not be traced -- but run-time
1.5473 + * performance will be improved. The latter behavior is desired for
1.5474 + * many applications such as profiling of run time.
1.5475 + *
1.5476 + * When the trace is deleted, the 'delProc' procedure will be invoked,
1.5477 + * passing it the original client data.
1.5478 + *
1.5479 + *----------------------------------------------------------------------
1.5480 + */
1.5481 +
1.5482 +EXPORT_C Tcl_Trace
1.5483 +Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc )
1.5484 + Tcl_Interp* interp; /* Tcl interpreter */
1.5485 + int level; /* Maximum nesting level */
1.5486 + int flags; /* Flags, see above */
1.5487 + Tcl_CmdObjTraceProc* proc; /* Trace callback */
1.5488 + ClientData clientData; /* Client data for the callback */
1.5489 + Tcl_CmdObjTraceDeleteProc* delProc;
1.5490 + /* Procedure to call when trace is deleted */
1.5491 +{
1.5492 + register Trace *tracePtr;
1.5493 + register Interp *iPtr = (Interp *) interp;
1.5494 +
1.5495 + /* Test if this trace allows inline compilation of commands */
1.5496 +
1.5497 + if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) {
1.5498 + if (iPtr->tracesForbiddingInline == 0) {
1.5499 +
1.5500 + /*
1.5501 + * When the first trace forbidding inline compilation is
1.5502 + * created, invalidate existing compiled code for this
1.5503 + * interpreter and arrange (by setting the
1.5504 + * DONT_COMPILE_CMDS_INLINE flag) that when compiling new
1.5505 + * code, no commands will be compiled inline (i.e., into
1.5506 + * an inline sequence of instructions). We do this because
1.5507 + * commands that were compiled inline will never result in
1.5508 + * a command trace being called.
1.5509 + */
1.5510 +
1.5511 + iPtr->compileEpoch++;
1.5512 + iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
1.5513 + }
1.5514 + iPtr->tracesForbiddingInline++;
1.5515 + }
1.5516 +
1.5517 + tracePtr = (Trace *) ckalloc(sizeof(Trace));
1.5518 + tracePtr->level = level;
1.5519 + tracePtr->proc = proc;
1.5520 + tracePtr->clientData = clientData;
1.5521 + tracePtr->delProc = delProc;
1.5522 + tracePtr->nextPtr = iPtr->tracePtr;
1.5523 + tracePtr->flags = flags;
1.5524 + iPtr->tracePtr = tracePtr;
1.5525 +
1.5526 + return (Tcl_Trace) tracePtr;
1.5527 +}
1.5528 +
1.5529 +/*
1.5530 + *----------------------------------------------------------------------
1.5531 + *
1.5532 + * Tcl_CreateTrace --
1.5533 + *
1.5534 + * Arrange for a procedure to be called to trace command execution.
1.5535 + *
1.5536 + * Results:
1.5537 + * The return value is a token for the trace, which may be passed
1.5538 + * to Tcl_DeleteTrace to eliminate the trace.
1.5539 + *
1.5540 + * Side effects:
1.5541 + * From now on, proc will be called just before a command procedure
1.5542 + * is called to execute a Tcl command. Calls to proc will have the
1.5543 + * following form:
1.5544 + *
1.5545 + * void
1.5546 + * proc(clientData, interp, level, command, cmdProc, cmdClientData,
1.5547 + * argc, argv)
1.5548 + * ClientData clientData;
1.5549 + * Tcl_Interp *interp;
1.5550 + * int level;
1.5551 + * char *command;
1.5552 + * int (*cmdProc)();
1.5553 + * ClientData cmdClientData;
1.5554 + * int argc;
1.5555 + * char **argv;
1.5556 + * {
1.5557 + * }
1.5558 + *
1.5559 + * The clientData and interp arguments to proc will be the same
1.5560 + * as the corresponding arguments to this procedure. Level gives
1.5561 + * the nesting level of command interpretation for this interpreter
1.5562 + * (0 corresponds to top level). Command gives the ASCII text of
1.5563 + * the raw command, cmdProc and cmdClientData give the procedure that
1.5564 + * will be called to process the command and the ClientData value it
1.5565 + * will receive, and argc and argv give the arguments to the
1.5566 + * command, after any argument parsing and substitution. Proc
1.5567 + * does not return a value.
1.5568 + *
1.5569 + *----------------------------------------------------------------------
1.5570 + */
1.5571 +
1.5572 +EXPORT_C Tcl_Trace
1.5573 +Tcl_CreateTrace(interp, level, proc, clientData)
1.5574 + Tcl_Interp *interp; /* Interpreter in which to create trace. */
1.5575 + int level; /* Only call proc for commands at nesting
1.5576 + * level<=argument level (1=>top level). */
1.5577 + Tcl_CmdTraceProc *proc; /* Procedure to call before executing each
1.5578 + * command. */
1.5579 + ClientData clientData; /* Arbitrary value word to pass to proc. */
1.5580 +{
1.5581 + StringTraceData* data;
1.5582 + data = (StringTraceData*) ckalloc( sizeof( *data ));
1.5583 + data->clientData = clientData;
1.5584 + data->proc = proc;
1.5585 + return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc,
1.5586 + (ClientData) data, StringTraceDeleteProc );
1.5587 +}
1.5588 +
1.5589 +/*
1.5590 + *----------------------------------------------------------------------
1.5591 + *
1.5592 + * StringTraceProc --
1.5593 + *
1.5594 + * Invoke a string-based trace procedure from an object-based
1.5595 + * callback.
1.5596 + *
1.5597 + * Results:
1.5598 + * None.
1.5599 + *
1.5600 + * Side effects:
1.5601 + * Whatever the string-based trace procedure does.
1.5602 + *
1.5603 + *----------------------------------------------------------------------
1.5604 + */
1.5605 +
1.5606 +static int
1.5607 +StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv )
1.5608 + ClientData clientData;
1.5609 + Tcl_Interp* interp;
1.5610 + int level;
1.5611 + CONST char* command;
1.5612 + Tcl_Command commandInfo;
1.5613 + int objc;
1.5614 + Tcl_Obj *CONST *objv;
1.5615 +{
1.5616 + StringTraceData* data = (StringTraceData*) clientData;
1.5617 + Command* cmdPtr = (Command*) commandInfo;
1.5618 +
1.5619 + CONST char** argv; /* Args to pass to string trace proc */
1.5620 +
1.5621 + int i;
1.5622 +
1.5623 + /*
1.5624 + * This is a bit messy because we have to emulate the old trace
1.5625 + * interface, which uses strings for everything.
1.5626 + */
1.5627 +
1.5628 + argv = (CONST char **) ckalloc((unsigned) ( (objc + 1)
1.5629 + * sizeof(CONST char *) ));
1.5630 + for (i = 0; i < objc; i++) {
1.5631 + argv[i] = Tcl_GetString(objv[i]);
1.5632 + }
1.5633 + argv[objc] = 0;
1.5634 +
1.5635 + /*
1.5636 + * Invoke the command procedure. Note that we cast away const-ness
1.5637 + * on two parameters for compatibility with legacy code; the code
1.5638 + * MUST NOT modify either command or argv.
1.5639 + */
1.5640 +
1.5641 + ( data->proc )( data->clientData, interp, level,
1.5642 + (char*) command, cmdPtr->proc, cmdPtr->clientData,
1.5643 + objc, argv );
1.5644 + ckfree( (char*) argv );
1.5645 +
1.5646 + return TCL_OK;
1.5647 +}
1.5648 +
1.5649 +/*
1.5650 + *----------------------------------------------------------------------
1.5651 + *
1.5652 + * StringTraceDeleteProc --
1.5653 + *
1.5654 + * Clean up memory when a string-based trace is deleted.
1.5655 + *
1.5656 + * Results:
1.5657 + * None.
1.5658 + *
1.5659 + * Side effects:
1.5660 + * Allocated memory is returned to the system.
1.5661 + *
1.5662 + *----------------------------------------------------------------------
1.5663 + */
1.5664 +
1.5665 +static void
1.5666 +StringTraceDeleteProc( clientData )
1.5667 + ClientData clientData;
1.5668 +{
1.5669 + ckfree( (char*) clientData );
1.5670 +}
1.5671 +
1.5672 +/*
1.5673 + *----------------------------------------------------------------------
1.5674 + *
1.5675 + * Tcl_DeleteTrace --
1.5676 + *
1.5677 + * Remove a trace.
1.5678 + *
1.5679 + * Results:
1.5680 + * None.
1.5681 + *
1.5682 + * Side effects:
1.5683 + * From now on there will be no more calls to the procedure given
1.5684 + * in trace.
1.5685 + *
1.5686 + *----------------------------------------------------------------------
1.5687 + */
1.5688 +
1.5689 +EXPORT_C void
1.5690 +Tcl_DeleteTrace(interp, trace)
1.5691 + Tcl_Interp *interp; /* Interpreter that contains trace. */
1.5692 + Tcl_Trace trace; /* Token for trace (returned previously by
1.5693 + * Tcl_CreateTrace). */
1.5694 +{
1.5695 + Interp *iPtr = (Interp *) interp;
1.5696 + Trace *prevPtr, *tracePtr = (Trace *) trace;
1.5697 + register Trace **tracePtr2 = &(iPtr->tracePtr);
1.5698 + ActiveInterpTrace *activePtr;
1.5699 +
1.5700 + /*
1.5701 + * Locate the trace entry in the interpreter's trace list,
1.5702 + * and remove it from the list.
1.5703 + */
1.5704 +
1.5705 + prevPtr = NULL;
1.5706 + while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) {
1.5707 + prevPtr = *tracePtr2;
1.5708 + tracePtr2 = &((*tracePtr2)->nextPtr);
1.5709 + }
1.5710 + if (*tracePtr2 == NULL) {
1.5711 + return;
1.5712 + }
1.5713 + (*tracePtr2) = (*tracePtr2)->nextPtr;
1.5714 +
1.5715 + /*
1.5716 + * The code below makes it possible to delete traces while traces
1.5717 + * are active: it makes sure that the deleted trace won't be
1.5718 + * processed by TclCheckInterpTraces.
1.5719 + */
1.5720 +
1.5721 + for (activePtr = iPtr->activeInterpTracePtr; activePtr != NULL;
1.5722 + activePtr = activePtr->nextPtr) {
1.5723 + if (activePtr->nextTracePtr == tracePtr) {
1.5724 + if (activePtr->reverseScan) {
1.5725 + activePtr->nextTracePtr = prevPtr;
1.5726 + } else {
1.5727 + activePtr->nextTracePtr = tracePtr->nextPtr;
1.5728 + }
1.5729 + }
1.5730 + }
1.5731 +
1.5732 + /*
1.5733 + * If the trace forbids bytecode compilation, change the interpreter's
1.5734 + * state. If bytecode compilation is now permitted, flag the fact and
1.5735 + * advance the compilation epoch so that procs will be recompiled to
1.5736 + * take advantage of it.
1.5737 + */
1.5738 +
1.5739 + if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) {
1.5740 + iPtr->tracesForbiddingInline--;
1.5741 + if (iPtr->tracesForbiddingInline == 0) {
1.5742 + iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE;
1.5743 + iPtr->compileEpoch++;
1.5744 + }
1.5745 + }
1.5746 +
1.5747 + /*
1.5748 + * Execute any delete callback.
1.5749 + */
1.5750 +
1.5751 + if (tracePtr->delProc != NULL) {
1.5752 + (tracePtr->delProc)(tracePtr->clientData);
1.5753 + }
1.5754 +
1.5755 + /* Delete the trace object */
1.5756 +
1.5757 + Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC);
1.5758 +}
1.5759 +
1.5760 +/*
1.5761 + *----------------------------------------------------------------------
1.5762 + *
1.5763 + * Tcl_AddErrorInfo --
1.5764 + *
1.5765 + * Add information to the "errorInfo" variable that describes the
1.5766 + * current error.
1.5767 + *
1.5768 + * Results:
1.5769 + * None.
1.5770 + *
1.5771 + * Side effects:
1.5772 + * The contents of message are added to the "errorInfo" variable.
1.5773 + * If Tcl_Eval has been called since the current value of errorInfo
1.5774 + * was set, errorInfo is cleared before adding the new message.
1.5775 + * If we are just starting to log an error, errorInfo is initialized
1.5776 + * from the error message in the interpreter's result.
1.5777 + *
1.5778 + *----------------------------------------------------------------------
1.5779 + */
1.5780 +
1.5781 +EXPORT_C void
1.5782 +Tcl_AddErrorInfo(interp, message)
1.5783 + Tcl_Interp *interp; /* Interpreter to which error information
1.5784 + * pertains. */
1.5785 + CONST char *message; /* Message to record. */
1.5786 +{
1.5787 + Tcl_AddObjErrorInfo(interp, message, -1);
1.5788 +}
1.5789 +
1.5790 +/*
1.5791 + *----------------------------------------------------------------------
1.5792 + *
1.5793 + * Tcl_AddObjErrorInfo --
1.5794 + *
1.5795 + * Add information to the "errorInfo" variable that describes the
1.5796 + * current error. This routine differs from Tcl_AddErrorInfo by
1.5797 + * taking a byte pointer and length.
1.5798 + *
1.5799 + * Results:
1.5800 + * None.
1.5801 + *
1.5802 + * Side effects:
1.5803 + * "length" bytes from "message" are added to the "errorInfo" variable.
1.5804 + * If "length" is negative, use bytes up to the first NULL byte.
1.5805 + * If Tcl_EvalObj has been called since the current value of errorInfo
1.5806 + * was set, errorInfo is cleared before adding the new message.
1.5807 + * If we are just starting to log an error, errorInfo is initialized
1.5808 + * from the error message in the interpreter's result.
1.5809 + *
1.5810 + *----------------------------------------------------------------------
1.5811 + */
1.5812 +
1.5813 +EXPORT_C void
1.5814 +Tcl_AddObjErrorInfo(interp, message, length)
1.5815 + Tcl_Interp *interp; /* Interpreter to which error information
1.5816 + * pertains. */
1.5817 + CONST char *message; /* Points to the first byte of an array of
1.5818 + * bytes of the message. */
1.5819 + int length; /* The number of bytes in the message.
1.5820 + * If < 0, then append all bytes up to a
1.5821 + * NULL byte. */
1.5822 +{
1.5823 + register Interp *iPtr = (Interp *) interp;
1.5824 + Tcl_Obj *objPtr;
1.5825 +
1.5826 + /*
1.5827 + * If we are just starting to log an error, errorInfo is initialized
1.5828 + * from the error message in the interpreter's result.
1.5829 + */
1.5830 +
1.5831 + if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */
1.5832 + iPtr->flags |= ERR_IN_PROGRESS;
1.5833 +
1.5834 + if (iPtr->result[0] == 0) {
1.5835 + Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
1.5836 + iPtr->objResultPtr, TCL_GLOBAL_ONLY);
1.5837 + } else { /* use the string result */
1.5838 + objPtr = Tcl_NewStringObj(interp->result, -1);
1.5839 + Tcl_IncrRefCount(objPtr);
1.5840 + Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
1.5841 + objPtr, TCL_GLOBAL_ONLY);
1.5842 + Tcl_DecrRefCount(objPtr);
1.5843 + }
1.5844 +
1.5845 + /*
1.5846 + * If the errorCode variable wasn't set by the code that generated
1.5847 + * the error, set it to "NONE".
1.5848 + */
1.5849 +
1.5850 + if (!(iPtr->flags & ERROR_CODE_SET)) {
1.5851 + objPtr = Tcl_NewStringObj("NONE", -1);
1.5852 + Tcl_IncrRefCount(objPtr);
1.5853 + Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL,
1.5854 + objPtr, TCL_GLOBAL_ONLY);
1.5855 + Tcl_DecrRefCount(objPtr);
1.5856 + }
1.5857 + }
1.5858 +
1.5859 + /*
1.5860 + * Now append "message" to the end of errorInfo.
1.5861 + */
1.5862 +
1.5863 + if (length != 0) {
1.5864 + objPtr = Tcl_NewStringObj(message, length);
1.5865 + Tcl_IncrRefCount(objPtr);
1.5866 + Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
1.5867 + objPtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
1.5868 + Tcl_DecrRefCount(objPtr); /* free msg object appended above */
1.5869 + }
1.5870 +}
1.5871 +
1.5872 +/*
1.5873 + *---------------------------------------------------------------------------
1.5874 + *
1.5875 + * Tcl_VarEvalVA --
1.5876 + *
1.5877 + * Given a variable number of string arguments, concatenate them
1.5878 + * all together and execute the result as a Tcl command.
1.5879 + *
1.5880 + * Results:
1.5881 + * A standard Tcl return result. An error message or other result may
1.5882 + * be left in the interp's result.
1.5883 + *
1.5884 + * Side effects:
1.5885 + * Depends on what was done by the command.
1.5886 + *
1.5887 + *---------------------------------------------------------------------------
1.5888 + */
1.5889 +
1.5890 +EXPORT_C int
1.5891 +Tcl_VarEvalVA (interp, argList)
1.5892 + Tcl_Interp *interp; /* Interpreter in which to evaluate command. */
1.5893 + va_list argList; /* Variable argument list. */
1.5894 +{
1.5895 + Tcl_DString buf;
1.5896 + char *string;
1.5897 + int result;
1.5898 +
1.5899 + /*
1.5900 + * Copy the strings one after the other into a single larger
1.5901 + * string. Use stack-allocated space for small commands, but if
1.5902 + * the command gets too large than call ckalloc to create the
1.5903 + * space.
1.5904 + */
1.5905 +
1.5906 + Tcl_DStringInit(&buf);
1.5907 + while (1) {
1.5908 + string = va_arg(argList, char *);
1.5909 + if (string == NULL) {
1.5910 + break;
1.5911 + }
1.5912 + Tcl_DStringAppend(&buf, string, -1);
1.5913 + }
1.5914 +
1.5915 + result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
1.5916 + Tcl_DStringFree(&buf);
1.5917 + return result;
1.5918 +}
1.5919 +
1.5920 +/*
1.5921 + *----------------------------------------------------------------------
1.5922 + *
1.5923 + * Tcl_VarEval --
1.5924 + *
1.5925 + * Given a variable number of string arguments, concatenate them
1.5926 + * all together and execute the result as a Tcl command.
1.5927 + *
1.5928 + * Results:
1.5929 + * A standard Tcl return result. An error message or other
1.5930 + * result may be left in interp->result.
1.5931 + *
1.5932 + * Side effects:
1.5933 + * Depends on what was done by the command.
1.5934 + *
1.5935 + *----------------------------------------------------------------------
1.5936 + */
1.5937 + /* VARARGS2 */ /* ARGSUSED */
1.5938 +EXPORT_C int
1.5939 +Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
1.5940 +{
1.5941 + Tcl_Interp *interp;
1.5942 + va_list argList;
1.5943 + int result;
1.5944 +
1.5945 + interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
1.5946 + result = Tcl_VarEvalVA(interp, argList);
1.5947 + va_end(argList);
1.5948 +
1.5949 + return result;
1.5950 +}
1.5951 +
1.5952 +/*
1.5953 + *---------------------------------------------------------------------------
1.5954 + *
1.5955 + * Tcl_GlobalEval --
1.5956 + *
1.5957 + * Evaluate a command at global level in an interpreter.
1.5958 + *
1.5959 + * Results:
1.5960 + * A standard Tcl result is returned, and the interp's result is
1.5961 + * modified accordingly.
1.5962 + *
1.5963 + * Side effects:
1.5964 + * The command string is executed in interp, and the execution
1.5965 + * is carried out in the variable context of global level (no
1.5966 + * procedures active), just as if an "uplevel #0" command were
1.5967 + * being executed.
1.5968 + *
1.5969 + ---------------------------------------------------------------------------
1.5970 + */
1.5971 +
1.5972 +EXPORT_C int
1.5973 +Tcl_GlobalEval(interp, command)
1.5974 + Tcl_Interp *interp; /* Interpreter in which to evaluate command. */
1.5975 + CONST char *command; /* Command to evaluate. */
1.5976 +{
1.5977 + register Interp *iPtr = (Interp *) interp;
1.5978 + int result;
1.5979 + CallFrame *savedVarFramePtr;
1.5980 +
1.5981 + savedVarFramePtr = iPtr->varFramePtr;
1.5982 + iPtr->varFramePtr = NULL;
1.5983 + result = Tcl_Eval(interp, command);
1.5984 + iPtr->varFramePtr = savedVarFramePtr;
1.5985 + return result;
1.5986 +}
1.5987 +
1.5988 +/*
1.5989 + *----------------------------------------------------------------------
1.5990 + *
1.5991 + * Tcl_SetRecursionLimit --
1.5992 + *
1.5993 + * Set the maximum number of recursive calls that may be active
1.5994 + * for an interpreter at once.
1.5995 + *
1.5996 + * Results:
1.5997 + * The return value is the old limit on nesting for interp.
1.5998 + *
1.5999 + * Side effects:
1.6000 + * None.
1.6001 + *
1.6002 + *----------------------------------------------------------------------
1.6003 + */
1.6004 +
1.6005 +EXPORT_C int
1.6006 +Tcl_SetRecursionLimit(interp, depth)
1.6007 + Tcl_Interp *interp; /* Interpreter whose nesting limit
1.6008 + * is to be set. */
1.6009 + int depth; /* New value for maximimum depth. */
1.6010 +{
1.6011 + Interp *iPtr = (Interp *) interp;
1.6012 + int old;
1.6013 +
1.6014 + old = iPtr->maxNestingDepth;
1.6015 + if (depth > 0) {
1.6016 + iPtr->maxNestingDepth = depth;
1.6017 + }
1.6018 + return old;
1.6019 +}
1.6020 +
1.6021 +/*
1.6022 + *----------------------------------------------------------------------
1.6023 + *
1.6024 + * Tcl_AllowExceptions --
1.6025 + *
1.6026 + * Sets a flag in an interpreter so that exceptions can occur
1.6027 + * in the next call to Tcl_Eval without them being turned into
1.6028 + * errors.
1.6029 + *
1.6030 + * Results:
1.6031 + * None.
1.6032 + *
1.6033 + * Side effects:
1.6034 + * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's
1.6035 + * evalFlags structure. See the reference documentation for
1.6036 + * more details.
1.6037 + *
1.6038 + *----------------------------------------------------------------------
1.6039 + */
1.6040 +
1.6041 +EXPORT_C void
1.6042 +Tcl_AllowExceptions(interp)
1.6043 + Tcl_Interp *interp; /* Interpreter in which to set flag. */
1.6044 +{
1.6045 + Interp *iPtr = (Interp *) interp;
1.6046 +
1.6047 + iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
1.6048 +}
1.6049 +
1.6050 +
1.6051 +/*
1.6052 + *----------------------------------------------------------------------
1.6053 + *
1.6054 + * Tcl_GetVersion
1.6055 + *
1.6056 + * Get the Tcl major, minor, and patchlevel version numbers and
1.6057 + * the release type. A patch is a release type TCL_FINAL_RELEASE
1.6058 + * with a patchLevel > 0.
1.6059 + *
1.6060 + * Results:
1.6061 + * None.
1.6062 + *
1.6063 + * Side effects:
1.6064 + * None.
1.6065 + *
1.6066 + *----------------------------------------------------------------------
1.6067 + */
1.6068 +
1.6069 +EXPORT_C void
1.6070 +Tcl_GetVersion(majorV, minorV, patchLevelV, type)
1.6071 + int *majorV;
1.6072 + int *minorV;
1.6073 + int *patchLevelV;
1.6074 + int *type;
1.6075 +{
1.6076 + if (majorV != NULL) {
1.6077 + *majorV = TCL_MAJOR_VERSION;
1.6078 + }
1.6079 + if (minorV != NULL) {
1.6080 + *minorV = TCL_MINOR_VERSION;
1.6081 + }
1.6082 + if (patchLevelV != NULL) {
1.6083 + *patchLevelV = TCL_RELEASE_SERIAL;
1.6084 + }
1.6085 + if (type != NULL) {
1.6086 + *type = TCL_RELEASE_LEVEL;
1.6087 + }
1.6088 +}
1.6089 +
1.6090 +/*
1.6091 + * Local Variables:
1.6092 + * mode: c
1.6093 + * c-basic-offset: 4
1.6094 + * fill-column: 78
1.6095 + * End:
1.6096 + */
1.6097 +