1/* 2 * tclBasic.c -- 3 * 4 * Contains the basic facilities for TCL command interpretation, 5 * including interpreter creation and deletion, command creation 6 * and deletion, and command/script execution. 7 * 8 * Copyright (c) 1987-1994 The Regents of the University of California. 9 * Copyright (c) 1994-1997 Sun Microsystems, Inc. 10 * Copyright (c) 1998-1999 by Scriptics Corporation. 11 * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. 12 * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> 13 * 14 * See the file "license.terms" for information on usage and redistribution 15 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 16 * 17 * RCS: @(#) $Id: tclBasic.c,v 1.75.2.28 2007/09/13 16:13:19 das Exp $ 18 */ 19 20#include "tclInt.h" 21#include "tclCompile.h" 22#ifndef TCL_GENERIC_ONLY 23# include "tclPort.h" 24#endif 25 26/* 27 * Static procedures in this file: 28 */ 29 30static char * CallCommandTraces _ANSI_ARGS_((Interp *iPtr, 31 Command *cmdPtr, CONST char *oldName, 32 CONST char* newName, int flags)); 33static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); 34static void ProcessUnexpectedResult _ANSI_ARGS_(( 35 Tcl_Interp *interp, int returnCode)); 36static int StringTraceProc _ANSI_ARGS_((ClientData clientData, 37 Tcl_Interp* interp, 38 int level, 39 CONST char* command, 40 Tcl_Command commandInfo, 41 int objc, 42 Tcl_Obj *CONST objv[])); 43static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData)); 44 45#ifdef TCL_TIP280 46/* TIP #280 - Modified token based evaluation, with line information */ 47static int EvalEx _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script, 48 int numBytes, int flags, int line, 49 int* clNextOuter, CONST char* outerScript)); 50 51static int EvalTokensStandard _ANSI_ARGS_((Tcl_Interp *interp, 52 Tcl_Token *tokenPtr, 53 int count, int line, 54 int* clNextOuter, CONST char* outerScript)); 55#endif 56 57#ifdef USE_DTRACE 58static int DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, 59 Tcl_Obj *CONST objv[]); 60#endif 61 62extern TclStubs tclStubs; 63 64/* 65 * The following structure defines the commands in the Tcl core. 66 */ 67 68typedef struct { 69 char *name; /* Name of object-based command. */ 70 Tcl_CmdProc *proc; /* String-based procedure for command. */ 71 Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */ 72 CompileProc *compileProc; /* Procedure called to compile command. */ 73 int isSafe; /* If non-zero, command will be present 74 * in safe interpreter. Otherwise it will 75 * be hidden. */ 76} CmdInfo; 77 78/* 79 * The built-in commands, and the procedures that implement them: 80 */ 81 82static CmdInfo builtInCmds[] = { 83 /* 84 * Commands in the generic core. Note that at least one of the proc or 85 * objProc members should be non-NULL. This avoids infinitely recursive 86 * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a 87 * command name is computed at runtime and results in the name of a 88 * compiled command. 89 */ 90 91 {"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd, 92 TclCompileAppendCmd, 1}, 93 {"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd, 94 (CompileProc *) NULL, 1}, 95 {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd, 96 (CompileProc *) NULL, 1}, 97 {"break", (Tcl_CmdProc *) NULL, Tcl_BreakObjCmd, 98 TclCompileBreakCmd, 1}, 99 {"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd, 100 (CompileProc *) NULL, 1}, 101 {"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd, 102 TclCompileCatchCmd, 1}, 103 {"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd, 104 (CompileProc *) NULL, 1}, 105 {"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd, 106 (CompileProc *) NULL, 1}, 107 {"continue", (Tcl_CmdProc *) NULL, Tcl_ContinueObjCmd, 108 TclCompileContinueCmd, 1}, 109 {"encoding", (Tcl_CmdProc *) NULL, Tcl_EncodingObjCmd, 110 (CompileProc *) NULL, 0}, 111 {"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd, 112 (CompileProc *) NULL, 1}, 113 {"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd, 114 (CompileProc *) NULL, 1}, 115 {"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd, 116 (CompileProc *) NULL, 0}, 117 {"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd, 118 TclCompileExprCmd, 1}, 119 {"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd, 120 (CompileProc *) NULL, 1}, 121 {"fileevent", (Tcl_CmdProc *) NULL, Tcl_FileEventObjCmd, 122 (CompileProc *) NULL, 1}, 123 {"for", (Tcl_CmdProc *) NULL, Tcl_ForObjCmd, 124 TclCompileForCmd, 1}, 125 {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd, 126 TclCompileForeachCmd, 1}, 127 {"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd, 128 (CompileProc *) NULL, 1}, 129 {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd, 130 (CompileProc *) NULL, 1}, 131 {"if", (Tcl_CmdProc *) NULL, Tcl_IfObjCmd, 132 TclCompileIfCmd, 1}, 133 {"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd, 134 TclCompileIncrCmd, 1}, 135 {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd, 136 (CompileProc *) NULL, 1}, 137 {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd, 138 (CompileProc *) NULL, 1}, 139 {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd, 140 TclCompileLappendCmd, 1}, 141 {"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd, 142 TclCompileLindexCmd, 1}, 143 {"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd, 144 (CompileProc *) NULL, 1}, 145 {"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd, 146 TclCompileListCmd, 1}, 147 {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd, 148 TclCompileLlengthCmd, 1}, 149 {"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd, 150 (CompileProc *) NULL, 0}, 151 {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd, 152 (CompileProc *) NULL, 1}, 153 {"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd, 154 (CompileProc *) NULL, 1}, 155 {"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd, 156 (CompileProc *) NULL, 1}, 157 {"lset", (Tcl_CmdProc *) NULL, Tcl_LsetObjCmd, 158 TclCompileLsetCmd, 1}, 159 {"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd, 160 (CompileProc *) NULL, 1}, 161 {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd, 162 (CompileProc *) NULL, 1}, 163 {"package", (Tcl_CmdProc *) NULL, Tcl_PackageObjCmd, 164 (CompileProc *) NULL, 1}, 165 {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd, 166 (CompileProc *) NULL, 1}, 167 {"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd, 168 TclCompileRegexpCmd, 1}, 169 {"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd, 170 (CompileProc *) NULL, 1}, 171 {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd, 172 (CompileProc *) NULL, 1}, 173 {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd, 174 TclCompileReturnCmd, 1}, 175 {"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd, 176 (CompileProc *) NULL, 1}, 177 {"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd, 178 TclCompileSetCmd, 1}, 179 {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd, 180 (CompileProc *) NULL, 1}, 181 {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd, 182 TclCompileStringCmd, 1}, 183 {"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd, 184 (CompileProc *) NULL, 1}, 185 {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd, 186 (CompileProc *) NULL, 1}, 187 {"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd, 188 (CompileProc *) NULL, 1}, 189 {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd, 190 (CompileProc *) NULL, 1}, 191 {"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd, 192 (CompileProc *) NULL, 1}, 193 {"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd, 194 (CompileProc *) NULL, 1}, 195 {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd, 196 (CompileProc *) NULL, 1}, 197 {"while", (Tcl_CmdProc *) NULL, Tcl_WhileObjCmd, 198 TclCompileWhileCmd, 1}, 199 200 /* 201 * Commands in the UNIX core: 202 */ 203 204#ifndef TCL_GENERIC_ONLY 205 {"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd, 206 (CompileProc *) NULL, 1}, 207 {"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd, 208 (CompileProc *) NULL, 0}, 209 {"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd, 210 (CompileProc *) NULL, 1}, 211 {"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd, 212 (CompileProc *) NULL, 1}, 213 {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd, 214 (CompileProc *) NULL, 1}, 215 {"fconfigure", (Tcl_CmdProc *) NULL, Tcl_FconfigureObjCmd, 216 (CompileProc *) NULL, 0}, 217 {"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd, 218 (CompileProc *) NULL, 0}, 219 {"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd, 220 (CompileProc *) NULL, 1}, 221 {"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd, 222 (CompileProc *) NULL, 1}, 223 {"glob", (Tcl_CmdProc *) NULL, Tcl_GlobObjCmd, 224 (CompileProc *) NULL, 0}, 225 {"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd, 226 (CompileProc *) NULL, 0}, 227 {"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd, 228 (CompileProc *) NULL, 1}, 229 {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd, 230 (CompileProc *) NULL, 1}, 231 {"pwd", (Tcl_CmdProc *) NULL, Tcl_PwdObjCmd, 232 (CompileProc *) NULL, 0}, 233 {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd, 234 (CompileProc *) NULL, 1}, 235 {"seek", (Tcl_CmdProc *) NULL, Tcl_SeekObjCmd, 236 (CompileProc *) NULL, 1}, 237 {"socket", (Tcl_CmdProc *) NULL, Tcl_SocketObjCmd, 238 (CompileProc *) NULL, 0}, 239 {"tell", (Tcl_CmdProc *) NULL, Tcl_TellObjCmd, 240 (CompileProc *) NULL, 1}, 241 {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd, 242 (CompileProc *) NULL, 1}, 243 {"update", (Tcl_CmdProc *) NULL, Tcl_UpdateObjCmd, 244 (CompileProc *) NULL, 1}, 245 {"vwait", (Tcl_CmdProc *) NULL, Tcl_VwaitObjCmd, 246 (CompileProc *) NULL, 1}, 247 248#ifdef MAC_TCL 249 {"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd, 250 (CompileProc *) NULL, 0}, 251 {"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL, 252 (CompileProc *) NULL, 0}, 253 {"ls", (Tcl_CmdProc *) NULL, Tcl_LsObjCmd, 254 (CompileProc *) NULL, 0}, 255 {"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd, 256 (CompileProc *) NULL, 1}, 257 {"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd, 258 (CompileProc *) NULL, 0}, 259#else 260 {"exec", (Tcl_CmdProc *) NULL, Tcl_ExecObjCmd, 261 (CompileProc *) NULL, 0}, 262 {"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd, 263 (CompileProc *) NULL, 0}, 264#endif /* MAC_TCL */ 265 266#endif /* TCL_GENERIC_ONLY */ 267 {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL, 268 (CompileProc *) NULL, 0} 269}; 270 271/* 272 * The following structure holds the client data for string-based 273 * trace procs 274 */ 275 276typedef struct StringTraceData { 277 ClientData clientData; /* Client data from Tcl_CreateTrace */ 278 Tcl_CmdTraceProc* proc; /* Trace procedure from Tcl_CreateTrace */ 279} StringTraceData; 280 281/* 282 *---------------------------------------------------------------------- 283 * 284 * Tcl_CreateInterp -- 285 * 286 * Create a new TCL command interpreter. 287 * 288 * Results: 289 * The return value is a token for the interpreter, which may be 290 * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or 291 * Tcl_DeleteInterp. 292 * 293 * Side effects: 294 * The command interpreter is initialized with the built-in commands 295 * and with the variables documented in tclvars(n). 296 * 297 *---------------------------------------------------------------------- 298 */ 299 300Tcl_Interp * 301Tcl_CreateInterp() 302{ 303 Interp *iPtr; 304 Tcl_Interp *interp; 305 Command *cmdPtr; 306 BuiltinFunc *builtinFuncPtr; 307 MathFunc *mathFuncPtr; 308 Tcl_HashEntry *hPtr; 309 CmdInfo *cmdInfoPtr; 310 int i; 311 union { 312 char c[sizeof(short)]; 313 short s; 314 } order; 315#ifdef TCL_COMPILE_STATS 316 ByteCodeStats *statsPtr; 317#endif /* TCL_COMPILE_STATS */ 318 319 TclInitSubsystems(NULL); 320 321 /* 322 * Panic if someone updated the CallFrame structure without 323 * also updating the Tcl_CallFrame structure (or vice versa). 324 */ 325 326 if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) { 327 /*NOTREACHED*/ 328 panic("Tcl_CallFrame must not be smaller than CallFrame"); 329 } 330 331 /* 332 * Initialize support for namespaces and create the global namespace 333 * (whose name is ""; an alias is "::"). This also initializes the 334 * Tcl object type table and other object management code. 335 */ 336 337 iPtr = (Interp *) ckalloc(sizeof(Interp)); 338 interp = (Tcl_Interp *) iPtr; 339 340 iPtr->result = iPtr->resultSpace; 341 iPtr->freeProc = NULL; 342 iPtr->errorLine = 0; 343 iPtr->objResultPtr = Tcl_NewObj(); 344 Tcl_IncrRefCount(iPtr->objResultPtr); 345 iPtr->handle = TclHandleCreate(iPtr); 346 iPtr->globalNsPtr = NULL; 347 iPtr->hiddenCmdTablePtr = NULL; 348 iPtr->interpInfo = NULL; 349 Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); 350 351 iPtr->numLevels = 0; 352 iPtr->maxNestingDepth = MAX_NESTING_DEPTH; 353 iPtr->framePtr = NULL; 354 iPtr->varFramePtr = NULL; 355 356#ifdef TCL_TIP280 357 /* 358 * TIP #280 - Initialize the arrays used to extend the ByteCode and 359 * Proc structures. 360 */ 361 iPtr->cmdFramePtr = NULL; 362 iPtr->linePBodyPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); 363 iPtr->lineBCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); 364 iPtr->lineLAPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); 365 iPtr->lineLABCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); 366 Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS); 367 Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS); 368 Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS); 369 Tcl_InitHashTable(iPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); 370 iPtr->scriptCLLocPtr = NULL; 371#endif 372 373 iPtr->activeVarTracePtr = NULL; 374 iPtr->returnCode = TCL_OK; 375 iPtr->errorInfo = NULL; 376 iPtr->errorCode = NULL; 377 378 iPtr->appendResult = NULL; 379 iPtr->appendAvl = 0; 380 iPtr->appendUsed = 0; 381 382 Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); 383 iPtr->packageUnknown = NULL; 384#ifdef TCL_TIP268 385 /* TIP #268 */ 386 iPtr->packagePrefer = (getenv ("TCL_PKG_PREFER_LATEST") == NULL ? 387 PKG_PREFER_STABLE : 388 PKG_PREFER_LATEST); 389#endif 390 iPtr->cmdCount = 0; 391 iPtr->termOffset = 0; 392 TclInitLiteralTable(&(iPtr->literalTable)); 393 iPtr->compileEpoch = 0; 394 iPtr->compiledProcPtr = NULL; 395 iPtr->resolverPtr = NULL; 396 iPtr->evalFlags = 0; 397 iPtr->scriptFile = NULL; 398 iPtr->flags = 0; 399 iPtr->tracePtr = NULL; 400 iPtr->tracesForbiddingInline = 0; 401 iPtr->activeCmdTracePtr = NULL; 402 iPtr->activeInterpTracePtr = NULL; 403 iPtr->assocData = (Tcl_HashTable *) NULL; 404 iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ 405 iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ 406 Tcl_IncrRefCount(iPtr->emptyObjPtr); 407 iPtr->resultSpace[0] = 0; 408 iPtr->threadId = Tcl_GetCurrentThread(); 409 410 iPtr->globalNsPtr = NULL; /* force creation of global ns below */ 411 iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "", 412 (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); 413 if (iPtr->globalNsPtr == NULL) { 414 panic("Tcl_CreateInterp: can't create global namespace"); 415 } 416 417 /* 418 * Initialize support for code compilation and execution. We call 419 * TclCreateExecEnv after initializing namespaces since it tries to 420 * reference a Tcl variable (it links to the Tcl "tcl_traceExec" 421 * variable). 422 */ 423 424 iPtr->execEnvPtr = TclCreateExecEnv(interp); 425 426 /* 427 * Initialize the compilation and execution statistics kept for this 428 * interpreter. 429 */ 430 431#ifdef TCL_COMPILE_STATS 432 statsPtr = &(iPtr->stats); 433 statsPtr->numExecutions = 0; 434 statsPtr->numCompilations = 0; 435 statsPtr->numByteCodesFreed = 0; 436 (VOID *) memset(statsPtr->instructionCount, 0, 437 sizeof(statsPtr->instructionCount)); 438 439 statsPtr->totalSrcBytes = 0.0; 440 statsPtr->totalByteCodeBytes = 0.0; 441 statsPtr->currentSrcBytes = 0.0; 442 statsPtr->currentByteCodeBytes = 0.0; 443 (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); 444 (VOID *) memset(statsPtr->byteCodeCount, 0, 445 sizeof(statsPtr->byteCodeCount)); 446 (VOID *) memset(statsPtr->lifetimeCount, 0, 447 sizeof(statsPtr->lifetimeCount)); 448 449 statsPtr->currentInstBytes = 0.0; 450 statsPtr->currentLitBytes = 0.0; 451 statsPtr->currentExceptBytes = 0.0; 452 statsPtr->currentAuxBytes = 0.0; 453 statsPtr->currentCmdMapBytes = 0.0; 454 455 statsPtr->numLiteralsCreated = 0; 456 statsPtr->totalLitStringBytes = 0.0; 457 statsPtr->currentLitStringBytes = 0.0; 458 (VOID *) memset(statsPtr->literalCount, 0, 459 sizeof(statsPtr->literalCount)); 460#endif /* TCL_COMPILE_STATS */ 461 462 /* 463 * Initialise the stub table pointer. 464 */ 465 466 iPtr->stubTable = &tclStubs; 467 468 469 /* 470 * Create the core commands. Do it here, rather than calling 471 * Tcl_CreateCommand, because it's faster (there's no need to check for 472 * a pre-existing command by the same name). If a command has a 473 * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to 474 * TclInvokeStringCommand. This is an object-based wrapper procedure 475 * that extracts strings, calls the string procedure, and creates an 476 * object for the result. Similarly, if a command has a Tcl_ObjCmdProc 477 * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. 478 */ 479 480 for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; 481 cmdInfoPtr++) { 482 int new; 483 Tcl_HashEntry *hPtr; 484 485 if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) 486 && (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) 487 && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) { 488 panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n"); 489 } 490 491 hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, 492 cmdInfoPtr->name, &new); 493 if (new) { 494 cmdPtr = (Command *) ckalloc(sizeof(Command)); 495 cmdPtr->hPtr = hPtr; 496 cmdPtr->nsPtr = iPtr->globalNsPtr; 497 cmdPtr->refCount = 1; 498 cmdPtr->cmdEpoch = 0; 499 cmdPtr->compileProc = cmdInfoPtr->compileProc; 500 if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) { 501 cmdPtr->proc = TclInvokeObjectCommand; 502 cmdPtr->clientData = (ClientData) cmdPtr; 503 } else { 504 cmdPtr->proc = cmdInfoPtr->proc; 505 cmdPtr->clientData = (ClientData) NULL; 506 } 507 if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { 508 cmdPtr->objProc = TclInvokeStringCommand; 509 cmdPtr->objClientData = (ClientData) cmdPtr; 510 } else { 511 cmdPtr->objProc = cmdInfoPtr->objProc; 512 cmdPtr->objClientData = (ClientData) NULL; 513 } 514 cmdPtr->deleteProc = NULL; 515 cmdPtr->deleteData = (ClientData) NULL; 516 cmdPtr->flags = 0; 517 cmdPtr->importRefPtr = NULL; 518 cmdPtr->tracePtr = NULL; 519 Tcl_SetHashValue(hPtr, cmdPtr); 520 } 521 } 522 523#ifdef USE_DTRACE 524 /* 525 * Register the tcl::dtrace command. 526 */ 527 528 Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL); 529#endif /* USE_DTRACE */ 530 531 /* 532 * Register the builtin math functions. 533 */ 534 535 i = 0; 536 for (builtinFuncPtr = tclBuiltinFuncTable; builtinFuncPtr->name != NULL; 537 builtinFuncPtr++) { 538 Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name, 539 builtinFuncPtr->numArgs, builtinFuncPtr->argTypes, 540 (Tcl_MathProc *) NULL, (ClientData) 0); 541 hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, 542 builtinFuncPtr->name); 543 if (hPtr == NULL) { 544 panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name); 545 return NULL; 546 } 547 mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); 548 mathFuncPtr->builtinFuncIndex = i; 549 i++; 550 } 551 iPtr->flags |= EXPR_INITIALIZED; 552 553 /* 554 * Do Multiple/Safe Interps Tcl init stuff 555 */ 556 557 TclInterpInit(interp); 558 559 /* 560 * We used to create the "errorInfo" and "errorCode" global vars at this 561 * point because so much of the Tcl implementation assumes they already 562 * exist. This is not quite enough, however, since they can be unset 563 * at any time. 564 * 565 * There are 2 choices: 566 * + Check every place where a GetVar of those is used 567 * and the NULL result is not checked (like in tclLoad.c) 568 * + Make SetVar,... NULL friendly 569 * We choose the second option because : 570 * + It is easy and low cost to check for NULL pointer before 571 * calling strlen() 572 * + It can be helpfull to other people using those API 573 * + Passing a NULL value to those closest 'meaning' is empty string 574 * (specially with the new objects where 0 bytes strings are ok) 575 * So the following init is commented out: -- dl 576 * 577 * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, 578 * "", TCL_GLOBAL_ONLY); 579 * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, 580 * "NONE", TCL_GLOBAL_ONLY); 581 */ 582 583#ifndef TCL_GENERIC_ONLY 584 TclSetupEnv(interp); 585#endif 586 587 /* 588 * Compute the byte order of this machine. 589 */ 590 591 order.s = 1; 592 Tcl_SetVar2(interp, "tcl_platform", "byteOrder", 593 ((order.c[0] == 1) ? "littleEndian" : "bigEndian"), 594 TCL_GLOBAL_ONLY); 595 596 Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize", 597 Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY); 598 599 /* 600 * Set up other variables such as tcl_version and tcl_library 601 */ 602 603 Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); 604 Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); 605 Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL, 606 TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, 607 TclPrecTraceProc, (ClientData) NULL); 608 TclpSetVariables(interp); 609 610#ifdef TCL_THREADS 611 /* 612 * The existence of the "threaded" element of the tcl_platform array indicates 613 * that this particular Tcl shell has been compiled with threads turned on. 614 * Using "info exists tcl_platform(threaded)" a Tcl script can introspect on the 615 * interpreter level of thread safety. 616 */ 617 618 619 Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", 620 TCL_GLOBAL_ONLY); 621#endif 622 623 /* 624 * Register Tcl's version number. 625 * TIP#268: Expose information about its status, 626 * for runtime switches in the core library 627 * and tests. 628 */ 629 630 Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs); 631 632#ifdef TCL_TIP268 633 Tcl_SetVar2(interp, "tcl_platform", "tip,268", "1", 634 TCL_GLOBAL_ONLY); 635#endif 636#ifdef TCL_TIP280 637 Tcl_SetVar2(interp, "tcl_platform", "tip,280", "1", 638 TCL_GLOBAL_ONLY); 639#endif 640#ifdef Tcl_InitStubs 641#undef Tcl_InitStubs 642#endif 643 Tcl_InitStubs(interp, TCL_VERSION, 1); 644 645 return interp; 646} 647 648/* 649 *---------------------------------------------------------------------- 650 * 651 * TclHideUnsafeCommands -- 652 * 653 * Hides base commands that are not marked as safe from this 654 * interpreter. 655 * 656 * Results: 657 * TCL_OK if it succeeds, TCL_ERROR else. 658 * 659 * Side effects: 660 * Hides functionality in an interpreter. 661 * 662 *---------------------------------------------------------------------- 663 */ 664 665int 666TclHideUnsafeCommands(interp) 667 Tcl_Interp *interp; /* Hide commands in this interpreter. */ 668{ 669 register CmdInfo *cmdInfoPtr; 670 671 if (interp == (Tcl_Interp *) NULL) { 672 return TCL_ERROR; 673 } 674 for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { 675 if (!cmdInfoPtr->isSafe) { 676 Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); 677 } 678 } 679 return TCL_OK; 680} 681 682/* 683 *-------------------------------------------------------------- 684 * 685 * Tcl_CallWhenDeleted -- 686 * 687 * Arrange for a procedure to be called before a given 688 * interpreter is deleted. The procedure is called as soon 689 * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is 690 * called on an interpreter that has already been deleted, 691 * the procedure will be called when the last Tcl_Release is 692 * done on the interpreter. 693 * 694 * Results: 695 * None. 696 * 697 * Side effects: 698 * When Tcl_DeleteInterp is invoked to delete interp, 699 * proc will be invoked. See the manual entry for 700 * details. 701 * 702 *-------------------------------------------------------------- 703 */ 704 705void 706Tcl_CallWhenDeleted(interp, proc, clientData) 707 Tcl_Interp *interp; /* Interpreter to watch. */ 708 Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter 709 * is about to be deleted. */ 710 ClientData clientData; /* One-word value to pass to proc. */ 711{ 712 Interp *iPtr = (Interp *) interp; 713 static Tcl_ThreadDataKey assocDataCounterKey; 714 int *assocDataCounterPtr = 715 Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int)); 716 int new; 717 char buffer[32 + TCL_INTEGER_SPACE]; 718 AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); 719 Tcl_HashEntry *hPtr; 720 721 sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr); 722 (*assocDataCounterPtr)++; 723 724 if (iPtr->assocData == (Tcl_HashTable *) NULL) { 725 iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); 726 Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); 727 } 728 hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new); 729 dPtr->proc = proc; 730 dPtr->clientData = clientData; 731 Tcl_SetHashValue(hPtr, dPtr); 732} 733 734/* 735 *-------------------------------------------------------------- 736 * 737 * Tcl_DontCallWhenDeleted -- 738 * 739 * Cancel the arrangement for a procedure to be called when 740 * a given interpreter is deleted. 741 * 742 * Results: 743 * None. 744 * 745 * Side effects: 746 * If proc and clientData were previously registered as a 747 * callback via Tcl_CallWhenDeleted, they are unregistered. 748 * If they weren't previously registered then nothing 749 * happens. 750 * 751 *-------------------------------------------------------------- 752 */ 753 754void 755Tcl_DontCallWhenDeleted(interp, proc, clientData) 756 Tcl_Interp *interp; /* Interpreter to watch. */ 757 Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter 758 * is about to be deleted. */ 759 ClientData clientData; /* One-word value to pass to proc. */ 760{ 761 Interp *iPtr = (Interp *) interp; 762 Tcl_HashTable *hTablePtr; 763 Tcl_HashSearch hSearch; 764 Tcl_HashEntry *hPtr; 765 AssocData *dPtr; 766 767 hTablePtr = iPtr->assocData; 768 if (hTablePtr == (Tcl_HashTable *) NULL) { 769 return; 770 } 771 for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; 772 hPtr = Tcl_NextHashEntry(&hSearch)) { 773 dPtr = (AssocData *) Tcl_GetHashValue(hPtr); 774 if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { 775 ckfree((char *) dPtr); 776 Tcl_DeleteHashEntry(hPtr); 777 return; 778 } 779 } 780} 781 782/* 783 *---------------------------------------------------------------------- 784 * 785 * Tcl_SetAssocData -- 786 * 787 * Creates a named association between user-specified data, a delete 788 * function and this interpreter. If the association already exists 789 * the data is overwritten with the new data. The delete function will 790 * be invoked when the interpreter is deleted. 791 * 792 * Results: 793 * None. 794 * 795 * Side effects: 796 * Sets the associated data, creates the association if needed. 797 * 798 *---------------------------------------------------------------------- 799 */ 800 801void 802Tcl_SetAssocData(interp, name, proc, clientData) 803 Tcl_Interp *interp; /* Interpreter to associate with. */ 804 CONST char *name; /* Name for association. */ 805 Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is 806 * about to be deleted. */ 807 ClientData clientData; /* One-word value to pass to proc. */ 808{ 809 Interp *iPtr = (Interp *) interp; 810 AssocData *dPtr; 811 Tcl_HashEntry *hPtr; 812 int new; 813 814 if (iPtr->assocData == (Tcl_HashTable *) NULL) { 815 iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); 816 Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); 817 } 818 hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new); 819 if (new == 0) { 820 dPtr = (AssocData *) Tcl_GetHashValue(hPtr); 821 } else { 822 dPtr = (AssocData *) ckalloc(sizeof(AssocData)); 823 } 824 dPtr->proc = proc; 825 dPtr->clientData = clientData; 826 827 Tcl_SetHashValue(hPtr, dPtr); 828} 829 830/* 831 *---------------------------------------------------------------------- 832 * 833 * Tcl_DeleteAssocData -- 834 * 835 * Deletes a named association of user-specified data with 836 * the specified interpreter. 837 * 838 * Results: 839 * None. 840 * 841 * Side effects: 842 * Deletes the association. 843 * 844 *---------------------------------------------------------------------- 845 */ 846 847void 848Tcl_DeleteAssocData(interp, name) 849 Tcl_Interp *interp; /* Interpreter to associate with. */ 850 CONST char *name; /* Name of association. */ 851{ 852 Interp *iPtr = (Interp *) interp; 853 AssocData *dPtr; 854 Tcl_HashEntry *hPtr; 855 856 if (iPtr->assocData == (Tcl_HashTable *) NULL) { 857 return; 858 } 859 hPtr = Tcl_FindHashEntry(iPtr->assocData, name); 860 if (hPtr == (Tcl_HashEntry *) NULL) { 861 return; 862 } 863 dPtr = (AssocData *) Tcl_GetHashValue(hPtr); 864 if (dPtr->proc != NULL) { 865 (dPtr->proc) (dPtr->clientData, interp); 866 } 867 ckfree((char *) dPtr); 868 Tcl_DeleteHashEntry(hPtr); 869} 870 871/* 872 *---------------------------------------------------------------------- 873 * 874 * Tcl_GetAssocData -- 875 * 876 * Returns the client data associated with this name in the 877 * specified interpreter. 878 * 879 * Results: 880 * The client data in the AssocData record denoted by the named 881 * association, or NULL. 882 * 883 * Side effects: 884 * None. 885 * 886 *---------------------------------------------------------------------- 887 */ 888 889ClientData 890Tcl_GetAssocData(interp, name, procPtr) 891 Tcl_Interp *interp; /* Interpreter associated with. */ 892 CONST char *name; /* Name of association. */ 893 Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address 894 * of current deletion callback. */ 895{ 896 Interp *iPtr = (Interp *) interp; 897 AssocData *dPtr; 898 Tcl_HashEntry *hPtr; 899 900 if (iPtr->assocData == (Tcl_HashTable *) NULL) { 901 return (ClientData) NULL; 902 } 903 hPtr = Tcl_FindHashEntry(iPtr->assocData, name); 904 if (hPtr == (Tcl_HashEntry *) NULL) { 905 return (ClientData) NULL; 906 } 907 dPtr = (AssocData *) Tcl_GetHashValue(hPtr); 908 if (procPtr != (Tcl_InterpDeleteProc **) NULL) { 909 *procPtr = dPtr->proc; 910 } 911 return dPtr->clientData; 912} 913 914/* 915 *---------------------------------------------------------------------- 916 * 917 * Tcl_InterpDeleted -- 918 * 919 * Returns nonzero if the interpreter has been deleted with a call 920 * to Tcl_DeleteInterp. 921 * 922 * Results: 923 * Nonzero if the interpreter is deleted, zero otherwise. 924 * 925 * Side effects: 926 * None. 927 * 928 *---------------------------------------------------------------------- 929 */ 930 931int 932Tcl_InterpDeleted(interp) 933 Tcl_Interp *interp; 934{ 935 return (((Interp *) interp)->flags & DELETED) ? 1 : 0; 936} 937 938/* 939 *---------------------------------------------------------------------- 940 * 941 * Tcl_DeleteInterp -- 942 * 943 * Ensures that the interpreter will be deleted eventually. If there 944 * are no Tcl_Preserve calls in effect for this interpreter, it is 945 * deleted immediately, otherwise the interpreter is deleted when 946 * the last Tcl_Preserve is matched by a call to Tcl_Release. In either 947 * case, the procedure runs the currently registered deletion callbacks. 948 * 949 * Results: 950 * None. 951 * 952 * Side effects: 953 * The interpreter is marked as deleted. The caller may still use it 954 * safely if there are calls to Tcl_Preserve in effect for the 955 * interpreter, but further calls to Tcl_Eval etc in this interpreter 956 * will fail. 957 * 958 *---------------------------------------------------------------------- 959 */ 960 961void 962Tcl_DeleteInterp(interp) 963 Tcl_Interp *interp; /* Token for command interpreter (returned 964 * by a previous call to Tcl_CreateInterp). */ 965{ 966 Interp *iPtr = (Interp *) interp; 967 968 /* 969 * If the interpreter has already been marked deleted, just punt. 970 */ 971 972 if (iPtr->flags & DELETED) { 973 return; 974 } 975 976 /* 977 * Mark the interpreter as deleted. No further evals will be allowed. 978 */ 979 980 iPtr->flags |= DELETED; 981 982 /* 983 * Ensure that the interpreter is eventually deleted. 984 */ 985 986 Tcl_EventuallyFree((ClientData) interp, 987 (Tcl_FreeProc *) DeleteInterpProc); 988} 989 990/* 991 *---------------------------------------------------------------------- 992 * 993 * DeleteInterpProc -- 994 * 995 * Helper procedure to delete an interpreter. This procedure is 996 * called when the last call to Tcl_Preserve on this interpreter 997 * is matched by a call to Tcl_Release. The procedure cleans up 998 * all resources used in the interpreter and calls all currently 999 * registered interpreter deletion callbacks. 1000 * 1001 * Results: 1002 * None. 1003 * 1004 * Side effects: 1005 * Whatever the interpreter deletion callbacks do. Frees resources 1006 * used by the interpreter. 1007 * 1008 *---------------------------------------------------------------------- 1009 */ 1010 1011static void 1012DeleteInterpProc(interp) 1013 Tcl_Interp *interp; /* Interpreter to delete. */ 1014{ 1015 Interp *iPtr = (Interp *) interp; 1016 Tcl_HashEntry *hPtr; 1017 Tcl_HashSearch search; 1018 Tcl_HashTable *hTablePtr; 1019 ResolverScheme *resPtr, *nextResPtr; 1020 1021 /* 1022 * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. 1023 */ 1024 1025 if (iPtr->numLevels > 0) { 1026 panic("DeleteInterpProc called with active evals"); 1027 } 1028 1029 /* 1030 * The interpreter should already be marked deleted; otherwise how 1031 * did we get here? 1032 */ 1033 1034 if (!(iPtr->flags & DELETED)) { 1035 panic("DeleteInterpProc called on interpreter not marked deleted"); 1036 } 1037 1038 TclHandleFree(iPtr->handle); 1039 1040 /* 1041 * Dismantle everything in the global namespace except for the 1042 * "errorInfo" and "errorCode" variables. These remain until the 1043 * namespace is actually destroyed, in case any errors occur. 1044 * 1045 * Dismantle the namespace here, before we clear the assocData. If any 1046 * background errors occur here, they will be deleted below. 1047 */ 1048 1049 TclTeardownNamespace(iPtr->globalNsPtr); 1050 1051 /* 1052 * Delete all the hidden commands. 1053 */ 1054 1055 hTablePtr = iPtr->hiddenCmdTablePtr; 1056 if (hTablePtr != NULL) { 1057 /* 1058 * Non-pernicious deletion. The deletion callbacks will not be 1059 * allowed to create any new hidden or non-hidden commands. 1060 * Tcl_DeleteCommandFromToken() will remove the entry from the 1061 * hiddenCmdTablePtr. 1062 */ 1063 1064 hPtr = Tcl_FirstHashEntry(hTablePtr, &search); 1065 for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { 1066 Tcl_DeleteCommandFromToken(interp, 1067 (Tcl_Command) Tcl_GetHashValue(hPtr)); 1068 } 1069 Tcl_DeleteHashTable(hTablePtr); 1070 ckfree((char *) hTablePtr); 1071 } 1072 /* 1073 * Tear down the math function table. 1074 */ 1075 1076 for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search); 1077 hPtr != NULL; 1078 hPtr = Tcl_NextHashEntry(&search)) { 1079 ckfree((char *) Tcl_GetHashValue(hPtr)); 1080 } 1081 Tcl_DeleteHashTable(&iPtr->mathFuncTable); 1082 1083 /* 1084 * Invoke deletion callbacks; note that a callback can create new 1085 * callbacks, so we iterate. 1086 */ 1087 1088 while (iPtr->assocData != (Tcl_HashTable *) NULL) { 1089 AssocData *dPtr; 1090 1091 hTablePtr = iPtr->assocData; 1092 iPtr->assocData = (Tcl_HashTable *) NULL; 1093 for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); 1094 hPtr != NULL; 1095 hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { 1096 dPtr = (AssocData *) Tcl_GetHashValue(hPtr); 1097 Tcl_DeleteHashEntry(hPtr); 1098 if (dPtr->proc != NULL) { 1099 (*dPtr->proc)(dPtr->clientData, interp); 1100 } 1101 ckfree((char *) dPtr); 1102 } 1103 Tcl_DeleteHashTable(hTablePtr); 1104 ckfree((char *) hTablePtr); 1105 } 1106 1107 /* 1108 * Finish deleting the global namespace. 1109 */ 1110 1111 Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); 1112 1113 /* 1114 * Free up the result *after* deleting variables, since variable 1115 * deletion could have transferred ownership of the result string 1116 * to Tcl. 1117 */ 1118 1119 Tcl_FreeResult(interp); 1120 interp->result = NULL; 1121 Tcl_DecrRefCount(iPtr->objResultPtr); 1122 iPtr->objResultPtr = NULL; 1123 if (iPtr->errorInfo != NULL) { 1124 ckfree(iPtr->errorInfo); 1125 iPtr->errorInfo = NULL; 1126 } 1127 if (iPtr->errorCode != NULL) { 1128 ckfree(iPtr->errorCode); 1129 iPtr->errorCode = NULL; 1130 } 1131 if (iPtr->appendResult != NULL) { 1132 ckfree(iPtr->appendResult); 1133 iPtr->appendResult = NULL; 1134 } 1135 TclFreePackageInfo(iPtr); 1136 while (iPtr->tracePtr != NULL) { 1137 Tcl_DeleteTrace((Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr); 1138 } 1139 if (iPtr->execEnvPtr != NULL) { 1140 TclDeleteExecEnv(iPtr->execEnvPtr); 1141 } 1142 Tcl_DecrRefCount(iPtr->emptyObjPtr); 1143 iPtr->emptyObjPtr = NULL; 1144 1145 resPtr = iPtr->resolverPtr; 1146 while (resPtr) { 1147 nextResPtr = resPtr->nextPtr; 1148 ckfree(resPtr->name); 1149 ckfree((char *) resPtr); 1150 resPtr = nextResPtr; 1151 } 1152 1153 /* 1154 * Free up literal objects created for scripts compiled by the 1155 * interpreter. 1156 */ 1157 1158 TclDeleteLiteralTable(interp, &(iPtr->literalTable)); 1159 1160#ifdef TCL_TIP280 1161 /* TIP #280 - Release the arrays for ByteCode/Proc extension, and contents. 1162 */ 1163 { 1164 Tcl_HashEntry *hPtr; 1165 Tcl_HashSearch hSearch; 1166 CmdFrame* cfPtr; 1167 ExtCmdLoc* eclPtr; 1168 int i; 1169 1170 for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &hSearch); 1171 hPtr != NULL; 1172 hPtr = Tcl_NextHashEntry(&hSearch)) { 1173 1174 cfPtr = (CmdFrame*) Tcl_GetHashValue (hPtr); 1175 1176 if (cfPtr->type == TCL_LOCATION_SOURCE) { 1177 Tcl_DecrRefCount (cfPtr->data.eval.path); 1178 } 1179 ckfree ((char*) cfPtr->line); 1180 ckfree ((char*) cfPtr); 1181 Tcl_DeleteHashEntry (hPtr); 1182 1183 } 1184 Tcl_DeleteHashTable (iPtr->linePBodyPtr); 1185 ckfree ((char*) iPtr->linePBodyPtr); 1186 iPtr->linePBodyPtr = NULL; 1187 1188 /* See also tclCompile.c, TclCleanupByteCode */ 1189 1190 for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &hSearch); 1191 hPtr != NULL; 1192 hPtr = Tcl_NextHashEntry(&hSearch)) { 1193 1194 eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hPtr); 1195 1196 if (eclPtr->type == TCL_LOCATION_SOURCE) { 1197 Tcl_DecrRefCount (eclPtr->path); 1198 } 1199 for (i=0; i< eclPtr->nuloc; i++) { 1200 ckfree ((char*) eclPtr->loc[i].line); 1201 } 1202 1203 if (eclPtr->loc != NULL) { 1204 ckfree ((char*) eclPtr->loc); 1205 } 1206 1207 Tcl_DeleteHashTable (&eclPtr->litInfo); 1208 1209 ckfree ((char*) eclPtr); 1210 Tcl_DeleteHashEntry (hPtr); 1211 } 1212 Tcl_DeleteHashTable (iPtr->lineBCPtr); 1213 ckfree((char*) iPtr->lineBCPtr); 1214 iPtr->lineBCPtr = NULL; 1215 1216 /* 1217 * Location stack for uplevel/eval/... scripts which were passed 1218 * through proc arguments. Actually we track all arguments as we 1219 * don't, cannot know which arguments will be used as scripts and 1220 * which won't. 1221 */ 1222 1223 if (iPtr->lineLAPtr->numEntries) { 1224 /* 1225 * When the interp goes away we have nothing on the stack, so 1226 * there are no arguments, so this table has to be empty. 1227 */ 1228 1229 Tcl_Panic ("Argument location tracking table not empty"); 1230 } 1231 1232 Tcl_DeleteHashTable (iPtr->lineLAPtr); 1233 ckfree((char*) iPtr->lineLAPtr); 1234 iPtr->lineLAPtr = NULL; 1235 1236 if (iPtr->lineLABCPtr->numEntries) { 1237 /* 1238 * When the interp goes away we have nothing on the stack, so 1239 * there are no arguments, so this table has to be empty. 1240 */ 1241 1242 Tcl_Panic ("Argument location tracking table not empty"); 1243 } 1244 1245 Tcl_DeleteHashTable (iPtr->lineLABCPtr); 1246 ckfree((char*) iPtr->lineLABCPtr); 1247 iPtr->lineLABCPtr = NULL; 1248 } 1249#endif 1250 ckfree((char *) iPtr); 1251} 1252 1253/* 1254 *--------------------------------------------------------------------------- 1255 * 1256 * Tcl_HideCommand -- 1257 * 1258 * Makes a command hidden so that it cannot be invoked from within 1259 * an interpreter, only from within an ancestor. 1260 * 1261 * Results: 1262 * A standard Tcl result; also leaves a message in the interp's result 1263 * if an error occurs. 1264 * 1265 * Side effects: 1266 * Removes a command from the command table and create an entry 1267 * into the hidden command table under the specified token name. 1268 * 1269 *--------------------------------------------------------------------------- 1270 */ 1271 1272int 1273Tcl_HideCommand(interp, cmdName, hiddenCmdToken) 1274 Tcl_Interp *interp; /* Interpreter in which to hide command. */ 1275 CONST char *cmdName; /* Name of command to hide. */ 1276 CONST char *hiddenCmdToken; /* Token name of the to-be-hidden command. */ 1277{ 1278 Interp *iPtr = (Interp *) interp; 1279 Tcl_Command cmd; 1280 Command *cmdPtr; 1281 Tcl_HashTable *hiddenCmdTablePtr; 1282 Tcl_HashEntry *hPtr; 1283 int new; 1284 1285 if (iPtr->flags & DELETED) { 1286 1287 /* 1288 * The interpreter is being deleted. Do not create any new 1289 * structures, because it is not safe to modify the interpreter. 1290 */ 1291 1292 return TCL_ERROR; 1293 } 1294 1295 /* 1296 * Disallow hiding of commands that are currently in a namespace or 1297 * renaming (as part of hiding) into a namespace. 1298 * 1299 * (because the current implementation with a single global table 1300 * and the needed uniqueness of names cause problems with namespaces) 1301 * 1302 * we don't need to check for "::" in cmdName because the real check is 1303 * on the nsPtr below. 1304 * 1305 * hiddenCmdToken is just a string which is not interpreted in any way. 1306 * It may contain :: but the string is not interpreted as a namespace 1307 * qualifier command name. Thus, hiding foo::bar to foo::bar and then 1308 * trying to expose or invoke ::foo::bar will NOT work; but if the 1309 * application always uses the same strings it will get consistent 1310 * behaviour. 1311 * 1312 * But as we currently limit ourselves to the global namespace only 1313 * for the source, in order to avoid potential confusion, 1314 * lets prevent "::" in the token too. --dl 1315 */ 1316 1317 if (strstr(hiddenCmdToken, "::") != NULL) { 1318 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1319 "cannot use namespace qualifiers in hidden command", 1320 " token (rename)", (char *) NULL); 1321 return TCL_ERROR; 1322 } 1323 1324 /* 1325 * Find the command to hide. An error is returned if cmdName can't 1326 * be found. Look up the command only from the global namespace. 1327 * Full path of the command must be given if using namespaces. 1328 */ 1329 1330 cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, 1331 /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); 1332 if (cmd == (Tcl_Command) NULL) { 1333 return TCL_ERROR; 1334 } 1335 cmdPtr = (Command *) cmd; 1336 1337 /* 1338 * Check that the command is really in global namespace 1339 */ 1340 1341 if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { 1342 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1343 "can only hide global namespace commands", 1344 " (use rename then hide)", (char *) NULL); 1345 return TCL_ERROR; 1346 } 1347 1348 /* 1349 * Initialize the hidden command table if necessary. 1350 */ 1351 1352 hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; 1353 if (hiddenCmdTablePtr == NULL) { 1354 hiddenCmdTablePtr = (Tcl_HashTable *) 1355 ckalloc((unsigned) sizeof(Tcl_HashTable)); 1356 Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); 1357 iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; 1358 } 1359 1360 /* 1361 * It is an error to move an exposed command to a hidden command with 1362 * hiddenCmdToken if a hidden command with the name hiddenCmdToken already 1363 * exists. 1364 */ 1365 1366 hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new); 1367 if (!new) { 1368 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1369 "hidden command named \"", hiddenCmdToken, "\" already exists", 1370 (char *) NULL); 1371 return TCL_ERROR; 1372 } 1373 1374 /* 1375 * Nb : This code is currently 'like' a rename to a specialy set apart 1376 * name table. Changes here and in TclRenameCommand must 1377 * be kept in synch untill the common parts are actually 1378 * factorized out. 1379 */ 1380 1381 /* 1382 * Remove the hash entry for the command from the interpreter command 1383 * table. This is like deleting the command, so bump its command epoch; 1384 * this invalidates any cached references that point to the command. 1385 */ 1386 1387 if (cmdPtr->hPtr != NULL) { 1388 Tcl_DeleteHashEntry(cmdPtr->hPtr); 1389 cmdPtr->hPtr = (Tcl_HashEntry *) NULL; 1390 cmdPtr->cmdEpoch++; 1391 } 1392 1393 /* 1394 * Now link the hash table entry with the command structure. 1395 * We ensured above that the nsPtr was right. 1396 */ 1397 1398 cmdPtr->hPtr = hPtr; 1399 Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); 1400 1401 /* 1402 * If the command being hidden has a compile procedure, increment the 1403 * interpreter's compileEpoch to invalidate its compiled code. This 1404 * makes sure that we don't later try to execute old code compiled with 1405 * command-specific (i.e., inline) bytecodes for the now-hidden 1406 * command. This field is checked in Tcl_EvalObj and ObjInterpProc, 1407 * and code whose compilation epoch doesn't match is recompiled. 1408 */ 1409 1410 if (cmdPtr->compileProc != NULL) { 1411 iPtr->compileEpoch++; 1412 } 1413 return TCL_OK; 1414} 1415 1416/* 1417 *---------------------------------------------------------------------- 1418 * 1419 * Tcl_ExposeCommand -- 1420 * 1421 * Makes a previously hidden command callable from inside the 1422 * interpreter instead of only by its ancestors. 1423 * 1424 * Results: 1425 * A standard Tcl result. If an error occurs, a message is left 1426 * in the interp's result. 1427 * 1428 * Side effects: 1429 * Moves commands from one hash table to another. 1430 * 1431 *---------------------------------------------------------------------- 1432 */ 1433 1434int 1435Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) 1436 Tcl_Interp *interp; /* Interpreter in which to make command 1437 * callable. */ 1438 CONST char *hiddenCmdToken; /* Name of hidden command. */ 1439 CONST char *cmdName; /* Name of to-be-exposed command. */ 1440{ 1441 Interp *iPtr = (Interp *) interp; 1442 Command *cmdPtr; 1443 Namespace *nsPtr; 1444 Tcl_HashEntry *hPtr; 1445 Tcl_HashTable *hiddenCmdTablePtr; 1446 int new; 1447 1448 if (iPtr->flags & DELETED) { 1449 /* 1450 * The interpreter is being deleted. Do not create any new 1451 * structures, because it is not safe to modify the interpreter. 1452 */ 1453 1454 return TCL_ERROR; 1455 } 1456 1457 /* 1458 * Check that we have a regular name for the command 1459 * (that the user is not trying to do an expose and a rename 1460 * (to another namespace) at the same time) 1461 */ 1462 1463 if (strstr(cmdName, "::") != NULL) { 1464 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1465 "can not expose to a namespace ", 1466 "(use expose to toplevel, then rename)", 1467 (char *) NULL); 1468 return TCL_ERROR; 1469 } 1470 1471 /* 1472 * Get the command from the hidden command table: 1473 */ 1474 1475 hPtr = NULL; 1476 hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; 1477 if (hiddenCmdTablePtr != NULL) { 1478 hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); 1479 } 1480 if (hPtr == (Tcl_HashEntry *) NULL) { 1481 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1482 "unknown hidden command \"", hiddenCmdToken, 1483 "\"", (char *) NULL); 1484 return TCL_ERROR; 1485 } 1486 cmdPtr = (Command *) Tcl_GetHashValue(hPtr); 1487 1488 1489 /* 1490 * Check that we have a true global namespace 1491 * command (enforced by Tcl_HideCommand() but let's double 1492 * check. (If it was not, we would not really know how to 1493 * handle it). 1494 */ 1495 if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { 1496 /* 1497 * This case is theoritically impossible, 1498 * we might rather panic() than 'nicely' erroring out ? 1499 */ 1500 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1501 "trying to expose a non global command name space command", 1502 (char *) NULL); 1503 return TCL_ERROR; 1504 } 1505 1506 /* This is the global table */ 1507 nsPtr = cmdPtr->nsPtr; 1508 1509 /* 1510 * It is an error to overwrite an existing exposed command as a result 1511 * of exposing a previously hidden command. 1512 */ 1513 1514 hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new); 1515 if (!new) { 1516 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1517 "exposed command \"", cmdName, 1518 "\" already exists", (char *) NULL); 1519 return TCL_ERROR; 1520 } 1521 1522 /* 1523 * Remove the hash entry for the command from the interpreter hidden 1524 * command table. 1525 */ 1526 1527 if (cmdPtr->hPtr != NULL) { 1528 Tcl_DeleteHashEntry(cmdPtr->hPtr); 1529 cmdPtr->hPtr = NULL; 1530 } 1531 1532 /* 1533 * Now link the hash table entry with the command structure. 1534 * This is like creating a new command, so deal with any shadowing 1535 * of commands in the global namespace. 1536 */ 1537 1538 cmdPtr->hPtr = hPtr; 1539 1540 Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); 1541 1542 /* 1543 * Not needed as we are only in the global namespace 1544 * (but would be needed again if we supported namespace command hiding) 1545 * 1546 * TclResetShadowedCmdRefs(interp, cmdPtr); 1547 */ 1548 1549 1550 /* 1551 * If the command being exposed has a compile procedure, increment 1552 * interpreter's compileEpoch to invalidate its compiled code. This 1553 * makes sure that we don't later try to execute old code compiled 1554 * assuming the command is hidden. This field is checked in Tcl_EvalObj 1555 * and ObjInterpProc, and code whose compilation epoch doesn't match is 1556 * recompiled. 1557 */ 1558 1559 if (cmdPtr->compileProc != NULL) { 1560 iPtr->compileEpoch++; 1561 } 1562 return TCL_OK; 1563} 1564 1565/* 1566 *---------------------------------------------------------------------- 1567 * 1568 * Tcl_CreateCommand -- 1569 * 1570 * Define a new command in a command table. 1571 * 1572 * Results: 1573 * The return value is a token for the command, which can 1574 * be used in future calls to Tcl_GetCommandName. 1575 * 1576 * Side effects: 1577 * If a command named cmdName already exists for interp, it is deleted. 1578 * In the future, when cmdName is seen as the name of a command by 1579 * Tcl_Eval, proc will be called. To support the bytecode interpreter, 1580 * the command is created with a wrapper Tcl_ObjCmdProc 1581 * (TclInvokeStringCommand) that eventially calls proc. When the 1582 * command is deleted from the table, deleteProc will be called. 1583 * See the manual entry for details on the calling sequence. 1584 * 1585 *---------------------------------------------------------------------- 1586 */ 1587 1588Tcl_Command 1589Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) 1590 Tcl_Interp *interp; /* Token for command interpreter returned by 1591 * a previous call to Tcl_CreateInterp. */ 1592 CONST char *cmdName; /* Name of command. If it contains namespace 1593 * qualifiers, the new command is put in the 1594 * specified namespace; otherwise it is put 1595 * in the global namespace. */ 1596 Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */ 1597 ClientData clientData; /* Arbitrary value passed to string proc. */ 1598 Tcl_CmdDeleteProc *deleteProc; 1599 /* If not NULL, gives a procedure to call 1600 * when this command is deleted. */ 1601{ 1602 Interp *iPtr = (Interp *) interp; 1603 ImportRef *oldRefPtr = NULL; 1604 Namespace *nsPtr, *dummy1, *dummy2; 1605 Command *cmdPtr, *refCmdPtr; 1606 Tcl_HashEntry *hPtr; 1607 CONST char *tail; 1608 int new; 1609 ImportedCmdData *dataPtr; 1610 1611 if (iPtr->flags & DELETED) { 1612 /* 1613 * The interpreter is being deleted. Don't create any new 1614 * commands; it's not safe to muck with the interpreter anymore. 1615 */ 1616 1617 return (Tcl_Command) NULL; 1618 } 1619 1620 /* 1621 * Determine where the command should reside. If its name contains 1622 * namespace qualifiers, we put it in the specified namespace; 1623 * otherwise, we always put it in the global namespace. 1624 */ 1625 1626 if (strstr(cmdName, "::") != NULL) { 1627 TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, 1628 CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); 1629 if ((nsPtr == NULL) || (tail == NULL)) { 1630 return (Tcl_Command) NULL; 1631 } 1632 } else { 1633 nsPtr = iPtr->globalNsPtr; 1634 tail = cmdName; 1635 } 1636 1637 hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); 1638 if (!new) { 1639 /* 1640 * Command already exists. Delete the old one. 1641 * Be careful to preserve any existing import links so we can 1642 * restore them down below. That way, you can redefine a 1643 * command and its import status will remain intact. 1644 */ 1645 1646 cmdPtr = (Command *) Tcl_GetHashValue(hPtr); 1647 oldRefPtr = cmdPtr->importRefPtr; 1648 cmdPtr->importRefPtr = NULL; 1649 1650 Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); 1651 hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); 1652 if (!new) { 1653 /* 1654 * If the deletion callback recreated the command, just throw 1655 * away the new command (if we try to delete it again, we 1656 * could get stuck in an infinite loop). 1657 */ 1658 1659 ckfree((char*) Tcl_GetHashValue(hPtr)); 1660 } 1661 } 1662 cmdPtr = (Command *) ckalloc(sizeof(Command)); 1663 Tcl_SetHashValue(hPtr, cmdPtr); 1664 cmdPtr->hPtr = hPtr; 1665 cmdPtr->nsPtr = nsPtr; 1666 cmdPtr->refCount = 1; 1667 cmdPtr->cmdEpoch = 0; 1668 cmdPtr->compileProc = (CompileProc *) NULL; 1669 cmdPtr->objProc = TclInvokeStringCommand; 1670 cmdPtr->objClientData = (ClientData) cmdPtr; 1671 cmdPtr->proc = proc; 1672 cmdPtr->clientData = clientData; 1673 cmdPtr->deleteProc = deleteProc; 1674 cmdPtr->deleteData = clientData; 1675 cmdPtr->flags = 0; 1676 cmdPtr->importRefPtr = NULL; 1677 cmdPtr->tracePtr = NULL; 1678 1679 /* 1680 * Plug in any existing import references found above. Be sure 1681 * to update all of these references to point to the new command. 1682 */ 1683 1684 if (oldRefPtr != NULL) { 1685 cmdPtr->importRefPtr = oldRefPtr; 1686 while (oldRefPtr != NULL) { 1687 refCmdPtr = oldRefPtr->importedCmdPtr; 1688 dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; 1689 dataPtr->realCmdPtr = cmdPtr; 1690 oldRefPtr = oldRefPtr->nextPtr; 1691 } 1692 } 1693 1694 /* 1695 * We just created a command, so in its namespace and all of its parent 1696 * namespaces, it may shadow global commands with the same name. If any 1697 * shadowed commands are found, invalidate all cached command references 1698 * in the affected namespaces. 1699 */ 1700 1701 TclResetShadowedCmdRefs(interp, cmdPtr); 1702 return (Tcl_Command) cmdPtr; 1703} 1704 1705/* 1706 *---------------------------------------------------------------------- 1707 * 1708 * Tcl_CreateObjCommand -- 1709 * 1710 * Define a new object-based command in a command table. 1711 * 1712 * Results: 1713 * The return value is a token for the command, which can 1714 * be used in future calls to Tcl_GetCommandName. 1715 * 1716 * Side effects: 1717 * If no command named "cmdName" already exists for interp, one is 1718 * created. Otherwise, if a command does exist, then if the 1719 * object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume 1720 * Tcl_CreateCommand was called previously for the same command and 1721 * just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we 1722 * delete the old command. 1723 * 1724 * In the future, during bytecode evaluation when "cmdName" is seen as 1725 * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based 1726 * Tcl_ObjCmdProc proc will be called. When the command is deleted from 1727 * the table, deleteProc will be called. See the manual entry for 1728 * details on the calling sequence. 1729 * 1730 *---------------------------------------------------------------------- 1731 */ 1732 1733Tcl_Command 1734Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) 1735 Tcl_Interp *interp; /* Token for command interpreter (returned 1736 * by previous call to Tcl_CreateInterp). */ 1737 CONST char *cmdName; /* Name of command. If it contains namespace 1738 * qualifiers, the new command is put in the 1739 * specified namespace; otherwise it is put 1740 * in the global namespace. */ 1741 Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with 1742 * name. */ 1743 ClientData clientData; /* Arbitrary value to pass to object 1744 * procedure. */ 1745 Tcl_CmdDeleteProc *deleteProc; 1746 /* If not NULL, gives a procedure to call 1747 * when this command is deleted. */ 1748{ 1749 Interp *iPtr = (Interp *) interp; 1750 ImportRef *oldRefPtr = NULL; 1751 Namespace *nsPtr, *dummy1, *dummy2; 1752 Command *cmdPtr, *refCmdPtr; 1753 Tcl_HashEntry *hPtr; 1754 CONST char *tail; 1755 int new; 1756 ImportedCmdData *dataPtr; 1757 1758 if (iPtr->flags & DELETED) { 1759 /* 1760 * The interpreter is being deleted. Don't create any new 1761 * commands; it's not safe to muck with the interpreter anymore. 1762 */ 1763 1764 return (Tcl_Command) NULL; 1765 } 1766 1767 /* 1768 * Determine where the command should reside. If its name contains 1769 * namespace qualifiers, we put it in the specified namespace; 1770 * otherwise, we always put it in the global namespace. 1771 */ 1772 1773 if (strstr(cmdName, "::") != NULL) { 1774 TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL, 1775 CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); 1776 if ((nsPtr == NULL) || (tail == NULL)) { 1777 return (Tcl_Command) NULL; 1778 } 1779 } else { 1780 nsPtr = iPtr->globalNsPtr; 1781 tail = cmdName; 1782 } 1783 1784 hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); 1785 if (!new) { 1786 cmdPtr = (Command *) Tcl_GetHashValue(hPtr); 1787 1788 /* 1789 * Command already exists. If its object-based Tcl_ObjCmdProc is 1790 * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the 1791 * argument "proc". Otherwise, we delete the old command. 1792 */ 1793 1794 if (cmdPtr->objProc == TclInvokeStringCommand) { 1795 cmdPtr->objProc = proc; 1796 cmdPtr->objClientData = clientData; 1797 cmdPtr->deleteProc = deleteProc; 1798 cmdPtr->deleteData = clientData; 1799 return (Tcl_Command) cmdPtr; 1800 } 1801 1802 /* 1803 * Otherwise, we delete the old command. Be careful to preserve 1804 * any existing import links so we can restore them down below. 1805 * That way, you can redefine a command and its import status 1806 * will remain intact. 1807 */ 1808 1809 oldRefPtr = cmdPtr->importRefPtr; 1810 cmdPtr->importRefPtr = NULL; 1811 1812 Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); 1813 hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); 1814 if (!new) { 1815 /* 1816 * If the deletion callback recreated the command, just throw 1817 * away the new command (if we try to delete it again, we 1818 * could get stuck in an infinite loop). 1819 */ 1820 1821 ckfree((char *) Tcl_GetHashValue(hPtr)); 1822 } 1823 } 1824 cmdPtr = (Command *) ckalloc(sizeof(Command)); 1825 Tcl_SetHashValue(hPtr, cmdPtr); 1826 cmdPtr->hPtr = hPtr; 1827 cmdPtr->nsPtr = nsPtr; 1828 cmdPtr->refCount = 1; 1829 cmdPtr->cmdEpoch = 0; 1830 cmdPtr->compileProc = (CompileProc *) NULL; 1831 cmdPtr->objProc = proc; 1832 cmdPtr->objClientData = clientData; 1833 cmdPtr->proc = TclInvokeObjectCommand; 1834 cmdPtr->clientData = (ClientData) cmdPtr; 1835 cmdPtr->deleteProc = deleteProc; 1836 cmdPtr->deleteData = clientData; 1837 cmdPtr->flags = 0; 1838 cmdPtr->importRefPtr = NULL; 1839 cmdPtr->tracePtr = NULL; 1840 1841 /* 1842 * Plug in any existing import references found above. Be sure 1843 * to update all of these references to point to the new command. 1844 */ 1845 1846 if (oldRefPtr != NULL) { 1847 cmdPtr->importRefPtr = oldRefPtr; 1848 while (oldRefPtr != NULL) { 1849 refCmdPtr = oldRefPtr->importedCmdPtr; 1850 dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; 1851 dataPtr->realCmdPtr = cmdPtr; 1852 oldRefPtr = oldRefPtr->nextPtr; 1853 } 1854 } 1855 1856 /* 1857 * We just created a command, so in its namespace and all of its parent 1858 * namespaces, it may shadow global commands with the same name. If any 1859 * shadowed commands are found, invalidate all cached command references 1860 * in the affected namespaces. 1861 */ 1862 1863 TclResetShadowedCmdRefs(interp, cmdPtr); 1864 return (Tcl_Command) cmdPtr; 1865} 1866 1867/* 1868 *---------------------------------------------------------------------- 1869 * 1870 * TclInvokeStringCommand -- 1871 * 1872 * "Wrapper" Tcl_ObjCmdProc used to call an existing string-based 1873 * Tcl_CmdProc if no object-based procedure exists for a command. A 1874 * pointer to this procedure is stored as the Tcl_ObjCmdProc in a 1875 * Command structure. It simply turns around and calls the string 1876 * Tcl_CmdProc in the Command structure. 1877 * 1878 * Results: 1879 * A standard Tcl object result value. 1880 * 1881 * Side effects: 1882 * Besides those side effects of the called Tcl_CmdProc, 1883 * TclInvokeStringCommand allocates and frees storage. 1884 * 1885 *---------------------------------------------------------------------- 1886 */ 1887 1888int 1889TclInvokeStringCommand(clientData, interp, objc, objv) 1890 ClientData clientData; /* Points to command's Command structure. */ 1891 Tcl_Interp *interp; /* Current interpreter. */ 1892 register int objc; /* Number of arguments. */ 1893 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1894{ 1895 register Command *cmdPtr = (Command *) clientData; 1896 register int i; 1897 int result; 1898 1899 /* 1900 * This procedure generates an argv array for the string arguments. It 1901 * starts out with stack-allocated space but uses dynamically-allocated 1902 * storage if needed. 1903 */ 1904 1905#define NUM_ARGS 20 1906 CONST char *(argStorage[NUM_ARGS]); 1907 CONST char **argv = argStorage; 1908 1909 /* 1910 * Create the string argument array "argv". Make sure argv is large 1911 * enough to hold the objc arguments plus 1 extra for the zero 1912 * end-of-argv word. 1913 */ 1914 1915 if ((objc + 1) > NUM_ARGS) { 1916 argv = (CONST char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); 1917 } 1918 1919 for (i = 0; i < objc; i++) { 1920 argv[i] = Tcl_GetString(objv[i]); 1921 } 1922 argv[objc] = 0; 1923 1924 /* 1925 * Invoke the command's string-based Tcl_CmdProc. 1926 */ 1927 1928 result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv); 1929 1930 /* 1931 * Free the argv array if malloc'ed storage was used. 1932 */ 1933 1934 if (argv != argStorage) { 1935 ckfree((char *) argv); 1936 } 1937 return result; 1938#undef NUM_ARGS 1939} 1940 1941/* 1942 *---------------------------------------------------------------------- 1943 * 1944 * TclInvokeObjectCommand -- 1945 * 1946 * "Wrapper" Tcl_CmdProc used to call an existing object-based 1947 * Tcl_ObjCmdProc if no string-based procedure exists for a command. 1948 * A pointer to this procedure is stored as the Tcl_CmdProc in a 1949 * Command structure. It simply turns around and calls the object 1950 * Tcl_ObjCmdProc in the Command structure. 1951 * 1952 * Results: 1953 * A standard Tcl string result value. 1954 * 1955 * Side effects: 1956 * Besides those side effects of the called Tcl_CmdProc, 1957 * TclInvokeStringCommand allocates and frees storage. 1958 * 1959 *---------------------------------------------------------------------- 1960 */ 1961 1962int 1963TclInvokeObjectCommand(clientData, interp, argc, argv) 1964 ClientData clientData; /* Points to command's Command structure. */ 1965 Tcl_Interp *interp; /* Current interpreter. */ 1966 int argc; /* Number of arguments. */ 1967 register CONST char **argv; /* Argument strings. */ 1968{ 1969 Command *cmdPtr = (Command *) clientData; 1970 register Tcl_Obj *objPtr; 1971 register int i; 1972 int length, result; 1973 1974 /* 1975 * This procedure generates an objv array for object arguments that hold 1976 * the argv strings. It starts out with stack-allocated space but uses 1977 * dynamically-allocated storage if needed. 1978 */ 1979 1980#define NUM_ARGS 20 1981 Tcl_Obj *(argStorage[NUM_ARGS]); 1982 register Tcl_Obj **objv = argStorage; 1983 1984 /* 1985 * Create the object argument array "objv". Make sure objv is large 1986 * enough to hold the objc arguments plus 1 extra for the zero 1987 * end-of-objv word. 1988 */ 1989 1990 if (argc > NUM_ARGS) { 1991 objv = (Tcl_Obj **) 1992 ckalloc((unsigned)(argc * sizeof(Tcl_Obj *))); 1993 } 1994 1995 for (i = 0; i < argc; i++) { 1996 length = strlen(argv[i]); 1997 TclNewObj(objPtr); 1998 TclInitStringRep(objPtr, argv[i], length); 1999 Tcl_IncrRefCount(objPtr); 2000 objv[i] = objPtr; 2001 } 2002 2003 /* 2004 * Invoke the command's object-based Tcl_ObjCmdProc. 2005 */ 2006 2007 result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv); 2008 2009 /* 2010 * Move the interpreter's object result to the string result, 2011 * then reset the object result. 2012 */ 2013 2014 Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), 2015 TCL_VOLATILE); 2016 2017 /* 2018 * Decrement the ref counts for the argument objects created above, 2019 * then free the objv array if malloc'ed storage was used. 2020 */ 2021 2022 for (i = 0; i < argc; i++) { 2023 objPtr = objv[i]; 2024 Tcl_DecrRefCount(objPtr); 2025 } 2026 if (objv != argStorage) { 2027 ckfree((char *) objv); 2028 } 2029 return result; 2030#undef NUM_ARGS 2031} 2032 2033/* 2034 *---------------------------------------------------------------------- 2035 * 2036 * TclRenameCommand -- 2037 * 2038 * Called to give an existing Tcl command a different name. Both the 2039 * old command name and the new command name can have "::" namespace 2040 * qualifiers. If the new command has a different namespace context, 2041 * the command will be moved to that namespace and will execute in 2042 * the context of that new namespace. 2043 * 2044 * If the new command name is NULL or the null string, the command is 2045 * deleted. 2046 * 2047 * Results: 2048 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 2049 * 2050 * Side effects: 2051 * If anything goes wrong, an error message is returned in the 2052 * interpreter's result object. 2053 * 2054 *---------------------------------------------------------------------- 2055 */ 2056 2057int 2058TclRenameCommand(interp, oldName, newName) 2059 Tcl_Interp *interp; /* Current interpreter. */ 2060 char *oldName; /* Existing command name. */ 2061 char *newName; /* New command name. */ 2062{ 2063 Interp *iPtr = (Interp *) interp; 2064 CONST char *newTail; 2065 Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2; 2066 Tcl_Command cmd; 2067 Command *cmdPtr; 2068 Tcl_HashEntry *hPtr, *oldHPtr; 2069 int new, result; 2070 Tcl_Obj* oldFullName; 2071 Tcl_DString newFullName; 2072 2073 /* 2074 * Find the existing command. An error is returned if cmdName can't 2075 * be found. 2076 */ 2077 2078 cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL, 2079 /*flags*/ 0); 2080 cmdPtr = (Command *) cmd; 2081 if (cmdPtr == NULL) { 2082 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ", 2083 ((newName == NULL)||(*newName == '\0'))? "delete":"rename", 2084 " \"", oldName, "\": command doesn't exist", (char *) NULL); 2085 return TCL_ERROR; 2086 } 2087 cmdNsPtr = cmdPtr->nsPtr; 2088 oldFullName = Tcl_NewObj(); 2089 Tcl_IncrRefCount( oldFullName ); 2090 Tcl_GetCommandFullName( interp, cmd, oldFullName ); 2091 2092 /* 2093 * If the new command name is NULL or empty, delete the command. Do this 2094 * with Tcl_DeleteCommandFromToken, since we already have the command. 2095 */ 2096 2097 if ((newName == NULL) || (*newName == '\0')) { 2098 Tcl_DeleteCommandFromToken(interp, cmd); 2099 result = TCL_OK; 2100 goto done; 2101 } 2102 2103 /* 2104 * Make sure that the destination command does not already exist. 2105 * The rename operation is like creating a command, so we should 2106 * automatically create the containing namespaces just like 2107 * Tcl_CreateCommand would. 2108 */ 2109 2110 TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL, 2111 CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); 2112 2113 if ((newNsPtr == NULL) || (newTail == NULL)) { 2114 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 2115 "can't rename to \"", newName, "\": bad command name", 2116 (char *) NULL); 2117 result = TCL_ERROR; 2118 goto done; 2119 } 2120 if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) { 2121 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 2122 "can't rename to \"", newName, 2123 "\": command already exists", (char *) NULL); 2124 result = TCL_ERROR; 2125 goto done; 2126 } 2127 2128 /* 2129 * Warning: any changes done in the code here are likely 2130 * to be needed in Tcl_HideCommand() code too. 2131 * (until the common parts are extracted out) --dl 2132 */ 2133 2134 /* 2135 * Put the command in the new namespace so we can check for an alias 2136 * loop. Since we are adding a new command to a namespace, we must 2137 * handle any shadowing of the global commands that this might create. 2138 */ 2139 2140 oldHPtr = cmdPtr->hPtr; 2141 hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new); 2142 Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); 2143 cmdPtr->hPtr = hPtr; 2144 cmdPtr->nsPtr = newNsPtr; 2145 TclResetShadowedCmdRefs(interp, cmdPtr); 2146 2147 /* 2148 * Now check for an alias loop. If we detect one, put everything back 2149 * the way it was and report the error. 2150 */ 2151 2152 result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr); 2153 if (result != TCL_OK) { 2154 Tcl_DeleteHashEntry(cmdPtr->hPtr); 2155 cmdPtr->hPtr = oldHPtr; 2156 cmdPtr->nsPtr = cmdNsPtr; 2157 goto done; 2158 } 2159 2160 /* 2161 * Script for rename traces can delete the command "oldName". 2162 * Therefore increment the reference count for cmdPtr so that 2163 * it's Command structure is freed only towards the end of this 2164 * function by calling TclCleanupCommand. 2165 * 2166 * The trace procedure needs to get a fully qualified name for 2167 * old and new commands [Tcl bug #651271], or else there's no way 2168 * for the trace procedure to get the namespace from which the old 2169 * command is being renamed! 2170 */ 2171 2172 Tcl_DStringInit( &newFullName ); 2173 Tcl_DStringAppend( &newFullName, newNsPtr->fullName, -1 ); 2174 if ( newNsPtr != iPtr->globalNsPtr ) { 2175 Tcl_DStringAppend( &newFullName, "::", 2 ); 2176 } 2177 Tcl_DStringAppend( &newFullName, newTail, -1 ); 2178 cmdPtr->refCount++; 2179 CallCommandTraces( iPtr, cmdPtr, 2180 Tcl_GetString( oldFullName ), 2181 Tcl_DStringValue( &newFullName ), 2182 TCL_TRACE_RENAME); 2183 Tcl_DStringFree( &newFullName ); 2184 2185 /* 2186 * The new command name is okay, so remove the command from its 2187 * current namespace. This is like deleting the command, so bump 2188 * the cmdEpoch to invalidate any cached references to the command. 2189 */ 2190 2191 Tcl_DeleteHashEntry(oldHPtr); 2192 cmdPtr->cmdEpoch++; 2193 2194 /* 2195 * If the command being renamed has a compile procedure, increment the 2196 * interpreter's compileEpoch to invalidate its compiled code. This 2197 * makes sure that we don't later try to execute old code compiled for 2198 * the now-renamed command. 2199 */ 2200 2201 if (cmdPtr->compileProc != NULL) { 2202 iPtr->compileEpoch++; 2203 } 2204 2205 /* 2206 * Now free the Command structure, if the "oldName" command has 2207 * been deleted by invocation of rename traces. 2208 */ 2209 TclCleanupCommand(cmdPtr); 2210 result = TCL_OK; 2211 2212 done: 2213 TclDecrRefCount( oldFullName ); 2214 return result; 2215} 2216 2217/* 2218 *---------------------------------------------------------------------- 2219 * 2220 * Tcl_SetCommandInfo -- 2221 * 2222 * Modifies various information about a Tcl command. Note that 2223 * this procedure will not change a command's namespace; use 2224 * Tcl_RenameCommand to do that. Also, the isNativeObjectProc 2225 * member of *infoPtr is ignored. 2226 * 2227 * Results: 2228 * If cmdName exists in interp, then the information at *infoPtr 2229 * is stored with the command in place of the current information 2230 * and 1 is returned. If the command doesn't exist then 0 is 2231 * returned. 2232 * 2233 * Side effects: 2234 * None. 2235 * 2236 *---------------------------------------------------------------------- 2237 */ 2238 2239int 2240Tcl_SetCommandInfo(interp, cmdName, infoPtr) 2241 Tcl_Interp *interp; /* Interpreter in which to look 2242 * for command. */ 2243 CONST char *cmdName; /* Name of desired command. */ 2244 CONST Tcl_CmdInfo *infoPtr; /* Where to find information 2245 * to store in the command. */ 2246{ 2247 Tcl_Command cmd; 2248 2249 cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, 2250 /*flags*/ 0); 2251 2252 return Tcl_SetCommandInfoFromToken( cmd, infoPtr ); 2253 2254} 2255 2256/* 2257 *---------------------------------------------------------------------- 2258 * 2259 * Tcl_SetCommandInfoFromToken -- 2260 * 2261 * Modifies various information about a Tcl command. Note that 2262 * this procedure will not change a command's namespace; use 2263 * Tcl_RenameCommand to do that. Also, the isNativeObjectProc 2264 * member of *infoPtr is ignored. 2265 * 2266 * Results: 2267 * If cmdName exists in interp, then the information at *infoPtr 2268 * is stored with the command in place of the current information 2269 * and 1 is returned. If the command doesn't exist then 0 is 2270 * returned. 2271 * 2272 * Side effects: 2273 * None. 2274 * 2275 *---------------------------------------------------------------------- 2276 */ 2277 2278int 2279Tcl_SetCommandInfoFromToken( cmd, infoPtr ) 2280 Tcl_Command cmd; 2281 CONST Tcl_CmdInfo* infoPtr; 2282{ 2283 Command* cmdPtr; /* Internal representation of the command */ 2284 2285 if (cmd == (Tcl_Command) NULL) { 2286 return 0; 2287 } 2288 2289 /* 2290 * The isNativeObjectProc and nsPtr members of *infoPtr are ignored. 2291 */ 2292 2293 cmdPtr = (Command *) cmd; 2294 cmdPtr->proc = infoPtr->proc; 2295 cmdPtr->clientData = infoPtr->clientData; 2296 if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) { 2297 cmdPtr->objProc = TclInvokeStringCommand; 2298 cmdPtr->objClientData = (ClientData) cmdPtr; 2299 } else { 2300 cmdPtr->objProc = infoPtr->objProc; 2301 cmdPtr->objClientData = infoPtr->objClientData; 2302 } 2303 cmdPtr->deleteProc = infoPtr->deleteProc; 2304 cmdPtr->deleteData = infoPtr->deleteData; 2305 return 1; 2306} 2307 2308/* 2309 *---------------------------------------------------------------------- 2310 * 2311 * Tcl_GetCommandInfo -- 2312 * 2313 * Returns various information about a Tcl command. 2314 * 2315 * Results: 2316 * If cmdName exists in interp, then *infoPtr is modified to 2317 * hold information about cmdName and 1 is returned. If the 2318 * command doesn't exist then 0 is returned and *infoPtr isn't 2319 * modified. 2320 * 2321 * Side effects: 2322 * None. 2323 * 2324 *---------------------------------------------------------------------- 2325 */ 2326 2327int 2328Tcl_GetCommandInfo(interp, cmdName, infoPtr) 2329 Tcl_Interp *interp; /* Interpreter in which to look 2330 * for command. */ 2331 CONST char *cmdName; /* Name of desired command. */ 2332 Tcl_CmdInfo *infoPtr; /* Where to store information about 2333 * command. */ 2334{ 2335 Tcl_Command cmd; 2336 2337 cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, 2338 /*flags*/ 0); 2339 2340 return Tcl_GetCommandInfoFromToken( cmd, infoPtr ); 2341 2342} 2343 2344/* 2345 *---------------------------------------------------------------------- 2346 * 2347 * Tcl_GetCommandInfoFromToken -- 2348 * 2349 * Returns various information about a Tcl command. 2350 * 2351 * Results: 2352 * Copies information from the command identified by 'cmd' into 2353 * a caller-supplied structure and returns 1. If the 'cmd' is 2354 * NULL, leaves the structure untouched and returns 0. 2355 * 2356 * Side effects: 2357 * None. 2358 * 2359 *---------------------------------------------------------------------- 2360 */ 2361 2362int 2363Tcl_GetCommandInfoFromToken( cmd, infoPtr ) 2364 Tcl_Command cmd; 2365 Tcl_CmdInfo* infoPtr; 2366{ 2367 2368 Command* cmdPtr; /* Internal representation of the command */ 2369 2370 if ( cmd == (Tcl_Command) NULL ) { 2371 return 0; 2372 } 2373 2374 /* 2375 * Set isNativeObjectProc 1 if objProc was registered by a call to 2376 * Tcl_CreateObjCommand. Otherwise set it to 0. 2377 */ 2378 2379 cmdPtr = (Command *) cmd; 2380 infoPtr->isNativeObjectProc = 2381 (cmdPtr->objProc != TclInvokeStringCommand); 2382 infoPtr->objProc = cmdPtr->objProc; 2383 infoPtr->objClientData = cmdPtr->objClientData; 2384 infoPtr->proc = cmdPtr->proc; 2385 infoPtr->clientData = cmdPtr->clientData; 2386 infoPtr->deleteProc = cmdPtr->deleteProc; 2387 infoPtr->deleteData = cmdPtr->deleteData; 2388 infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; 2389 2390 return 1; 2391 2392} 2393 2394/* 2395 *---------------------------------------------------------------------- 2396 * 2397 * Tcl_GetCommandName -- 2398 * 2399 * Given a token returned by Tcl_CreateCommand, this procedure 2400 * returns the current name of the command (which may have changed 2401 * due to renaming). 2402 * 2403 * Results: 2404 * The return value is the name of the given command. 2405 * 2406 * Side effects: 2407 * None. 2408 * 2409 *---------------------------------------------------------------------- 2410 */ 2411 2412CONST char * 2413Tcl_GetCommandName(interp, command) 2414 Tcl_Interp *interp; /* Interpreter containing the command. */ 2415 Tcl_Command command; /* Token for command returned by a previous 2416 * call to Tcl_CreateCommand. The command 2417 * must not have been deleted. */ 2418{ 2419 Command *cmdPtr = (Command *) command; 2420 2421 if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) { 2422 2423 /* 2424 * This should only happen if command was "created" after the 2425 * interpreter began to be deleted, so there isn't really any 2426 * command. Just return an empty string. 2427 */ 2428 2429 return ""; 2430 } 2431 return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); 2432} 2433 2434/* 2435 *---------------------------------------------------------------------- 2436 * 2437 * Tcl_GetCommandFullName -- 2438 * 2439 * Given a token returned by, e.g., Tcl_CreateCommand or 2440 * Tcl_FindCommand, this procedure appends to an object the command's 2441 * full name, qualified by a sequence of parent namespace names. The 2442 * command's fully-qualified name may have changed due to renaming. 2443 * 2444 * Results: 2445 * None. 2446 * 2447 * Side effects: 2448 * The command's fully-qualified name is appended to the string 2449 * representation of objPtr. 2450 * 2451 *---------------------------------------------------------------------- 2452 */ 2453 2454void 2455Tcl_GetCommandFullName(interp, command, objPtr) 2456 Tcl_Interp *interp; /* Interpreter containing the command. */ 2457 Tcl_Command command; /* Token for command returned by a previous 2458 * call to Tcl_CreateCommand. The command 2459 * must not have been deleted. */ 2460 Tcl_Obj *objPtr; /* Points to the object onto which the 2461 * command's full name is appended. */ 2462 2463{ 2464 Interp *iPtr = (Interp *) interp; 2465 register Command *cmdPtr = (Command *) command; 2466 char *name; 2467 2468 /* 2469 * Add the full name of the containing namespace, followed by the "::" 2470 * separator, and the command name. 2471 */ 2472 2473 if (cmdPtr != NULL) { 2474 if (cmdPtr->nsPtr != NULL) { 2475 Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1); 2476 if (cmdPtr->nsPtr != iPtr->globalNsPtr) { 2477 Tcl_AppendToObj(objPtr, "::", 2); 2478 } 2479 } 2480 if (cmdPtr->hPtr != NULL) { 2481 name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); 2482 Tcl_AppendToObj(objPtr, name, -1); 2483 } 2484 } 2485} 2486 2487/* 2488 *---------------------------------------------------------------------- 2489 * 2490 * Tcl_DeleteCommand -- 2491 * 2492 * Remove the given command from the given interpreter. 2493 * 2494 * Results: 2495 * 0 is returned if the command was deleted successfully. 2496 * -1 is returned if there didn't exist a command by that name. 2497 * 2498 * Side effects: 2499 * cmdName will no longer be recognized as a valid command for 2500 * interp. 2501 * 2502 *---------------------------------------------------------------------- 2503 */ 2504 2505int 2506Tcl_DeleteCommand(interp, cmdName) 2507 Tcl_Interp *interp; /* Token for command interpreter (returned 2508 * by a previous Tcl_CreateInterp call). */ 2509 CONST char *cmdName; /* Name of command to remove. */ 2510{ 2511 Tcl_Command cmd; 2512 2513 /* 2514 * Find the desired command and delete it. 2515 */ 2516 2517 cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, 2518 /*flags*/ 0); 2519 if (cmd == (Tcl_Command) NULL) { 2520 return -1; 2521 } 2522 return Tcl_DeleteCommandFromToken(interp, cmd); 2523} 2524 2525/* 2526 *---------------------------------------------------------------------- 2527 * 2528 * Tcl_DeleteCommandFromToken -- 2529 * 2530 * Removes the given command from the given interpreter. This procedure 2531 * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead 2532 * of a command name for efficiency. 2533 * 2534 * Results: 2535 * 0 is returned if the command was deleted successfully. 2536 * -1 is returned if there didn't exist a command by that name. 2537 * 2538 * Side effects: 2539 * The command specified by "cmd" will no longer be recognized as a 2540 * valid command for "interp". 2541 * 2542 *---------------------------------------------------------------------- 2543 */ 2544 2545int 2546Tcl_DeleteCommandFromToken(interp, cmd) 2547 Tcl_Interp *interp; /* Token for command interpreter returned by 2548 * a previous call to Tcl_CreateInterp. */ 2549 Tcl_Command cmd; /* Token for command to delete. */ 2550{ 2551 Interp *iPtr = (Interp *) interp; 2552 Command *cmdPtr = (Command *) cmd; 2553 ImportRef *refPtr, *nextRefPtr; 2554 Tcl_Command importCmd; 2555 2556 /* 2557 * The code here is tricky. We can't delete the hash table entry 2558 * before invoking the deletion callback because there are cases 2559 * where the deletion callback needs to invoke the command (e.g. 2560 * object systems such as OTcl). However, this means that the 2561 * callback could try to delete or rename the command. The deleted 2562 * flag allows us to detect these cases and skip nested deletes. 2563 */ 2564 2565 if (cmdPtr->flags & CMD_IS_DELETED) { 2566 /* 2567 * Another deletion is already in progress. Remove the hash 2568 * table entry now, but don't invoke a callback or free the 2569 * command structure. 2570 */ 2571 2572 Tcl_DeleteHashEntry(cmdPtr->hPtr); 2573 cmdPtr->hPtr = NULL; 2574 return 0; 2575 } 2576 2577 /* 2578 * We must delete this command, even though both traces and 2579 * delete procs may try to avoid this (renaming the command etc). 2580 * Also traces and delete procs may try to delete the command 2581 * themsevles. This flag declares that a delete is in progress 2582 * and that recursive deletes should be ignored. 2583 */ 2584 cmdPtr->flags |= CMD_IS_DELETED; 2585 2586 /* 2587 * Bump the command epoch counter. This will invalidate all cached 2588 * references that point to this command. 2589 */ 2590 2591 cmdPtr->cmdEpoch++; 2592 2593 /* 2594 * Call trace procedures for the command being deleted. Then delete 2595 * its traces. 2596 */ 2597 2598 if (cmdPtr->tracePtr != NULL) { 2599 CommandTrace *tracePtr; 2600 CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); 2601 /* Now delete these traces */ 2602 tracePtr = cmdPtr->tracePtr; 2603 while (tracePtr != NULL) { 2604 CommandTrace *nextPtr = tracePtr->nextPtr; 2605 if ((--tracePtr->refCount) <= 0) { 2606 ckfree((char*)tracePtr); 2607 } 2608 tracePtr = nextPtr; 2609 } 2610 cmdPtr->tracePtr = NULL; 2611 } 2612 2613 /* 2614 * If the command being deleted has a compile procedure, increment the 2615 * interpreter's compileEpoch to invalidate its compiled code. This 2616 * makes sure that we don't later try to execute old code compiled with 2617 * command-specific (i.e., inline) bytecodes for the now-deleted 2618 * command. This field is checked in Tcl_EvalObj and ObjInterpProc, and 2619 * code whose compilation epoch doesn't match is recompiled. 2620 */ 2621 2622 if (cmdPtr->compileProc != NULL) { 2623 iPtr->compileEpoch++; 2624 } 2625 2626 if (cmdPtr->deleteProc != NULL) { 2627 /* 2628 * Delete the command's client data. If this was an imported command 2629 * created when a command was imported into a namespace, this client 2630 * data will be a pointer to a ImportedCmdData structure describing 2631 * the "real" command that this imported command refers to. 2632 */ 2633 2634 /* 2635 * If you are getting a crash during the call to deleteProc and 2636 * cmdPtr->deleteProc is a pointer to the function free(), the 2637 * most likely cause is that your extension allocated memory 2638 * for the clientData argument to Tcl_CreateObjCommand() with 2639 * the ckalloc() macro and you are now trying to deallocate 2640 * this memory with free() instead of ckfree(). You should 2641 * pass a pointer to your own method that calls ckfree(). 2642 */ 2643 2644 (*cmdPtr->deleteProc)(cmdPtr->deleteData); 2645 } 2646 2647 /* 2648 * If this command was imported into other namespaces, then imported 2649 * commands were created that refer back to this command. Delete these 2650 * imported commands now. 2651 */ 2652 2653 for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; 2654 refPtr = nextRefPtr) { 2655 nextRefPtr = refPtr->nextPtr; 2656 importCmd = (Tcl_Command) refPtr->importedCmdPtr; 2657 Tcl_DeleteCommandFromToken(interp, importCmd); 2658 } 2659 2660 /* 2661 * Don't use hPtr to delete the hash entry here, because it's 2662 * possible that the deletion callback renamed the command. 2663 * Instead, use cmdPtr->hptr, and make sure that no-one else 2664 * has already deleted the hash entry. 2665 */ 2666 2667 if (cmdPtr->hPtr != NULL) { 2668 Tcl_DeleteHashEntry(cmdPtr->hPtr); 2669 } 2670 2671 /* 2672 * Mark the Command structure as no longer valid. This allows 2673 * TclExecuteByteCode to recognize when a Command has logically been 2674 * deleted and a pointer to this Command structure cached in a CmdName 2675 * object is invalid. TclExecuteByteCode will look up the command again 2676 * in the interpreter's command hashtable. 2677 */ 2678 2679 cmdPtr->objProc = NULL; 2680 2681 /* 2682 * Now free the Command structure, unless there is another reference to 2683 * it from a CmdName Tcl object in some ByteCode code sequence. In that 2684 * case, delay the cleanup until all references are either discarded 2685 * (when a ByteCode is freed) or replaced by a new reference (when a 2686 * cached CmdName Command reference is found to be invalid and 2687 * TclExecuteByteCode looks up the command in the command hashtable). 2688 */ 2689 2690 TclCleanupCommand(cmdPtr); 2691 return 0; 2692} 2693 2694static char * 2695CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) 2696 Interp *iPtr; /* Interpreter containing command. */ 2697 Command *cmdPtr; /* Command whose traces are to be 2698 * invoked. */ 2699 CONST char *oldName; /* Command's old name, or NULL if we 2700 * must get the name from cmdPtr */ 2701 CONST char *newName; /* Command's new name, or NULL if 2702 * the command is not being renamed */ 2703 int flags; /* Flags indicating the type of traces 2704 * to trigger, either TCL_TRACE_DELETE 2705 * or TCL_TRACE_RENAME. */ 2706{ 2707 register CommandTrace *tracePtr; 2708 ActiveCommandTrace active; 2709 char *result; 2710 Tcl_Obj *oldNamePtr = NULL; 2711 int mask = (TCL_TRACE_DELETE | TCL_TRACE_RENAME); /* Safety */ 2712 2713 flags &= mask; 2714 2715 if (cmdPtr->flags & CMD_TRACE_ACTIVE) { 2716 /* 2717 * While a rename trace is active, we will not process any more 2718 * rename traces; while a delete trace is active we will never 2719 * reach here -- because Tcl_DeleteCommandFromToken checks for the 2720 * condition (cmdPtr->flags & CMD_IS_DELETED) and returns immediately 2721 * when a command deletion is in progress. For all other traces, 2722 * delete traces will not be invoked but a call to TraceCommandProc 2723 * will ensure that tracePtr->clientData is freed whenever the 2724 * command "oldName" is deleted. 2725 */ 2726 if (cmdPtr->flags & TCL_TRACE_RENAME) { 2727 flags &= ~TCL_TRACE_RENAME; 2728 } 2729 if (flags == 0) { 2730 return NULL; 2731 } 2732 } 2733 cmdPtr->flags |= CMD_TRACE_ACTIVE; 2734 cmdPtr->refCount++; 2735 2736 result = NULL; 2737 active.nextPtr = iPtr->activeCmdTracePtr; 2738 active.reverseScan = 0; 2739 iPtr->activeCmdTracePtr = &active; 2740 2741 if (flags & TCL_TRACE_DELETE) { 2742 flags |= TCL_TRACE_DESTROYED; 2743 } 2744 active.cmdPtr = cmdPtr; 2745 2746 Tcl_Preserve((ClientData) iPtr); 2747 2748 for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL; 2749 tracePtr = active.nextTracePtr) { 2750 int traceFlags = (tracePtr->flags & mask); 2751 2752 active.nextTracePtr = tracePtr->nextPtr; 2753 if (!(traceFlags & flags)) { 2754 continue; 2755 } 2756 cmdPtr->flags |= traceFlags; 2757 if (oldName == NULL) { 2758 TclNewObj(oldNamePtr); 2759 Tcl_IncrRefCount(oldNamePtr); 2760 Tcl_GetCommandFullName((Tcl_Interp *) iPtr, 2761 (Tcl_Command) cmdPtr, oldNamePtr); 2762 oldName = TclGetString(oldNamePtr); 2763 } 2764 tracePtr->refCount++; 2765 (*tracePtr->traceProc)(tracePtr->clientData, 2766 (Tcl_Interp *) iPtr, oldName, newName, flags); 2767 cmdPtr->flags &= ~traceFlags; 2768 if ((--tracePtr->refCount) <= 0) { 2769 ckfree((char*)tracePtr); 2770 } 2771 } 2772 2773 /* 2774 * If a new object was created to hold the full oldName, 2775 * free it now. 2776 */ 2777 2778 if (oldNamePtr != NULL) { 2779 TclDecrRefCount(oldNamePtr); 2780 } 2781 2782 /* 2783 * Restore the variable's flags, remove the record of our active 2784 * traces, and then return. 2785 */ 2786 2787 cmdPtr->flags &= ~CMD_TRACE_ACTIVE; 2788 cmdPtr->refCount--; 2789 iPtr->activeCmdTracePtr = active.nextPtr; 2790 Tcl_Release((ClientData) iPtr); 2791 return result; 2792} 2793 2794/* 2795 *---------------------------------------------------------------------- 2796 * 2797 * TclCleanupCommand -- 2798 * 2799 * This procedure frees up a Command structure unless it is still 2800 * referenced from an interpreter's command hashtable or from a CmdName 2801 * Tcl object representing the name of a command in a ByteCode 2802 * instruction sequence. 2803 * 2804 * Results: 2805 * None. 2806 * 2807 * Side effects: 2808 * Memory gets freed unless a reference to the Command structure still 2809 * exists. In that case the cleanup is delayed until the command is 2810 * deleted or when the last ByteCode referring to it is freed. 2811 * 2812 *---------------------------------------------------------------------- 2813 */ 2814 2815void 2816TclCleanupCommand(cmdPtr) 2817 register Command *cmdPtr; /* Points to the Command structure to 2818 * be freed. */ 2819{ 2820 cmdPtr->refCount--; 2821 if (cmdPtr->refCount <= 0) { 2822 ckfree((char *) cmdPtr); 2823 } 2824} 2825 2826/* 2827 *---------------------------------------------------------------------- 2828 * 2829 * Tcl_CreateMathFunc -- 2830 * 2831 * Creates a new math function for expressions in a given 2832 * interpreter. 2833 * 2834 * Results: 2835 * None. 2836 * 2837 * Side effects: 2838 * The function defined by "name" is created or redefined. If the 2839 * function already exists then its definition is replaced; this 2840 * includes the builtin functions. Redefining a builtin function forces 2841 * all existing code to be invalidated since that code may be compiled 2842 * using an instruction specific to the replaced function. In addition, 2843 * redefioning a non-builtin function will force existing code to be 2844 * invalidated if the number of arguments has changed. 2845 * 2846 *---------------------------------------------------------------------- 2847 */ 2848 2849void 2850Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) 2851 Tcl_Interp *interp; /* Interpreter in which function is 2852 * to be available. */ 2853 CONST char *name; /* Name of function (e.g. "sin"). */ 2854 int numArgs; /* Nnumber of arguments required by 2855 * function. */ 2856 Tcl_ValueType *argTypes; /* Array of types acceptable for 2857 * each argument. */ 2858 Tcl_MathProc *proc; /* Procedure that implements the 2859 * math function. */ 2860 ClientData clientData; /* Additional value to pass to the 2861 * function. */ 2862{ 2863 Interp *iPtr = (Interp *) interp; 2864 Tcl_HashEntry *hPtr; 2865 MathFunc *mathFuncPtr; 2866 int new, i; 2867 2868 hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); 2869 if (new) { 2870 Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); 2871 } 2872 mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); 2873 2874 if (!new) { 2875 if (mathFuncPtr->builtinFuncIndex >= 0) { 2876 /* 2877 * We are redefining a builtin math function. Invalidate the 2878 * interpreter's existing code by incrementing its 2879 * compileEpoch member. This field is checked in Tcl_EvalObj 2880 * and ObjInterpProc, and code whose compilation epoch doesn't 2881 * match is recompiled. Newly compiled code will no longer 2882 * treat the function as builtin. 2883 */ 2884 2885 iPtr->compileEpoch++; 2886 } else { 2887 /* 2888 * A non-builtin function is being redefined. We must invalidate 2889 * existing code if the number of arguments has changed. This 2890 * is because existing code was compiled assuming that number. 2891 */ 2892 2893 if (numArgs != mathFuncPtr->numArgs) { 2894 iPtr->compileEpoch++; 2895 } 2896 } 2897 } 2898 2899 mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */ 2900 if (numArgs > MAX_MATH_ARGS) { 2901 numArgs = MAX_MATH_ARGS; 2902 } 2903 mathFuncPtr->numArgs = numArgs; 2904 for (i = 0; i < numArgs; i++) { 2905 mathFuncPtr->argTypes[i] = argTypes[i]; 2906 } 2907 mathFuncPtr->proc = proc; 2908 mathFuncPtr->clientData = clientData; 2909} 2910 2911/* 2912 *---------------------------------------------------------------------- 2913 * 2914 * Tcl_GetMathFuncInfo -- 2915 * 2916 * Discovers how a particular math function was created in a given 2917 * interpreter. 2918 * 2919 * Results: 2920 * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message 2921 * in the interpreter result if that happens.) 2922 * 2923 * Side effects: 2924 * If this function succeeds, the variables pointed to by the 2925 * numArgsPtr and argTypePtr arguments will be updated to detail the 2926 * arguments allowed by the function. The variable pointed to by the 2927 * procPtr argument will be set to NULL if the function is a builtin 2928 * function, and will be set to the address of the C function used to 2929 * implement the math function otherwise (in which case the variable 2930 * pointed to by the clientDataPtr argument will also be updated.) 2931 * 2932 *---------------------------------------------------------------------- 2933 */ 2934 2935int 2936Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr, 2937 clientDataPtr) 2938 Tcl_Interp *interp; 2939 CONST char *name; 2940 int *numArgsPtr; 2941 Tcl_ValueType **argTypesPtr; 2942 Tcl_MathProc **procPtr; 2943 ClientData *clientDataPtr; 2944{ 2945 Interp *iPtr = (Interp *) interp; 2946 Tcl_HashEntry *hPtr; 2947 MathFunc *mathFuncPtr; 2948 Tcl_ValueType *argTypes; 2949 int i,numArgs; 2950 2951 hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, name); 2952 if (hPtr == NULL) { 2953 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 2954 "math function \"", name, "\" not known in this interpreter", 2955 (char *) NULL); 2956 return TCL_ERROR; 2957 } 2958 mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); 2959 2960 *numArgsPtr = numArgs = mathFuncPtr->numArgs; 2961 if (numArgs == 0) { 2962 /* Avoid doing zero-sized allocs... */ 2963 numArgs = 1; 2964 } 2965 *argTypesPtr = argTypes = 2966 (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType)); 2967 for (i = 0; i < mathFuncPtr->numArgs; i++) { 2968 argTypes[i] = mathFuncPtr->argTypes[i]; 2969 } 2970 2971 if (mathFuncPtr->builtinFuncIndex == -1) { 2972 *procPtr = (Tcl_MathProc *) NULL; 2973 } else { 2974 *procPtr = mathFuncPtr->proc; 2975 *clientDataPtr = mathFuncPtr->clientData; 2976 } 2977 2978 return TCL_OK; 2979} 2980 2981/* 2982 *---------------------------------------------------------------------- 2983 * 2984 * Tcl_ListMathFuncs -- 2985 * 2986 * Produces a list of all the math functions defined in a given 2987 * interpreter. 2988 * 2989 * Results: 2990 * A pointer to a Tcl_Obj structure with a reference count of zero, 2991 * or NULL in the case of an error (in which case a suitable error 2992 * message will be left in the interpreter result.) 2993 * 2994 * Side effects: 2995 * None. 2996 * 2997 *---------------------------------------------------------------------- 2998 */ 2999 3000Tcl_Obj * 3001Tcl_ListMathFuncs(interp, pattern) 3002 Tcl_Interp *interp; 3003 CONST char *pattern; 3004{ 3005 Interp *iPtr = (Interp *) interp; 3006 Tcl_Obj *resultList = Tcl_NewObj(); 3007 register Tcl_HashEntry *hPtr; 3008 Tcl_HashSearch hSearch; 3009 CONST char *name; 3010 3011 for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &hSearch); 3012 hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { 3013 name = Tcl_GetHashKey(&iPtr->mathFuncTable, hPtr); 3014 if ((pattern == NULL || Tcl_StringMatch(name, pattern)) && 3015 /* I don't expect this to fail, but... */ 3016 Tcl_ListObjAppendElement(interp, resultList, 3017 Tcl_NewStringObj(name,-1)) != TCL_OK) { 3018 Tcl_DecrRefCount(resultList); 3019 return NULL; 3020 } 3021 } 3022 return resultList; 3023} 3024 3025/* 3026 *---------------------------------------------------------------------- 3027 * 3028 * TclInterpReady -- 3029 * 3030 * Check if an interpreter is ready to eval commands or scripts, 3031 * i.e., if it was not deleted and if the nesting level is not 3032 * too high. 3033 * 3034 * Results: 3035 * The return value is TCL_OK if it the interpreter is ready, 3036 * TCL_ERROR otherwise. 3037 * 3038 * Side effects: 3039 * The interpreters object and string results are cleared. 3040 * 3041 *---------------------------------------------------------------------- 3042 */ 3043 3044int 3045TclInterpReady(interp) 3046 Tcl_Interp *interp; 3047{ 3048 register Interp *iPtr = (Interp *) interp; 3049 3050 /* 3051 * Reset both the interpreter's string and object results and clear 3052 * out any previous error information. 3053 */ 3054 3055 Tcl_ResetResult(interp); 3056 3057 /* 3058 * If the interpreter has been deleted, return an error. 3059 */ 3060 3061 if (iPtr->flags & DELETED) { 3062 Tcl_ResetResult(interp); 3063 Tcl_AppendToObj(Tcl_GetObjResult(interp), 3064 "attempt to call eval in deleted interpreter", -1); 3065 Tcl_SetErrorCode(interp, "CORE", "IDELETE", 3066 "attempt to call eval in deleted interpreter", 3067 (char *) NULL); 3068 return TCL_ERROR; 3069 } 3070 3071 /* 3072 * Check depth of nested calls to Tcl_Eval: if this gets too large, 3073 * it's probably because of an infinite loop somewhere. 3074 */ 3075 3076 if (((iPtr->numLevels) > iPtr->maxNestingDepth) 3077 || (TclpCheckStackSpace() == 0)) { 3078 Tcl_AppendToObj(Tcl_GetObjResult(interp), 3079 "too many nested evaluations (infinite loop?)", -1); 3080 return TCL_ERROR; 3081 } 3082 3083 return TCL_OK; 3084} 3085 3086/* 3087 *---------------------------------------------------------------------- 3088 * 3089 * TclEvalObjvInternal -- 3090 * 3091 * This procedure evaluates a Tcl command that has already been 3092 * parsed into words, with one Tcl_Obj holding each word. The caller 3093 * is responsible for managing the iPtr->numLevels. 3094 * 3095 * Results: 3096 * The return value is a standard Tcl completion code such as 3097 * TCL_OK or TCL_ERROR. A result or error message is left in 3098 * interp's result. If an error occurs, this procedure does 3099 * NOT add any information to the errorInfo variable. 3100 * 3101 * Side effects: 3102 * Depends on the command. 3103 * 3104 *---------------------------------------------------------------------- 3105 */ 3106 3107int 3108TclEvalObjvInternal(interp, objc, objv, command, length, flags) 3109 Tcl_Interp *interp; /* Interpreter in which to evaluate the 3110 * command. Also used for error 3111 * reporting. */ 3112 int objc; /* Number of words in command. */ 3113 Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are 3114 * the words that make up the command. */ 3115 CONST char *command; /* Points to the beginning of the string 3116 * representation of the command; this 3117 * is used for traces. If the string 3118 * representation of the command is 3119 * unknown, an empty string should be 3120 * supplied. If it is NULL, no traces will 3121 * be called. */ 3122 int length; /* Number of bytes in command; if -1, all 3123 * characters up to the first null byte are 3124 * used. */ 3125 int flags; /* Collection of OR-ed bits that control 3126 * the evaluation of the script. Only 3127 * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are 3128 * currently supported. */ 3129 3130{ 3131 Command *cmdPtr; 3132 Interp *iPtr = (Interp *) interp; 3133 Tcl_Obj **newObjv; 3134 int i; 3135 CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr 3136 * in case TCL_EVAL_GLOBAL was set. */ 3137 int code = TCL_OK; 3138 int traceCode = TCL_OK; 3139 int checkTraces = 1; 3140 Namespace *savedNsPtr = NULL; 3141 3142 if (TclInterpReady(interp) == TCL_ERROR) { 3143 return TCL_ERROR; 3144 } 3145 3146 if (objc == 0) { 3147 return TCL_OK; 3148 } 3149 3150 3151 /* 3152 * If any execution traces rename or delete the current command, 3153 * we may need (at most) two passes here. 3154 */ 3155 3156 savedVarFramePtr = iPtr->varFramePtr; 3157 while (1) { 3158 3159 /* Configure evaluation context to match the requested flags */ 3160 if (flags & TCL_EVAL_GLOBAL) { 3161 iPtr->varFramePtr = NULL; 3162 } else if ((flags & TCL_EVAL_INVOKE) && iPtr->varFramePtr) { 3163 savedNsPtr = iPtr->varFramePtr->nsPtr; 3164 iPtr->varFramePtr->nsPtr = iPtr->globalNsPtr; 3165 } 3166 3167 /* 3168 * Find the procedure to execute this command. If there isn't one, 3169 * then see if there is a command "unknown". If so, create a new 3170 * word array with "unknown" as the first word and the original 3171 * command words as arguments. Then call ourselves recursively 3172 * to execute it. 3173 */ 3174 cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); 3175 if (cmdPtr == NULL) { 3176 newObjv = (Tcl_Obj **) ckalloc((unsigned) 3177 ((objc + 1) * sizeof (Tcl_Obj *))); 3178 for (i = objc-1; i >= 0; i--) { 3179 newObjv[i+1] = objv[i]; 3180 } 3181 newObjv[0] = Tcl_NewStringObj("::unknown", -1); 3182 Tcl_IncrRefCount(newObjv[0]); 3183 cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); 3184 if (cmdPtr == NULL) { 3185 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 3186 "invalid command name \"", Tcl_GetString(objv[0]), "\"", 3187 (char *) NULL); 3188 code = TCL_ERROR; 3189 } else { 3190 iPtr->numLevels++; 3191 code = TclEvalObjvInternal(interp, objc+1, newObjv, 3192 command, length, 0); 3193 iPtr->numLevels--; 3194 } 3195 Tcl_DecrRefCount(newObjv[0]); 3196 ckfree((char *) newObjv); 3197 if (savedNsPtr) { 3198 iPtr->varFramePtr->nsPtr = savedNsPtr; 3199 } 3200 goto done; 3201 } 3202 if (savedNsPtr) { 3203 iPtr->varFramePtr->nsPtr = savedNsPtr; 3204 } 3205 3206 /* 3207 * Call trace procedures if needed. 3208 */ 3209 if ((checkTraces) && (command != NULL)) { 3210 int cmdEpoch = cmdPtr->cmdEpoch; 3211 int newEpoch; 3212 3213 cmdPtr->refCount++; 3214 /* 3215 * If the first set of traces modifies/deletes the command or 3216 * any existing traces, then the set checkTraces to 0 and 3217 * go through this while loop one more time. 3218 */ 3219 if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { 3220 traceCode = TclCheckInterpTraces(interp, command, length, 3221 cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); 3222 } 3223 if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) 3224 && (traceCode == TCL_OK)) { 3225 traceCode = TclCheckExecutionTraces(interp, command, length, 3226 cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); 3227 } 3228 newEpoch = cmdPtr->cmdEpoch; 3229 TclCleanupCommand(cmdPtr); 3230 if (cmdEpoch != newEpoch) { 3231 /* The command has been modified in some way */ 3232 checkTraces = 0; 3233 continue; 3234 } 3235 } 3236 break; 3237 } 3238 3239 if (TCL_DTRACE_CMD_ARGS_ENABLED()) { 3240 char *a[10]; 3241 int i = 0; 3242 3243 while (i < 10) { 3244 a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; 3245 } 3246 TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], 3247 a[8], a[9]); 3248 } 3249 3250 /* 3251 * Finally, invoke the command's Tcl_ObjCmdProc. 3252 */ 3253 cmdPtr->refCount++; 3254 iPtr->cmdCount++; 3255 if ( code == TCL_OK && traceCode == TCL_OK) { 3256 if (TCL_DTRACE_CMD_ENTRY_ENABLED()) { 3257 TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, 3258 (Tcl_Obj **)(objv + 1)); 3259 } 3260 code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); 3261 if (TCL_DTRACE_CMD_RETURN_ENABLED()) { 3262 TCL_DTRACE_CMD_RETURN(TclGetString(objv[0]), code); 3263 } 3264 } 3265 if (Tcl_AsyncReady()) { 3266 code = Tcl_AsyncInvoke(interp, code); 3267 } 3268 3269 /* 3270 * Call 'leave' command traces 3271 */ 3272 if (!(cmdPtr->flags & CMD_IS_DELETED)) { 3273 int saveErrFlags = iPtr->flags 3274 & (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET); 3275 if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { 3276 traceCode = TclCheckExecutionTraces (interp, command, length, 3277 cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); 3278 } 3279 if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { 3280 traceCode = TclCheckInterpTraces(interp, command, length, 3281 cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); 3282 } 3283 if (traceCode == TCL_OK) { 3284 iPtr->flags |= saveErrFlags; 3285 } 3286 } 3287 TclCleanupCommand(cmdPtr); 3288 3289 /* 3290 * If one of the trace invocation resulted in error, then 3291 * change the result code accordingly. Note, that the 3292 * interp->result should already be set correctly by the 3293 * call to TraceExecutionProc. 3294 */ 3295 3296 if (traceCode != TCL_OK) { 3297 code = traceCode; 3298 } 3299 3300 /* 3301 * If the interpreter has a non-empty string result, the result 3302 * object is either empty or stale because some procedure set 3303 * interp->result directly. If so, move the string result to the 3304 * result object, then reset the string result. 3305 */ 3306 3307 if (*(iPtr->result) != 0) { 3308 (void) Tcl_GetObjResult(interp); 3309 } 3310 3311 if (TCL_DTRACE_CMD_RESULT_ENABLED()) { 3312 Tcl_Obj *r; 3313 3314 r = Tcl_GetObjResult(interp); 3315 TCL_DTRACE_CMD_RESULT(TclGetString(objv[0]), code, TclGetString(r), r); 3316 } 3317 3318 done: 3319 iPtr->varFramePtr = savedVarFramePtr; 3320 return code; 3321} 3322 3323/* 3324 *---------------------------------------------------------------------- 3325 * 3326 * Tcl_EvalObjv -- 3327 * 3328 * This procedure evaluates a Tcl command that has already been 3329 * parsed into words, with one Tcl_Obj holding each word. 3330 * 3331 * Results: 3332 * The return value is a standard Tcl completion code such as 3333 * TCL_OK or TCL_ERROR. A result or error message is left in 3334 * interp's result. 3335 * 3336 * Side effects: 3337 * Depends on the command. 3338 * 3339 *---------------------------------------------------------------------- 3340 */ 3341 3342int 3343Tcl_EvalObjv(interp, objc, objv, flags) 3344 Tcl_Interp *interp; /* Interpreter in which to evaluate the 3345 * command. Also used for error 3346 * reporting. */ 3347 int objc; /* Number of words in command. */ 3348 Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are 3349 * the words that make up the command. */ 3350 int flags; /* Collection of OR-ed bits that control 3351 * the evaluation of the script. Only 3352 * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE 3353 * are currently supported. */ 3354{ 3355 Interp *iPtr = (Interp *)interp; 3356 Trace *tracePtr; 3357 Tcl_DString cmdBuf; 3358 char *cmdString = ""; /* A command string is only necessary for 3359 * command traces or error logs; it will be 3360 * generated to replace this default value if 3361 * necessary. */ 3362 int cmdLen = 0; /* a non-zero value indicates that a command 3363 * string was generated. */ 3364 int code = TCL_OK; 3365 int i; 3366 int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); 3367 3368 for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) { 3369 if ((tracePtr->level == 0) || (iPtr->numLevels <= tracePtr->level)) { 3370 /* 3371 * The command may be needed for an execution trace. Generate a 3372 * command string. 3373 */ 3374 3375 Tcl_DStringInit(&cmdBuf); 3376 for (i = 0; i < objc; i++) { 3377 Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); 3378 } 3379 cmdString = Tcl_DStringValue(&cmdBuf); 3380 cmdLen = Tcl_DStringLength(&cmdBuf); 3381 break; 3382 } 3383 } 3384 3385 iPtr->numLevels++; 3386 code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags); 3387 iPtr->numLevels--; 3388 3389 /* 3390 * If we are again at the top level, process any unusual 3391 * return code returned by the evaluated code. 3392 */ 3393 3394 if (iPtr->numLevels == 0) { 3395 if (code == TCL_RETURN) { 3396 code = TclUpdateReturnInfo(iPtr); 3397 } 3398 if ((code != TCL_OK) && (code != TCL_ERROR) 3399 && !allowExceptions) { 3400 ProcessUnexpectedResult(interp, code); 3401 code = TCL_ERROR; 3402 } 3403 } 3404 3405 if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) { 3406 3407 /* 3408 * If there was an error, a command string will be needed for the 3409 * error log: generate it now if it was not done previously. 3410 */ 3411 3412 if (cmdLen == 0) { 3413 Tcl_DStringInit(&cmdBuf); 3414 for (i = 0; i < objc; i++) { 3415 Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); 3416 } 3417 cmdString = Tcl_DStringValue(&cmdBuf); 3418 cmdLen = Tcl_DStringLength(&cmdBuf); 3419 } 3420 Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); 3421 } 3422 3423 if (cmdLen != 0) { 3424 Tcl_DStringFree(&cmdBuf); 3425 } 3426 return code; 3427} 3428 3429/* 3430 *---------------------------------------------------------------------- 3431 * 3432 * Tcl_LogCommandInfo -- 3433 * 3434 * This procedure is invoked after an error occurs in an interpreter. 3435 * It adds information to the "errorInfo" variable to describe the 3436 * command that was being executed when the error occurred. 3437 * 3438 * Results: 3439 * None. 3440 * 3441 * Side effects: 3442 * Information about the command is added to errorInfo and the 3443 * line number stored internally in the interpreter is set. If this 3444 * is the first call to this procedure or Tcl_AddObjErrorInfo since 3445 * an error occurred, then old information in errorInfo is 3446 * deleted. 3447 * 3448 *---------------------------------------------------------------------- 3449 */ 3450 3451void 3452Tcl_LogCommandInfo(interp, script, command, length) 3453 Tcl_Interp *interp; /* Interpreter in which to log information. */ 3454 CONST char *script; /* First character in script containing 3455 * command (must be <= command). */ 3456 CONST char *command; /* First character in command that 3457 * generated the error. */ 3458 int length; /* Number of bytes in command (-1 means 3459 * use all bytes up to first null byte). */ 3460{ 3461 char buffer[200]; 3462 register CONST char *p; 3463 char *ellipsis = ""; 3464 Interp *iPtr = (Interp *) interp; 3465 3466 if (iPtr->flags & ERR_ALREADY_LOGGED) { 3467 /* 3468 * Someone else has already logged error information for this 3469 * command; we shouldn't add anything more. 3470 */ 3471 3472 return; 3473 } 3474 3475 /* 3476 * Compute the line number where the error occurred. 3477 */ 3478 3479 iPtr->errorLine = 1; 3480 for (p = script; p != command; p++) { 3481 if (*p == '\n') { 3482 iPtr->errorLine++; 3483 } 3484 } 3485 3486 /* 3487 * Create an error message to add to errorInfo, including up to a 3488 * maximum number of characters of the command. 3489 */ 3490 3491 if (length < 0) { 3492 length = strlen(command); 3493 } 3494 if (length > 150) { 3495 length = 150; 3496 ellipsis = "..."; 3497 } 3498 while ( (command[length] & 0xC0) == 0x80 ) { 3499 /* 3500 * Back up truncation point so that we don't truncate in the 3501 * middle of a multi-byte character (in UTF-8) 3502 */ 3503 length--; 3504 ellipsis = "..."; 3505 } 3506 if (!(iPtr->flags & ERR_IN_PROGRESS)) { 3507 sprintf(buffer, "\n while executing\n\"%.*s%s\"", 3508 length, command, ellipsis); 3509 } else { 3510 sprintf(buffer, "\n invoked from within\n\"%.*s%s\"", 3511 length, command, ellipsis); 3512 } 3513 Tcl_AddObjErrorInfo(interp, buffer, -1); 3514 iPtr->flags &= ~ERR_ALREADY_LOGGED; 3515} 3516 3517/* 3518 *---------------------------------------------------------------------- 3519 * 3520 * Tcl_EvalTokensStandard, EvalTokensStandard -- 3521 * 3522 * Given an array of tokens parsed from a Tcl command (e.g., the 3523 * tokens that make up a word or the index for an array variable) 3524 * this procedure evaluates the tokens and concatenates their 3525 * values to form a single result value. 3526 * 3527 * Results: 3528 * The return value is a standard Tcl completion code such as 3529 * TCL_OK or TCL_ERROR. A result or error message is left in 3530 * interp's result. 3531 * 3532 * Side effects: 3533 * Depends on the array of tokens being evaled. 3534 * 3535 * TIP #280 : Keep public API, internally extended API. 3536 *---------------------------------------------------------------------- 3537 */ 3538 3539int 3540Tcl_EvalTokensStandard(interp, tokenPtr, count) 3541 Tcl_Interp *interp; /* Interpreter in which to lookup 3542 * variables, execute nested commands, 3543 * and report errors. */ 3544 Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens 3545 * to evaluate and concatenate. */ 3546 int count; /* Number of tokens to consider at tokenPtr. 3547 * Must be at least 1. */ 3548{ 3549#ifdef TCL_TIP280 3550 return EvalTokensStandard (interp, tokenPtr, count, 1, NULL, NULL); 3551} 3552 3553static int 3554EvalTokensStandard(interp, tokenPtr, count, line, clNextOuter, outerScript) 3555 Tcl_Interp *interp; /* Interpreter in which to lookup 3556 * variables, execute nested commands, 3557 * and report errors. */ 3558 Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens 3559 * to evaluate and concatenate. */ 3560 int count; /* Number of tokens to consider at tokenPtr. 3561 * Must be at least 1. */ 3562 int line; /* The line the script starts on. */ 3563 int* clNextOuter; /* Information about an outer context for */ 3564 CONST char* outerScript; /* continuation line data. This is set by 3565 * EvalEx() to properly handle [...]-nested 3566 * commands. The 'outerScript' refers to the 3567 * most-outer script containing the embedded 3568 * command, which is refered to by 'script'. The 3569 * 'clNextOuter' refers to the current entry in 3570 * the table of continuation lines in this 3571 * "master script", and the character offsets are 3572 * relative to the 'outerScript' as well. 3573 * 3574 * If outerScript == script, then this call is for 3575 * words in the outer-most script/command. See 3576 * Tcl_EvalEx() and TclEvalObjEx() for the places 3577 * generating arguments for which this is true. 3578 */ 3579{ 3580#endif 3581 Tcl_Obj *resultPtr, *indexPtr, *valuePtr; 3582 char buffer[TCL_UTF_MAX]; 3583#ifdef TCL_MEM_DEBUG 3584# define MAX_VAR_CHARS 5 3585#else 3586# define MAX_VAR_CHARS 30 3587#endif 3588 char nameBuffer[MAX_VAR_CHARS+1]; 3589 char *varName, *index; 3590 CONST char *p = NULL; /* Initialized to avoid compiler warning. */ 3591 int length, code; 3592#ifdef TCL_TIP280 3593#define NUM_STATIC_POS 20 3594 int isLiteral, maxNumCL, numCL, i, adjust; 3595 int* clPosition = NULL; 3596 Interp* iPtr = (Interp*) interp; 3597 int inFile = iPtr->evalFlags & TCL_EVAL_FILE; 3598#endif 3599 3600 /* 3601 * The only tricky thing about this procedure is that it attempts to 3602 * avoid object creation and string copying whenever possible. For 3603 * example, if the value is just a nested command, then use the 3604 * command's result object directly. 3605 */ 3606 3607 code = TCL_OK; 3608 resultPtr = NULL; 3609 Tcl_ResetResult(interp); 3610#ifdef TCL_TIP280 3611 /* 3612 * For the handling of continuation lines in literals we first check if 3613 * this is actually a literal. For if not we can forego the additional 3614 * processing. Otherwise we pre-allocate a small table to store the 3615 * locations of all continuation lines we find in this literal, if 3616 * any. The table is extended if needed. 3617 */ 3618 3619 numCL = 0; 3620 maxNumCL = 0; 3621 isLiteral = 1; 3622 for (i=0 ; i < count; i++) { 3623 if ((tokenPtr[i].type != TCL_TOKEN_TEXT) && 3624 (tokenPtr[i].type != TCL_TOKEN_BS)) { 3625 isLiteral = 0; 3626 break; 3627 } 3628 } 3629 3630 if (isLiteral) { 3631 maxNumCL = NUM_STATIC_POS; 3632 clPosition = (int*) ckalloc (maxNumCL*sizeof(int)); 3633 } 3634 adjust = 0; 3635#endif 3636 for ( ; count > 0; count--, tokenPtr++) { 3637 valuePtr = NULL; 3638 3639 /* 3640 * The switch statement below computes the next value to be 3641 * concat to the result, as either a range of text or an 3642 * object. 3643 */ 3644 3645 switch (tokenPtr->type) { 3646 case TCL_TOKEN_TEXT: 3647 p = tokenPtr->start; 3648 length = tokenPtr->size; 3649 break; 3650 3651 case TCL_TOKEN_BS: 3652 length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, 3653 buffer); 3654 p = buffer; 3655#ifdef TCL_TIP280 3656 /* 3657 * If the backslash sequence we found is in a literal, and 3658 * represented a continuation line, we compute and store its 3659 * location (as char offset to the beginning of the _result_ 3660 * script). We may have to extend the table of locations. 3661 * 3662 * Note that the continuation line information is relevant 3663 * even if the word we are processing is not a literal, as it 3664 * can affect nested commands. See the branch for 3665 * TCL_TOKEN_COMMAND below, where the adjustment we are 3666 * tracking here is taken into account. The good thing is that 3667 * we do not need a table of everything, just the number of 3668 * lines we have to add as correction. 3669 */ 3670 3671 if ((length == 1) && (buffer[0] == ' ') && 3672 (tokenPtr->start[1] == '\n')) { 3673 if (isLiteral) { 3674 int clPos; 3675 if (resultPtr == 0) { 3676 clPos = 0; 3677 } else { 3678 Tcl_GetStringFromObj(resultPtr, &clPos); 3679 } 3680 3681 if (numCL >= maxNumCL) { 3682 maxNumCL *= 2; 3683 clPosition = (int*) ckrealloc ((char*)clPosition, 3684 maxNumCL*sizeof(int)); 3685 } 3686 clPosition[numCL] = clPos; 3687 numCL ++; 3688 } 3689 adjust ++; 3690 } 3691#endif 3692 break; 3693 3694 case TCL_TOKEN_COMMAND: { 3695 Interp *iPtr = (Interp *) interp; 3696 iPtr->numLevels++; 3697 code = TclInterpReady(interp); 3698 if (code == TCL_OK) { 3699#ifndef TCL_TIP280 3700 code = Tcl_EvalEx(interp, 3701 tokenPtr->start+1, tokenPtr->size-2, 0); 3702#else 3703 /* TIP #280: Transfer line information to nested command */ 3704 TclAdvanceContinuations (&line, &clNextOuter, 3705 tokenPtr->start - outerScript); 3706 code = EvalEx(interp, 3707 tokenPtr->start+1, tokenPtr->size-2, 0, 3708 line + adjust, clNextOuter, outerScript); 3709 3710 /* 3711 * Restore flag reset by the nested eval for future 3712 * bracketed commands and their CmdFrame setup 3713 */ 3714 if (inFile) { 3715 iPtr->evalFlags |= TCL_EVAL_FILE; 3716 } 3717#endif 3718 } 3719 iPtr->numLevels--; 3720 if (code != TCL_OK) { 3721 goto done; 3722 } 3723 valuePtr = Tcl_GetObjResult(interp); 3724 break; 3725 } 3726 3727 case TCL_TOKEN_VARIABLE: 3728 if (tokenPtr->numComponents == 1) { 3729 indexPtr = NULL; 3730 index = NULL; 3731 } else { 3732#ifndef TCL_TIP280 3733 code = Tcl_EvalTokensStandard(interp, tokenPtr+2, 3734 tokenPtr->numComponents - 1); 3735#else 3736 /* TIP #280: Transfer line information to nested command */ 3737 code = EvalTokensStandard(interp, tokenPtr+2, 3738 tokenPtr->numComponents - 1, line, NULL, NULL); 3739#endif 3740 if (code != TCL_OK) { 3741 goto done; 3742 } 3743 indexPtr = Tcl_GetObjResult(interp); 3744 Tcl_IncrRefCount(indexPtr); 3745 index = Tcl_GetString(indexPtr); 3746 } 3747 3748 /* 3749 * We have to make a copy of the variable name in order 3750 * to have a null-terminated string. We can't make a 3751 * temporary modification to the script to null-terminate 3752 * the name, because a trace callback might potentially 3753 * reuse the script and be affected by the null character. 3754 */ 3755 3756 if (tokenPtr[1].size <= MAX_VAR_CHARS) { 3757 varName = nameBuffer; 3758 } else { 3759 varName = ckalloc((unsigned) (tokenPtr[1].size + 1)); 3760 } 3761 strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size); 3762 varName[tokenPtr[1].size] = 0; 3763 valuePtr = Tcl_GetVar2Ex(interp, varName, index, 3764 TCL_LEAVE_ERR_MSG); 3765 if (varName != nameBuffer) { 3766 ckfree(varName); 3767 } 3768 if (indexPtr != NULL) { 3769 Tcl_DecrRefCount(indexPtr); 3770 } 3771 if (valuePtr == NULL) { 3772 code = TCL_ERROR; 3773 goto done; 3774 } 3775 count -= tokenPtr->numComponents; 3776 tokenPtr += tokenPtr->numComponents; 3777 break; 3778 3779 default: 3780 panic("unexpected token type in Tcl_EvalTokensStandard"); 3781 } 3782 3783 /* 3784 * If valuePtr isn't NULL, the next piece of text comes from that 3785 * object; otherwise, take length bytes starting at p. 3786 */ 3787 3788 if (resultPtr == NULL) { 3789 if (valuePtr != NULL) { 3790 resultPtr = valuePtr; 3791 } else { 3792 resultPtr = Tcl_NewStringObj(p, length); 3793 } 3794 Tcl_IncrRefCount(resultPtr); 3795 } else { 3796 if (Tcl_IsShared(resultPtr)) { 3797 Tcl_DecrRefCount(resultPtr); 3798 resultPtr = Tcl_DuplicateObj(resultPtr); 3799 Tcl_IncrRefCount(resultPtr); 3800 } 3801 if (valuePtr != NULL) { 3802 p = Tcl_GetStringFromObj(valuePtr, &length); 3803 } 3804 Tcl_AppendToObj(resultPtr, p, length); 3805 } 3806 } 3807 if (resultPtr != NULL) { 3808 Tcl_SetObjResult(interp, resultPtr); 3809#ifdef TCL_TIP280 3810 /* 3811 * If the code found continuation lines (which implies that this word 3812 * is a literal), then we store the accumulated table of locations in 3813 * the thread-global data structure for the bytecode compiler to find 3814 * later, assuming that the literal is a script which will be 3815 * compiled. 3816 */ 3817 3818 if (numCL) { 3819 TclContinuationsEnter(resultPtr, numCL, clPosition); 3820 } 3821 3822 /* 3823 * Release the temp table we used to collect the locations of 3824 * continuation lines, if any. 3825 */ 3826 3827 if (maxNumCL) { 3828 ckfree ((char*) clPosition); 3829 } 3830#endif 3831 } else { 3832 code = TCL_ERROR; 3833 } 3834 3835 done: 3836 if (resultPtr != NULL) { 3837 Tcl_DecrRefCount(resultPtr); 3838 } 3839 return code; 3840} 3841 3842/* 3843 *---------------------------------------------------------------------- 3844 * 3845 * Tcl_EvalTokens -- 3846 * 3847 * Given an array of tokens parsed from a Tcl command (e.g., the 3848 * tokens that make up a word or the index for an array variable) 3849 * this procedure evaluates the tokens and concatenates their 3850 * values to form a single result value. 3851 * 3852 * Results: 3853 * The return value is a pointer to a newly allocated Tcl_Obj 3854 * containing the value of the array of tokens. The reference 3855 * count of the returned object has been incremented. If an error 3856 * occurs in evaluating the tokens then a NULL value is returned 3857 * and an error message is left in interp's result. 3858 * 3859 * Side effects: 3860 * A new object is allocated to hold the result. 3861 * 3862 *---------------------------------------------------------------------- 3863 * 3864 * This uses a non-standard return convention; its use is now deprecated. 3865 * It is a wrapper for the new function Tcl_EvalTokensStandard, and is not 3866 * used in the core any longer. It is only kept for backward compatibility. 3867 */ 3868 3869Tcl_Obj * 3870Tcl_EvalTokens(interp, tokenPtr, count) 3871 Tcl_Interp *interp; /* Interpreter in which to lookup 3872 * variables, execute nested commands, 3873 * and report errors. */ 3874 Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens 3875 * to evaluate and concatenate. */ 3876 int count; /* Number of tokens to consider at tokenPtr. 3877 * Must be at least 1. */ 3878{ 3879 int code; 3880 Tcl_Obj *resPtr; 3881 3882 code = Tcl_EvalTokensStandard(interp, tokenPtr, count); 3883 if (code == TCL_OK) { 3884 resPtr = Tcl_GetObjResult(interp); 3885 Tcl_IncrRefCount(resPtr); 3886 Tcl_ResetResult(interp); 3887 return resPtr; 3888 } else { 3889 return NULL; 3890 } 3891} 3892 3893 3894/* 3895 *---------------------------------------------------------------------- 3896 * 3897 * Tcl_EvalEx, EvalEx -- 3898 * 3899 * This procedure evaluates a Tcl script without using the compiler 3900 * or byte-code interpreter. It just parses the script, creates 3901 * values for each word of each command, then calls EvalObjv 3902 * to execute each command. 3903 * 3904 * Results: 3905 * The return value is a standard Tcl completion code such as 3906 * TCL_OK or TCL_ERROR. A result or error message is left in 3907 * interp's result. 3908 * 3909 * Side effects: 3910 * Depends on the script. 3911 * 3912 * TIP #280 : Keep public API, internally extended API. 3913 *---------------------------------------------------------------------- 3914 */ 3915 3916int 3917Tcl_EvalEx(interp, script, numBytes, flags) 3918 Tcl_Interp *interp; /* Interpreter in which to evaluate the 3919 * script. Also used for error reporting. */ 3920 CONST char *script; /* First character of script to evaluate. */ 3921 int numBytes; /* Number of bytes in script. If < 0, the 3922 * script consists of all bytes up to the 3923 * first null character. */ 3924 int flags; /* Collection of OR-ed bits that control 3925 * the evaluation of the script. Only 3926 * TCL_EVAL_GLOBAL is currently 3927 * supported. */ 3928{ 3929#ifdef TCL_TIP280 3930 return EvalEx (interp, script, numBytes, flags, 1, NULL, script); 3931} 3932 3933static int 3934EvalEx(interp, script, numBytes, flags, line, clNextOuter, outerScript) 3935 Tcl_Interp *interp; /* Interpreter in which to evaluate the 3936 * script. Also used for error reporting. */ 3937 CONST char *script; /* First character of script to evaluate. */ 3938 int numBytes; /* Number of bytes in script. If < 0, the 3939 * script consists of all bytes up to the 3940 * first null character. */ 3941 int flags; /* Collection of OR-ed bits that control 3942 * the evaluation of the script. Only 3943 * TCL_EVAL_GLOBAL is currently 3944 * supported. */ 3945 int line; /* The line the script starts on. */ 3946 int* clNextOuter; /* Information about an outer context for */ 3947 CONST char* outerScript; /* continuation line data. This is set only in 3948 * EvalTokensStandard(), to properly handle 3949 * [...]-nested commands. The 'outerScript' 3950 * refers to the most-outer script containing the 3951 * embedded command, which is refered to by 3952 * 'script'. The 'clNextOuter' refers to the 3953 * current entry in the table of continuation 3954 * lines in this "master script", and the 3955 * character offsets are relative to the 3956 * 'outerScript' as well. 3957 * 3958 * If outerScript == script, then this call is 3959 * for the outer-most script/command. See 3960 * Tcl_EvalEx() and TclEvalObjEx() for places 3961 * generating arguments for which this is true. 3962 */ 3963{ 3964#endif 3965 Interp *iPtr = (Interp *) interp; 3966 CONST char *p, *next; 3967 Tcl_Parse parse; 3968#define NUM_STATIC_OBJS 20 3969 Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv; 3970 Tcl_Token *tokenPtr; 3971 int code = TCL_OK; 3972 int i, commandLength, bytesLeft, nested; 3973 CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr 3974 * in case TCL_EVAL_GLOBAL was set. */ 3975 int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); 3976 3977 /* 3978 * The variables below keep track of how much state has been 3979 * allocated while evaluating the script, so that it can be freed 3980 * properly if an error occurs. 3981 */ 3982 3983 int gotParse = 0, objectsUsed = 0; 3984 3985#ifdef TCL_TIP280 3986 /* TIP #280 Structures for tracking of command locations. */ 3987 CmdFrame eeFrame; 3988 3989 /* 3990 * Pointer for the tracking of invisible continuation lines. Initialized 3991 * only if the caller gave us a table of locations to track, via 3992 * scriptCLLocPtr. It always refers to the table entry holding the 3993 * location of the next invisible continuation line to look for, while 3994 * parsing the script. 3995 */ 3996 3997 int* clNext = NULL; 3998 3999 if (iPtr->scriptCLLocPtr) { 4000 if (clNextOuter) { 4001 clNext = clNextOuter; 4002 } else { 4003 clNext = &iPtr->scriptCLLocPtr->loc[0]; 4004 } 4005 } 4006#endif 4007 4008 if (numBytes < 0) { 4009 numBytes = strlen(script); 4010 } 4011 Tcl_ResetResult(interp); 4012 4013 savedVarFramePtr = iPtr->varFramePtr; 4014 if (flags & TCL_EVAL_GLOBAL) { 4015 iPtr->varFramePtr = NULL; 4016 } 4017 4018 /* 4019 * Each iteration through the following loop parses the next 4020 * command from the script and then executes it. 4021 */ 4022 4023 objv = staticObjArray; 4024 p = script; 4025 bytesLeft = numBytes; 4026 if (iPtr->evalFlags & TCL_BRACKET_TERM) { 4027 nested = 1; 4028 } else { 4029 nested = 0; 4030 } 4031 4032#ifdef TCL_TIP280 4033 /* TIP #280 Initialize tracking. Do not push on the frame stack yet. */ 4034 /* 4035 * We may cont. counting based on a specific context (CTX), or open a new 4036 * context, either for a sourced script, or 'eval'. For sourced files we 4037 * always have a path object, even if nothing was specified in the interp 4038 * itself. That makes code using it simpler as NULL checks can be left 4039 * out. Sourced file without path in the 'scriptFile' is possible during 4040 * Tcl initialization. 4041 */ 4042 4043 if (iPtr->evalFlags & TCL_EVAL_CTX) { 4044 /* Path information comes out of the context. */ 4045 4046 eeFrame.type = TCL_LOCATION_SOURCE; 4047 eeFrame.data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path; 4048 Tcl_IncrRefCount (eeFrame.data.eval.path); 4049 } else if (iPtr->evalFlags & TCL_EVAL_FILE) { 4050 /* Set up for a sourced file */ 4051 4052 eeFrame.type = TCL_LOCATION_SOURCE; 4053 4054 if (iPtr->scriptFile) { 4055 /* Normalization here, to have the correct pwd. Should have 4056 * negligible impact on performance, as the norm should have been 4057 * done already by the 'source' invoking us, and it caches the 4058 * result 4059 */ 4060 4061 Tcl_Obj* norm = Tcl_FSGetNormalizedPath (interp, iPtr->scriptFile); 4062 if (!norm) { 4063 /* Error message in the interp result */ 4064 return TCL_ERROR; 4065 } 4066 eeFrame.data.eval.path = norm; 4067 } else { 4068 eeFrame.data.eval.path = Tcl_NewStringObj ("",-1); 4069 } 4070 Tcl_IncrRefCount (eeFrame.data.eval.path); 4071 } else { 4072 /* Set up for plain eval */ 4073 4074 eeFrame.type = TCL_LOCATION_EVAL; 4075 eeFrame.data.eval.path = NULL; 4076 } 4077 4078 eeFrame.level = (iPtr->cmdFramePtr == NULL 4079 ? 1 4080 : iPtr->cmdFramePtr->level + 1); 4081 eeFrame.framePtr = iPtr->framePtr; 4082 eeFrame.nextPtr = iPtr->cmdFramePtr; 4083 eeFrame.nline = 0; 4084 eeFrame.line = NULL; 4085#endif 4086 4087 iPtr->evalFlags = 0; 4088 do { 4089 if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) 4090 != TCL_OK) { 4091 code = TCL_ERROR; 4092 goto error; 4093 } 4094 gotParse = 1; 4095 4096 if (nested && parse.term == (script + numBytes)) { 4097 /* 4098 * A nested script can only terminate in ']'. If 4099 * the parsing got terminated at the end of the script, 4100 * there was no closing ']'. Report the syntax error. 4101 */ 4102 4103 code = TCL_ERROR; 4104 goto error; 4105 } 4106 4107#ifdef TCL_TIP280 4108 /* 4109 * TIP #280 Track lines. The parser may have skipped text till it 4110 * found the command we are now at. We have count the lines in this 4111 * block, and do not forget invisible continuation lines. 4112 */ 4113 4114 TclAdvanceLines (&line, p, parse.commandStart); 4115 TclAdvanceContinuations (&line, &clNext, 4116 parse.commandStart - outerScript); 4117#endif 4118 4119 if (parse.numWords > 0) { 4120#ifdef TCL_TIP280 4121 /* 4122 * TIP #280. Track lines within the words of the current 4123 * command. We use a separate pointer into the table of 4124 * continuation line locations to not lose our position for the 4125 * per-command parsing. 4126 */ 4127 4128 int wordLine = line; 4129 CONST char* wordStart = parse.commandStart; 4130 int* wordCLNext = clNext; 4131#endif 4132 4133 /* 4134 * Generate an array of objects for the words of the command. 4135 */ 4136 4137 if (parse.numWords <= NUM_STATIC_OBJS) { 4138 objv = staticObjArray; 4139 } else { 4140 objv = (Tcl_Obj **) ckalloc((unsigned) 4141 (parse.numWords * sizeof (Tcl_Obj *))); 4142 } 4143 4144#ifdef TCL_TIP280 4145 eeFrame.nline = parse.numWords; 4146 eeFrame.line = (int*) ckalloc((unsigned) 4147 (parse.numWords * sizeof (int))); 4148#endif 4149 4150 for (objectsUsed = 0, tokenPtr = parse.tokenPtr; 4151 objectsUsed < parse.numWords; 4152 objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { 4153#ifndef TCL_TIP280 4154 code = Tcl_EvalTokensStandard(interp, tokenPtr+1, 4155 tokenPtr->numComponents); 4156#else 4157 /* 4158 * TIP #280. Track lines to current word. Save the 4159 * information on a per-word basis, signaling dynamic words as 4160 * needed. Make the information available to the recursively 4161 * called evaluator as well, including the type of context 4162 * (source vs. eval). 4163 */ 4164 4165 TclAdvanceLines (&wordLine, wordStart, tokenPtr->start); 4166 TclAdvanceContinuations (&wordLine, &wordCLNext, 4167 tokenPtr->start - outerScript); 4168 wordStart = tokenPtr->start; 4169 4170 eeFrame.line [objectsUsed] = (TclWordKnownAtCompileTime (tokenPtr) 4171 ? wordLine 4172 : -1); 4173 4174 if (eeFrame.type == TCL_LOCATION_SOURCE) { 4175 iPtr->evalFlags |= TCL_EVAL_FILE; 4176 } 4177 4178 code = EvalTokensStandard(interp, tokenPtr+1, 4179 tokenPtr->numComponents, wordLine, 4180 wordCLNext, outerScript); 4181 4182 iPtr->evalFlags = 0; 4183#endif 4184 4185 if (code == TCL_OK) { 4186 objv[objectsUsed] = Tcl_GetObjResult(interp); 4187 Tcl_IncrRefCount(objv[objectsUsed]); 4188#ifdef TCL_TIP280 4189 if (wordCLNext) { 4190 TclContinuationsEnterDerived (objv[objectsUsed], 4191 wordStart - outerScript, wordCLNext); 4192 } 4193#endif 4194 } else { 4195 goto error; 4196 } 4197 } 4198 4199 /* 4200 * Execute the command and free the objects for its words. 4201 * 4202 * TIP #280: Remember the command itself for 'info frame'. We 4203 * shorten the visible command by one char to exclude the 4204 * termination character, if necessary. Here is where we put our 4205 * frame on the stack of frames too. _After_ the nested commands 4206 * have been executed. 4207 */ 4208 4209#ifdef TCL_TIP280 4210 eeFrame.cmd.str.cmd = parse.commandStart; 4211 eeFrame.cmd.str.len = parse.commandSize; 4212 4213 if (parse.term == parse.commandStart + parse.commandSize - 1) { 4214 eeFrame.cmd.str.len --; 4215 } 4216 4217 TclArgumentEnter (interp, objv, objectsUsed, &eeFrame); 4218 iPtr->cmdFramePtr = &eeFrame; 4219#endif 4220 iPtr->numLevels++; 4221 code = TclEvalObjvInternal(interp, objectsUsed, objv, 4222 parse.commandStart, parse.commandSize, 0); 4223 iPtr->numLevels--; 4224#ifdef TCL_TIP280 4225 iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; 4226 TclArgumentRelease (interp, objv, objectsUsed); 4227 4228 ckfree ((char*) eeFrame.line); 4229 eeFrame.line = NULL; 4230 eeFrame.nline = 0; 4231#endif 4232 4233 if (code != TCL_OK) { 4234 goto error; 4235 } 4236 for (i = 0; i < objectsUsed; i++) { 4237 Tcl_DecrRefCount(objv[i]); 4238 } 4239 objectsUsed = 0; 4240 if (objv != staticObjArray) { 4241 ckfree((char *) objv); 4242 objv = staticObjArray; 4243 } 4244 } 4245 4246 /* 4247 * Advance to the next command in the script. 4248 * 4249 * TIP #280 Track Lines. Now we track how many lines were in the 4250 * executed command. 4251 */ 4252 4253 next = parse.commandStart + parse.commandSize; 4254 bytesLeft -= next - p; 4255 p = next; 4256#ifdef TCL_TIP280 4257 TclAdvanceLines (&line, parse.commandStart, p); 4258#endif 4259 Tcl_FreeParse(&parse); 4260 gotParse = 0; 4261 if (nested && (*parse.term == ']')) { 4262 /* 4263 * We get here in the special case where the TCL_BRACKET_TERM 4264 * flag was set in the interpreter and the latest parsed command 4265 * was terminated by the matching close-bracket we seek. 4266 * Return immediately. 4267 */ 4268 4269 iPtr->termOffset = (p - 1) - script; 4270 iPtr->varFramePtr = savedVarFramePtr; 4271#ifndef TCL_TIP280 4272 return TCL_OK; 4273#else 4274 code = TCL_OK; 4275 goto cleanup_return; 4276#endif 4277 } 4278 } while (bytesLeft > 0); 4279 4280 if (nested) { 4281 /* 4282 * This nested script did not terminate in ']', it is an error. 4283 */ 4284 4285 code = TCL_ERROR; 4286 goto error; 4287 } 4288 4289 iPtr->termOffset = p - script; 4290 iPtr->varFramePtr = savedVarFramePtr; 4291#ifndef TCL_TIP280 4292 return TCL_OK; 4293#else 4294 code = TCL_OK; 4295 goto cleanup_return; 4296#endif 4297 4298 error: 4299 /* 4300 * Generate various pieces of error information, such as the line 4301 * number where the error occurred and information to add to the 4302 * errorInfo variable. Then free resources that had been allocated 4303 * to the command. 4304 */ 4305 4306 if (iPtr->numLevels == 0) { 4307 if (code == TCL_RETURN) { 4308 code = TclUpdateReturnInfo(iPtr); 4309 } 4310 if ((code != TCL_OK) && (code != TCL_ERROR) 4311 && !allowExceptions) { 4312 ProcessUnexpectedResult(interp, code); 4313 code = TCL_ERROR; 4314 } 4315 } 4316 if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { 4317 commandLength = parse.commandSize; 4318 if (parse.term == parse.commandStart + commandLength - 1) { 4319 /* 4320 * The terminator character (such as ; or ]) of the command where 4321 * the error occurred is the last character in the parsed command. 4322 * Reduce the length by one so that the error message doesn't 4323 * include the terminator character. 4324 */ 4325 4326 commandLength -= 1; 4327 } 4328 Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength); 4329 } 4330 4331 for (i = 0; i < objectsUsed; i++) { 4332 Tcl_DecrRefCount(objv[i]); 4333 } 4334 if (gotParse) { 4335 Tcl_FreeParse(&parse); 4336 } 4337 if (objv != staticObjArray) { 4338 ckfree((char *) objv); 4339 } 4340 iPtr->varFramePtr = savedVarFramePtr; 4341 4342 /* 4343 * All that's left to do before returning is to set iPtr->termOffset 4344 * to point past the end of the script we just evaluated. 4345 */ 4346 4347 next = parse.commandStart + parse.commandSize; 4348 bytesLeft -= next - p; 4349 p = next; 4350 4351 if (!nested) { 4352 iPtr->termOffset = p - script; 4353#ifndef TCL_TIP280 4354 return code; 4355#else 4356 goto cleanup_return; 4357#endif 4358 } 4359 4360 /* 4361 * When we are nested (the TCL_BRACKET_TERM flag was set in the 4362 * interpreter), we must find the matching close-bracket to 4363 * end the script we are evaluating. 4364 * 4365 * When our return code is TCL_CONTINUE or TCL_RETURN, we want 4366 * to correctly set iPtr->termOffset to point to that matching 4367 * close-bracket so our caller can move to the part of the 4368 * string beyond the script we were asked to evaluate. 4369 * So we try to parse past the rest of the commands. 4370 */ 4371 4372 next = NULL; 4373 while (bytesLeft && (*parse.term != ']')) { 4374 if (TCL_OK != Tcl_ParseCommand(NULL, p, bytesLeft, 1, &parse)) { 4375 /* 4376 * Syntax error. Set the termOffset to the beginning of 4377 * the last command parsed. 4378 */ 4379 4380 if (next == NULL) { 4381 iPtr->termOffset = (parse.commandStart - 1) - script; 4382 } else { 4383 iPtr->termOffset = (next - 1) - script; 4384 } 4385#ifndef TCL_TIP280 4386 return code; 4387#else 4388 goto cleanup_return; 4389#endif 4390 } 4391 next = parse.commandStart + parse.commandSize; 4392 bytesLeft -= next - p; 4393 p = next; 4394 next = parse.commandStart; 4395 Tcl_FreeParse(&parse); 4396 } 4397 4398 if (bytesLeft) { 4399 /* 4400 * parse.term points to the close-bracket. 4401 */ 4402 4403 iPtr->termOffset = parse.term - script; 4404 } else if (parse.term == script + numBytes) { 4405 /* 4406 * There was no close-bracket. Syntax error. 4407 */ 4408 4409 iPtr->termOffset = parse.term - script; 4410 Tcl_SetObjResult(interp, 4411 Tcl_NewStringObj("missing close-bracket", -1)); 4412#ifndef TCL_TIP280 4413 return TCL_ERROR; 4414#else 4415 code = TCL_ERROR; 4416 goto cleanup_return; 4417#endif 4418 } else if (*parse.term != ']') { 4419 /* 4420 * There was no close-bracket. Syntax error. 4421 */ 4422 4423 iPtr->termOffset = (parse.term + 1) - script; 4424 Tcl_SetObjResult(interp, 4425 Tcl_NewStringObj("missing close-bracket", -1)); 4426#ifndef TCL_TIP280 4427 return TCL_ERROR; 4428#else 4429 code = TCL_ERROR; 4430 goto cleanup_return; 4431#endif 4432 } else { 4433 /* 4434 * parse.term points to the close-bracket. 4435 */ 4436 iPtr->termOffset = parse.term - script; 4437 } 4438 4439#ifdef TCL_TIP280 4440 cleanup_return: 4441 /* TIP #280. Release the local CmdFrame, and its contents. */ 4442 4443 if (eeFrame.line != NULL) { 4444 ckfree ((char*) eeFrame.line); 4445 } 4446 if (eeFrame.type == TCL_LOCATION_SOURCE) { 4447 Tcl_DecrRefCount (eeFrame.data.eval.path); 4448 } 4449#endif 4450 return code; 4451} 4452 4453#ifdef TCL_TIP280 4454/* 4455 *---------------------------------------------------------------------- 4456 * 4457 * TclAdvanceLines -- 4458 * 4459 * This procedure is a helper which counts the number of lines 4460 * in a block of text and advances an external counter. 4461 * 4462 * Results: 4463 * None. 4464 * 4465 * Side effects: 4466 * The specified counter is advanced per the number of lines found. 4467 * 4468 * TIP #280 4469 *---------------------------------------------------------------------- 4470 */ 4471 4472void 4473TclAdvanceLines (line,start,end) 4474 int* line; 4475 CONST char* start; 4476 CONST char* end; 4477{ 4478 CONST char* p; 4479 for (p = start; p < end; p++) { 4480 if (*p == '\n') { 4481 (*line) ++; 4482 } 4483 } 4484} 4485 4486/* 4487 *---------------------------------------------------------------------- 4488 * 4489 * TclAdvanceContinuations -- 4490 * 4491 * This procedure is a helper which counts the number of continuation 4492 * lines (CL) in a block of text using a table of CL locations and 4493 * advances an external counter, and the pointer into the table. 4494 * 4495 * Results: 4496 * None. 4497 * 4498 * Side effects: 4499 * The specified counter is advanced per the number of continuation lines 4500 * found. 4501 * 4502 * TIP #280 4503 *---------------------------------------------------------------------- 4504 */ 4505 4506void 4507TclAdvanceContinuations (line,clNextPtrPtr,loc) 4508 int* line; 4509 int** clNextPtrPtr; 4510 int loc; 4511{ 4512 /* 4513 * Track the invisible continuation lines embedded in a script, if 4514 * any. Here they are just spaces (already). They were removed by 4515 * EvalTokensStandard() via Tcl_UtfBackslash(). 4516 * 4517 * *clNextPtrPtr <=> We have continuation lines to track. 4518 * **clNextPtrPtr >= 0 <=> We are not beyond the last possible location. 4519 * loc >= **clNextPtrPtr <=> We stepped beyond the current cont. line. 4520 */ 4521 4522 while (*clNextPtrPtr && (**clNextPtrPtr >= 0) && (loc >= **clNextPtrPtr)) { 4523 /* 4524 * We just stepped over an invisible continuation line. Adjust the 4525 * line counter and step to the table entry holding the location of 4526 * the next continuation line to track. 4527 */ 4528 (*line) ++; 4529 (*clNextPtrPtr) ++; 4530 } 4531} 4532 4533/* 4534 *---------------------------------------------------------------------- 4535 * Note: The whole data structure access for argument location tracking is 4536 * hidden behind these three functions. The only parts open are the lineLAPtr 4537 * field in the Interp structure. The CFWord definition is internal to here. 4538 * Should make it easier to redo the data structures if we find something more 4539 * space/time efficient. 4540 */ 4541 4542/* 4543 *---------------------------------------------------------------------- 4544 * 4545 * TclArgumentEnter -- 4546 * 4547 * This procedure is a helper for the TIP #280 uplevel extension. 4548 * It enters location references for the arguments of a command to be 4549 * invoked. Only the first entry has the actual data, further entries 4550 * simply count the usage up. 4551 * 4552 * Results: 4553 * None. 4554 * 4555 * Side effects: 4556 * May allocate memory. 4557 * 4558 * TIP #280 4559 *---------------------------------------------------------------------- 4560 */ 4561 4562void 4563TclArgumentEnter(interp,objv,objc,cfPtr) 4564 Tcl_Interp* interp; 4565 Tcl_Obj** objv; 4566 int objc; 4567 CmdFrame* cfPtr; 4568{ 4569 Interp* iPtr = (Interp*) interp; 4570 int new, i; 4571 Tcl_HashEntry* hPtr; 4572 CFWord* cfwPtr; 4573 4574 for (i=1; i < objc; i++) { 4575 /* 4576 * Ignore argument words without line information (= dynamic). If 4577 * they are variables they may have location information associated 4578 * with that, either through globally recorded 'set' invokations, or 4579 * literals in bytecode. Eitehr way there is no need to record 4580 * something here. 4581 */ 4582 4583 if (cfPtr->line [i] < 0) continue; 4584 hPtr = Tcl_CreateHashEntry (iPtr->lineLAPtr, (char*) objv[i], &new); 4585 if (new) { 4586 /* 4587 * The word is not on the stack yet, remember the current location 4588 * and initialize references. 4589 */ 4590 cfwPtr = (CFWord*) ckalloc (sizeof (CFWord)); 4591 cfwPtr->framePtr = cfPtr; 4592 cfwPtr->word = i; 4593 cfwPtr->refCount = 1; 4594 Tcl_SetHashValue (hPtr, cfwPtr); 4595 } else { 4596 /* 4597 * The word is already on the stack, its current location is not 4598 * relevant. Just remember the reference to prevent early removal. 4599 */ 4600 cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr); 4601 cfwPtr->refCount ++; 4602 } 4603 } 4604} 4605 4606/* 4607 *---------------------------------------------------------------------- 4608 * 4609 * TclArgumentRelease -- 4610 * 4611 * This procedure is a helper for the TIP #280 uplevel extension. 4612 * It removes the location references for the arguments of a command 4613 * just done. Usage is counted down, the data is removed only when 4614 * no user is left over. 4615 * 4616 * Results: 4617 * None. 4618 * 4619 * Side effects: 4620 * May release memory. 4621 * 4622 * TIP #280 4623 *---------------------------------------------------------------------- 4624 */ 4625 4626void 4627TclArgumentRelease(interp,objv,objc) 4628 Tcl_Interp* interp; 4629 Tcl_Obj** objv; 4630 int objc; 4631{ 4632 Interp* iPtr = (Interp*) interp; 4633 Tcl_HashEntry* hPtr; 4634 CFWord* cfwPtr; 4635 int i; 4636 4637 for (i=1; i < objc; i++) { 4638 hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) objv[i]); 4639 4640 if (!hPtr) { continue; } 4641 cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr); 4642 4643 cfwPtr->refCount --; 4644 if (cfwPtr->refCount > 0) { continue; } 4645 4646 ckfree ((char*) cfwPtr); 4647 Tcl_DeleteHashEntry (hPtr); 4648 } 4649} 4650 4651/* 4652 *---------------------------------------------------------------------- 4653 * 4654 * TclArgumentBCEnter -- 4655 * 4656 * This procedure is a helper for the TIP #280 uplevel extension. 4657 * It enters location references for the literal arguments of commands 4658 * in bytecode about to be executed. Only the first entry has the actual 4659 * data, further entries simply count the usage up. 4660 * 4661 * Results: 4662 * None. 4663 * 4664 * Side effects: 4665 * May allocate memory. 4666 * 4667 * TIP #280 4668 *---------------------------------------------------------------------- 4669 */ 4670 4671void 4672TclArgumentBCEnter(interp, objv, objc, codePtr, cfPtr, pc) 4673 Tcl_Interp* interp; 4674 Tcl_Obj* objv[]; 4675 int objc; 4676 void* codePtr; 4677 CmdFrame* cfPtr; 4678 int pc; 4679{ 4680 Interp* iPtr = (Interp*) interp; 4681 Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); 4682 4683 if (hePtr) { 4684 ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); 4685 hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, (char*) pc); 4686 4687 if (hePtr) { 4688 int word; 4689 int cmd = (int) Tcl_GetHashValue(hePtr); 4690 ECL* ePtr = &eclPtr->loc[cmd]; 4691 4692 /* 4693 * A few truths ... 4694 * (1) ePtr->nline == objc 4695 * (2) (ePtr->line[word] < 0) => !literal, for all words 4696 * (3) (word == 0) => !literal 4697 * 4698 * Item (2) is why we can use objv to get the literals, and do not 4699 * have to save them at compile time. 4700 */ 4701 4702 for (word = 1; word < objc; word++) { 4703 if (ePtr->line[word] >= 0) { 4704 int isnew; 4705 Tcl_HashEntry* hPtr = 4706 Tcl_CreateHashEntry (iPtr->lineLABCPtr, 4707 (char*) objv[word], &isnew); 4708 CFWordBC* cfwPtr = (CFWordBC*) ckalloc (sizeof (CFWordBC)); 4709 4710 cfwPtr->framePtr = cfPtr; 4711 cfwPtr->pc = pc; 4712 cfwPtr->word = word; 4713 4714 if (isnew) { 4715 /* 4716 * The word is not on the stack yet, remember the 4717 * current location and initialize references. 4718 */ 4719 cfwPtr->prevPtr = NULL; 4720 } else { 4721 /* 4722 * The object is already on the stack, however it may 4723 * have a different location now (literal sharing may 4724 * map multiple location to a single Tcl_Obj*. Save 4725 * the old information in the new structure. 4726 */ 4727 cfwPtr->prevPtr = (CFWordBC*) Tcl_GetHashValue(hPtr); 4728 } 4729 4730 Tcl_SetHashValue (hPtr, cfwPtr); 4731 } 4732 } /* for */ 4733 } /* if */ 4734 } /* if */ 4735} 4736 4737/* 4738 *---------------------------------------------------------------------- 4739 * 4740 * TclArgumentBCRelease -- 4741 * 4742 * This procedure is a helper for the TIP #280 uplevel extension. 4743 * It removes the location references for the literal arguments of 4744 * commands in bytecode just done. Usage is counted down, the data 4745 * is removed only when no user is left over. 4746 * 4747 * Results: 4748 * None. 4749 * 4750 * Side effects: 4751 * May release memory. 4752 * 4753 * TIP #280 4754 *---------------------------------------------------------------------- 4755 */ 4756 4757void 4758TclArgumentBCRelease(interp, objv, objc, codePtr, pc) 4759 Tcl_Interp* interp; 4760 Tcl_Obj* objv[]; 4761 int objc; 4762 void* codePtr; 4763 int pc; 4764{ 4765 Interp* iPtr = (Interp*) interp; 4766 Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); 4767 4768 if (hePtr) { 4769 ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); 4770 hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, (char*) pc); 4771 4772 if (hePtr) { 4773 int cmd = (int) Tcl_GetHashValue(hePtr); 4774 ECL* ePtr = &eclPtr->loc[cmd]; 4775 int word; 4776 4777 /* 4778 * Iterate in reverse order, to properly match our pop to the push 4779 * in TclArgumentBCEnter(). 4780 */ 4781 for (word = objc-1; word >= 1; word--) { 4782 if (ePtr->line[word] >= 0) { 4783 Tcl_HashEntry* hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, 4784 (char *) objv[word]); 4785 if (hPtr) { 4786 CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr); 4787 4788 if (cfwPtr->prevPtr) { 4789 Tcl_SetHashValue(hPtr, cfwPtr->prevPtr); 4790 } else { 4791 Tcl_DeleteHashEntry(hPtr); 4792 } 4793 4794 ckfree((char *) cfwPtr); 4795 } 4796 } 4797 } 4798 } 4799 } 4800} 4801 4802/* 4803 *---------------------------------------------------------------------- 4804 * 4805 * TclArgumentGet -- 4806 * 4807 * This procedure is a helper for the TIP #280 uplevel extension. 4808 * It find the location references for a Tcl_Obj, if any. 4809 * 4810 * Results: 4811 * None. 4812 * 4813 * Side effects: 4814 * Writes found location information into the result arguments. 4815 * 4816 * TIP #280 4817 *---------------------------------------------------------------------- 4818 */ 4819 4820void 4821TclArgumentGet(interp,obj,cfPtrPtr,wordPtr) 4822 Tcl_Interp* interp; 4823 Tcl_Obj* obj; 4824 CmdFrame** cfPtrPtr; 4825 int* wordPtr; 4826{ 4827 Interp* iPtr = (Interp*) interp; 4828 Tcl_HashEntry* hPtr; 4829 CmdFrame* framePtr; 4830 4831 /* 4832 * An object which either has no string rep guaranteed to have been 4833 * generated dynamically: bail out, this cannot have a usable absolute 4834 * location. _Do not touch_ the information the set up by the caller. It 4835 * knows better than us. 4836 */ 4837 4838 if (!obj->bytes) { 4839 return; 4840 } 4841 4842 /* 4843 * First look for location information recorded in the argument 4844 * stack. That is nearest. 4845 */ 4846 4847 hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) obj); 4848 if (hPtr) { 4849 CFWord* cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr); 4850 *wordPtr = cfwPtr->word; 4851 *cfPtrPtr = cfwPtr->framePtr; 4852 return; 4853 } 4854 4855 /* 4856 * Check if the Tcl_Obj has location information as a bytecode literal, in 4857 * that stack. 4858 */ 4859 4860 hPtr = Tcl_FindHashEntry (iPtr->lineLABCPtr, (char *) obj); 4861 if (hPtr) { 4862 CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr); 4863 4864 framePtr = cfwPtr->framePtr; 4865 framePtr->data.tebc.pc = (char*) ((ByteCode*) 4866 framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc; 4867 *cfPtrPtr = cfwPtr->framePtr; 4868 *wordPtr = cfwPtr->word; 4869 return; 4870 } 4871} 4872#endif 4873 4874/* 4875 *---------------------------------------------------------------------- 4876 * 4877 * Tcl_Eval -- 4878 * 4879 * Execute a Tcl command in a string. This procedure executes the 4880 * script directly, rather than compiling it to bytecodes. Before 4881 * the arrival of the bytecode compiler in Tcl 8.0 Tcl_Eval was 4882 * the main procedure used for executing Tcl commands, but nowadays 4883 * it isn't used much. 4884 * 4885 * Results: 4886 * The return value is one of the return codes defined in tcl.h 4887 * (such as TCL_OK), and interp's result contains a value 4888 * to supplement the return code. The value of the result 4889 * will persist only until the next call to Tcl_Eval or Tcl_EvalObj: 4890 * you must copy it or lose it! 4891 * 4892 * Side effects: 4893 * Can be almost arbitrary, depending on the commands in the script. 4894 * 4895 *---------------------------------------------------------------------- 4896 */ 4897 4898int 4899Tcl_Eval(interp, string) 4900 Tcl_Interp *interp; /* Token for command interpreter (returned 4901 * by previous call to Tcl_CreateInterp). */ 4902 CONST char *string; /* Pointer to TCL command to execute. */ 4903{ 4904 int code = Tcl_EvalEx(interp, string, -1, 0); 4905 4906 /* 4907 * For backwards compatibility with old C code that predates the 4908 * object system in Tcl 8.0, we have to mirror the object result 4909 * back into the string result (some callers may expect it there). 4910 */ 4911 4912 Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), 4913 TCL_VOLATILE); 4914 return code; 4915} 4916 4917/* 4918 *---------------------------------------------------------------------- 4919 * 4920 * Tcl_EvalObj, Tcl_GlobalEvalObj -- 4921 * 4922 * These functions are deprecated but we keep them around for backwards 4923 * compatibility reasons. 4924 * 4925 * Results: 4926 * See the functions they call. 4927 * 4928 * Side effects: 4929 * See the functions they call. 4930 * 4931 *---------------------------------------------------------------------- 4932 */ 4933 4934#undef Tcl_EvalObj 4935int 4936Tcl_EvalObj(interp, objPtr) 4937 Tcl_Interp * interp; 4938 Tcl_Obj * objPtr; 4939{ 4940 return Tcl_EvalObjEx(interp, objPtr, 0); 4941} 4942 4943#undef Tcl_GlobalEvalObj 4944int 4945Tcl_GlobalEvalObj(interp, objPtr) 4946 Tcl_Interp * interp; 4947 Tcl_Obj * objPtr; 4948{ 4949 return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); 4950} 4951 4952/* 4953 *---------------------------------------------------------------------- 4954 * 4955 * Tcl_EvalObjEx, TclEvalObjEx -- 4956 * 4957 * Execute Tcl commands stored in a Tcl object. These commands are 4958 * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT 4959 * is specified. 4960 * 4961 * Results: 4962 * The return value is one of the return codes defined in tcl.h 4963 * (such as TCL_OK), and the interpreter's result contains a value 4964 * to supplement the return code. 4965 * 4966 * Side effects: 4967 * The object is converted, if necessary, to a ByteCode object that 4968 * holds the bytecode instructions for the commands. Executing the 4969 * commands will almost certainly have side effects that depend 4970 * on those commands. 4971 * 4972 * Just as in Tcl_Eval, interp->termOffset is set to the offset of the 4973 * last character executed in the objPtr's string. 4974 * 4975 * TIP #280 : Keep public API, internally extended API. 4976 *---------------------------------------------------------------------- 4977 */ 4978 4979int 4980Tcl_EvalObjEx(interp, objPtr, flags) 4981 Tcl_Interp *interp; /* Token for command interpreter 4982 * (returned by a previous call to 4983 * Tcl_CreateInterp). */ 4984 register Tcl_Obj *objPtr; /* Pointer to object containing 4985 * commands to execute. */ 4986 int flags; /* Collection of OR-ed bits that 4987 * control the evaluation of the 4988 * script. Supported values are 4989 * TCL_EVAL_GLOBAL and 4990 * TCL_EVAL_DIRECT. */ 4991{ 4992#ifdef TCL_TIP280 4993 return TclEvalObjEx (interp, objPtr, flags, NULL, 0); 4994} 4995 4996int 4997TclEvalObjEx(interp, objPtr, flags, invoker, word) 4998 Tcl_Interp *interp; /* Token for command interpreter 4999 * (returned by a previous call to 5000 * Tcl_CreateInterp). */ 5001 register Tcl_Obj *objPtr; /* Pointer to object containing 5002 * commands to execute. */ 5003 int flags; /* Collection of OR-ed bits that 5004 * control the evaluation of the 5005 * script. Supported values are 5006 * TCL_EVAL_GLOBAL and 5007 * TCL_EVAL_DIRECT. */ 5008 CONST CmdFrame* invoker; /* Frame of the command doing the eval */ 5009 int word; /* Index of the word which is in objPtr */ 5010{ 5011#endif 5012 register Interp *iPtr = (Interp *) interp; 5013 char *script; 5014 int numSrcBytes; 5015 int result; 5016 CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr 5017 * in case TCL_EVAL_GLOBAL was set. */ 5018 int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); 5019 5020 Tcl_IncrRefCount(objPtr); 5021 5022 if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) { 5023 /* 5024 * We're not supposed to use the compiler or byte-code interpreter. 5025 * Let Tcl_EvalEx evaluate the command directly (and probably 5026 * more slowly). 5027 * 5028 * Pure List Optimization (no string representation). In this 5029 * case, we can safely use Tcl_EvalObjv instead and get an 5030 * appreciable improvement in execution speed. This is because it 5031 * allows us to avoid a setFromAny step that would just pack 5032 * everything into a string and back out again. 5033 * 5034 * USE_EVAL_DIRECT is a special flag used for testing purpose only 5035 * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt) 5036 */ 5037 if (!(iPtr->flags & USE_EVAL_DIRECT) && 5038 (objPtr->typePtr == &tclListType) && /* is a list... */ 5039 (objPtr->bytes == NULL) /* ...without a string rep */) { 5040 register List *listRepPtr = 5041 (List *) objPtr->internalRep.twoPtrValue.ptr1; 5042 int i, objc = listRepPtr->elemCount; 5043 5044#define TEOE_PREALLOC 10 5045 Tcl_Obj *staticObjv[TEOE_PREALLOC], **objv = staticObjv; 5046 5047#ifdef TCL_TIP280 5048 /* TIP #280 Structures for tracking lines. 5049 * As we know that this is dynamic execution we ignore the 5050 * invoker, even if known. 5051 */ 5052 CmdFrame eoFrame; 5053 5054 eoFrame.type = TCL_LOCATION_EVAL_LIST; 5055 eoFrame.level = (iPtr->cmdFramePtr == NULL ? 5056 1 : 5057 iPtr->cmdFramePtr->level + 1); 5058 eoFrame.framePtr = iPtr->framePtr; 5059 eoFrame.nextPtr = iPtr->cmdFramePtr; 5060 eoFrame.nline = 0; 5061 eoFrame.line = NULL; 5062 5063 /* NOTE: Getting the string rep of the list to eval to fill the 5064 * command information required by 'info frame' implies that 5065 * further calls for the same list would not be optimized, as it 5066 * would not be 'pure' anymore. It would also be a waste of time 5067 * as most of the time this information is not needed at all. What 5068 * we do instead is to keep the list obj itself around and have 5069 * 'info frame' sort it out. 5070 */ 5071 5072 eoFrame.cmd.listPtr = objPtr; 5073 Tcl_IncrRefCount (eoFrame.cmd.listPtr); 5074 eoFrame.data.eval.path = NULL; 5075#endif 5076 if (objc > TEOE_PREALLOC) { 5077 objv = (Tcl_Obj **) ckalloc(objc*sizeof(Tcl_Obj *)); 5078 } 5079#undef TEOE_PREALLOC 5080 /* 5081 * Copy the list elements here, to avoid a segfault if 5082 * objPtr loses its List internal rep [Bug 1119369]. 5083 * 5084 * TIP #280 We do _not_ compute all the line numbers for the words 5085 * in the command. For the eval of a pure list the most sensible 5086 * choice is to put all words on line 1. Given that we neither 5087 * need memory for them nor compute anything. 'line' is left 5088 * NULL. The two places using this information (TclInfoFrame, and 5089 * TclInitCompileEnv), are special-cased to use the proper line 5090 * number directly instead of accessing the 'line' array. 5091 */ 5092 5093 for (i=0; i < objc; i++) { 5094 objv[i] = listRepPtr->elements[i]; 5095 Tcl_IncrRefCount(objv[i]); 5096 } 5097 5098#ifdef TCL_TIP280 5099 iPtr->cmdFramePtr = &eoFrame; 5100#endif 5101 result = Tcl_EvalObjv(interp, objc, objv, flags); 5102#ifdef TCL_TIP280 5103 iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; 5104 Tcl_DecrRefCount (eoFrame.cmd.listPtr); 5105#endif 5106 5107 for (i=0; i < objc; i++) { 5108 TclDecrRefCount(objv[i]); 5109 } 5110 if (objv != staticObjv) { 5111 ckfree((char *) objv); 5112 } 5113#ifdef TCL_TIP280 5114 ckfree ((char*) eoFrame.line); 5115 eoFrame.line = NULL; 5116 eoFrame.nline = 0; 5117#endif 5118 } else { 5119#ifndef TCL_TIP280 5120 script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); 5121 result = Tcl_EvalEx(interp, script, numSrcBytes, flags); 5122#else 5123 /* 5124 * TIP #280. Propagate context as much as we can. Especially if 5125 * the script to evaluate is a single literal it makes sense to 5126 * look if our context is one with absolute line numbers we can 5127 * then track into the literal itself too. 5128 * 5129 * See also tclCompile.c, TclInitCompileEnv, for the equivalent 5130 * code in the bytecode compiler. 5131 */ 5132 5133 /* 5134 * Now we check if we have data about invisible continuation lines 5135 * for the script, and make it available to the direct script 5136 * parser and evaluator we are about to call, if so. 5137 * 5138 * It may be possible that the script Tcl_Obj* can be free'd while 5139 * the evaluator is using it, leading to the release of the 5140 * associated ContLineLoc structure as well. To ensure that the 5141 * latter doesn't happen we set a lock on it. We release this lock 5142 * later in this function, after the evaluator is done. The 5143 * relevant "lineCLPtr" hashtable is managed in the file 5144 * "tclObj.c". 5145 * 5146 * Another important action is to save (and later restore) the 5147 * continuation line information of the caller, in case we are 5148 * executing nested commands in the eval/direct path. 5149 */ 5150 5151 ContLineLoc* saveCLLocPtr = iPtr->scriptCLLocPtr; 5152 ContLineLoc* clLocPtr = TclContinuationsGet (objPtr); 5153 5154 if (clLocPtr) { 5155 iPtr->scriptCLLocPtr = clLocPtr; 5156 Tcl_Preserve (iPtr->scriptCLLocPtr); 5157 } else { 5158 iPtr->scriptCLLocPtr = NULL; 5159 } 5160 5161 if (invoker == NULL) { 5162 /* No context, force opening of our own */ 5163 script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); 5164 result = Tcl_EvalEx(interp, script, numSrcBytes, flags); 5165 } else { 5166 /* We have an invoker, describing the command asking for the 5167 * evaluation of a subordinate script. This script may 5168 * originate in a literal word, or from a variable, etc. Using 5169 * the line array we now check if we have good line 5170 * information for the relevant word. The type of context is 5171 * relevant as well. In a non-'source' context we don't have 5172 * to try tracking lines. 5173 * 5174 * First see if the word exists and is a literal. If not we go 5175 * through the easy dynamic branch. No need to perform more 5176 * complex invokations. 5177 */ 5178 5179 CmdFrame ctx = *invoker; 5180 int pc = 0; 5181 5182 if (invoker->type == TCL_LOCATION_BC) { 5183 /* Note: Type BC => ctx.data.eval.path is not used. 5184 * ctx.data.tebc.codePtr is used instead. 5185 */ 5186 TclGetSrcInfoForPc (&ctx); 5187 pc = 1; 5188 } 5189 5190 script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); 5191 5192 if ((ctx.nline <= word) || 5193 (ctx.line[word] < 0) || 5194 (ctx.type != TCL_LOCATION_SOURCE)) { 5195 /* Dynamic script, or dynamic context, force our own 5196 * context */ 5197 5198 result = Tcl_EvalEx(interp, script, numSrcBytes, flags); 5199 } else { 5200 /* Absolute context available to reuse. */ 5201 5202 iPtr->invokeCmdFramePtr = &ctx; 5203 iPtr->evalFlags |= TCL_EVAL_CTX; 5204 5205 result = EvalEx(interp, script, numSrcBytes, flags, 5206 ctx.line [word], NULL, script); 5207 } 5208 if (pc && (ctx.type == TCL_LOCATION_SOURCE)) { 5209 /* Death of SrcInfo reference. */ 5210 Tcl_DecrRefCount(ctx.data.eval.path); 5211 } 5212 } 5213 5214 /* 5215 * Now release the lock on the continuation line information, if 5216 * any, and restore the caller's settings. 5217 */ 5218 5219 if (iPtr->scriptCLLocPtr) { 5220 Tcl_Release (iPtr->scriptCLLocPtr); 5221 } 5222 iPtr->scriptCLLocPtr = saveCLLocPtr; 5223#endif 5224 } 5225 } else { 5226 /* 5227 * Let the compiler/engine subsystem do the evaluation. 5228 * 5229 * TIP #280 The invoker provides us with the context for the 5230 * script. We transfer this to the byte code compiler. 5231 */ 5232 5233 savedVarFramePtr = iPtr->varFramePtr; 5234 if (flags & TCL_EVAL_GLOBAL) { 5235 iPtr->varFramePtr = NULL; 5236 } 5237 5238#ifndef TCL_TIP280 5239 result = TclCompEvalObj(interp, objPtr); 5240#else 5241 result = TclCompEvalObj(interp, objPtr, invoker, word); 5242#endif 5243 5244 /* 5245 * If we are again at the top level, process any unusual 5246 * return code returned by the evaluated code. 5247 */ 5248 5249 if (iPtr->numLevels == 0) { 5250 if (result == TCL_RETURN) { 5251 result = TclUpdateReturnInfo(iPtr); 5252 } 5253 if ((result != TCL_OK) && (result != TCL_ERROR) 5254 && !allowExceptions) { 5255 ProcessUnexpectedResult(interp, result); 5256 result = TCL_ERROR; 5257 5258 /* 5259 * If an error was created here, record information about 5260 * what was being executed when the error occurred. Remove 5261 * the extra \n added by tclMain.c in the command sent to 5262 * Tcl_LogCommandInfo [Bug 833150]. 5263 */ 5264 5265 if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { 5266 script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); 5267 Tcl_LogCommandInfo(interp, script, script, --numSrcBytes); 5268 iPtr->flags &= ~ERR_ALREADY_LOGGED; 5269 } 5270 } 5271 } 5272 iPtr->evalFlags = 0; 5273 iPtr->varFramePtr = savedVarFramePtr; 5274 } 5275 5276 TclDecrRefCount(objPtr); 5277 return result; 5278} 5279 5280/* 5281 *---------------------------------------------------------------------- 5282 * 5283 * ProcessUnexpectedResult -- 5284 * 5285 * Procedure called by Tcl_EvalObj to set the interpreter's result 5286 * value to an appropriate error message when the code it evaluates 5287 * returns an unexpected result code (not TCL_OK and not TCL_ERROR) to 5288 * the topmost evaluation level. 5289 * 5290 * Results: 5291 * None. 5292 * 5293 * Side effects: 5294 * The interpreter result is set to an error message appropriate to 5295 * the result code. 5296 * 5297 *---------------------------------------------------------------------- 5298 */ 5299 5300static void 5301ProcessUnexpectedResult(interp, returnCode) 5302 Tcl_Interp *interp; /* The interpreter in which the unexpected 5303 * result code was returned. */ 5304 int returnCode; /* The unexpected result code. */ 5305{ 5306 Tcl_ResetResult(interp); 5307 if (returnCode == TCL_BREAK) { 5308 Tcl_AppendToObj(Tcl_GetObjResult(interp), 5309 "invoked \"break\" outside of a loop", -1); 5310 } else if (returnCode == TCL_CONTINUE) { 5311 Tcl_AppendToObj(Tcl_GetObjResult(interp), 5312 "invoked \"continue\" outside of a loop", -1); 5313 } else { 5314 char buf[30 + TCL_INTEGER_SPACE]; 5315 5316 sprintf(buf, "command returned bad code: %d", returnCode); 5317 Tcl_SetResult(interp, buf, TCL_VOLATILE); 5318 } 5319} 5320 5321/* 5322 *--------------------------------------------------------------------------- 5323 * 5324 * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- 5325 * 5326 * Procedures to evaluate an expression and return its value in a 5327 * particular form. 5328 * 5329 * Results: 5330 * Each of the procedures below returns a standard Tcl result. If an 5331 * error occurs then an error message is left in the interp's result. 5332 * Otherwise the value of the expression, in the appropriate form, 5333 * is stored at *ptr. If the expression had a result that was 5334 * incompatible with the desired form then an error is returned. 5335 * 5336 * Side effects: 5337 * None. 5338 * 5339 *--------------------------------------------------------------------------- 5340 */ 5341 5342int 5343Tcl_ExprLong(interp, string, ptr) 5344 Tcl_Interp *interp; /* Context in which to evaluate the 5345 * expression. */ 5346 CONST char *string; /* Expression to evaluate. */ 5347 long *ptr; /* Where to store result. */ 5348{ 5349 register Tcl_Obj *exprPtr; 5350 Tcl_Obj *resultPtr; 5351 int length = strlen(string); 5352 int result = TCL_OK; 5353 5354 if (length > 0) { 5355 exprPtr = Tcl_NewStringObj(string, length); 5356 Tcl_IncrRefCount(exprPtr); 5357 result = Tcl_ExprObj(interp, exprPtr, &resultPtr); 5358 if (result == TCL_OK) { 5359 /* 5360 * Store an integer based on the expression result. 5361 */ 5362 5363 if (resultPtr->typePtr == &tclIntType) { 5364 *ptr = resultPtr->internalRep.longValue; 5365 } else if (resultPtr->typePtr == &tclDoubleType) { 5366 *ptr = (long) resultPtr->internalRep.doubleValue; 5367 } else if (resultPtr->typePtr == &tclWideIntType) { 5368#ifndef TCL_WIDE_INT_IS_LONG 5369 /* 5370 * See Tcl_GetIntFromObj for conversion comments. 5371 */ 5372 Tcl_WideInt w = resultPtr->internalRep.wideValue; 5373 if ((w >= -(Tcl_WideInt)(ULONG_MAX)) 5374 && (w <= (Tcl_WideInt)(ULONG_MAX))) { 5375 *ptr = Tcl_WideAsLong(w); 5376 } else { 5377 Tcl_SetResult(interp, 5378 "integer value too large to represent as non-long integer", 5379 TCL_STATIC); 5380 result = TCL_ERROR; 5381 } 5382#else 5383 *ptr = resultPtr->internalRep.longValue; 5384#endif 5385 } else { 5386 Tcl_SetResult(interp, 5387 "expression didn't have numeric value", TCL_STATIC); 5388 result = TCL_ERROR; 5389 } 5390 Tcl_DecrRefCount(resultPtr); /* discard the result object */ 5391 } else { 5392 /* 5393 * Move the interpreter's object result to the string result, 5394 * then reset the object result. 5395 */ 5396 5397 Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), 5398 TCL_VOLATILE); 5399 } 5400 Tcl_DecrRefCount(exprPtr); /* discard the expression object */ 5401 } else { 5402 /* 5403 * An empty string. Just set the result integer to 0. 5404 */ 5405 5406 *ptr = 0; 5407 } 5408 return result; 5409} 5410 5411int 5412Tcl_ExprDouble(interp, string, ptr) 5413 Tcl_Interp *interp; /* Context in which to evaluate the 5414 * expression. */ 5415 CONST char *string; /* Expression to evaluate. */ 5416 double *ptr; /* Where to store result. */ 5417{ 5418 register Tcl_Obj *exprPtr; 5419 Tcl_Obj *resultPtr; 5420 int length = strlen(string); 5421 int result = TCL_OK; 5422 5423 if (length > 0) { 5424 exprPtr = Tcl_NewStringObj(string, length); 5425 Tcl_IncrRefCount(exprPtr); 5426 result = Tcl_ExprObj(interp, exprPtr, &resultPtr); 5427 if (result == TCL_OK) { 5428 /* 5429 * Store a double based on the expression result. 5430 */ 5431 5432 if (resultPtr->typePtr == &tclIntType) { 5433 *ptr = (double) resultPtr->internalRep.longValue; 5434 } else if (resultPtr->typePtr == &tclDoubleType) { 5435 *ptr = resultPtr->internalRep.doubleValue; 5436 } else if (resultPtr->typePtr == &tclWideIntType) { 5437#ifndef TCL_WIDE_INT_IS_LONG 5438 /* 5439 * See Tcl_GetIntFromObj for conversion comments. 5440 */ 5441 Tcl_WideInt w = resultPtr->internalRep.wideValue; 5442 if ((w >= -(Tcl_WideInt)(ULONG_MAX)) 5443 && (w <= (Tcl_WideInt)(ULONG_MAX))) { 5444 *ptr = (double) Tcl_WideAsLong(w); 5445 } else { 5446 Tcl_SetResult(interp, 5447 "integer value too large to represent as non-long integer", 5448 TCL_STATIC); 5449 result = TCL_ERROR; 5450 } 5451#else 5452 *ptr = (double) resultPtr->internalRep.longValue; 5453#endif 5454 } else { 5455 Tcl_SetResult(interp, 5456 "expression didn't have numeric value", TCL_STATIC); 5457 result = TCL_ERROR; 5458 } 5459 Tcl_DecrRefCount(resultPtr); /* discard the result object */ 5460 } else { 5461 /* 5462 * Move the interpreter's object result to the string result, 5463 * then reset the object result. 5464 */ 5465 5466 Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), 5467 TCL_VOLATILE); 5468 } 5469 Tcl_DecrRefCount(exprPtr); /* discard the expression object */ 5470 } else { 5471 /* 5472 * An empty string. Just set the result double to 0.0. 5473 */ 5474 5475 *ptr = 0.0; 5476 } 5477 return result; 5478} 5479 5480int 5481Tcl_ExprBoolean(interp, string, ptr) 5482 Tcl_Interp *interp; /* Context in which to evaluate the 5483 * expression. */ 5484 CONST char *string; /* Expression to evaluate. */ 5485 int *ptr; /* Where to store 0/1 result. */ 5486{ 5487 register Tcl_Obj *exprPtr; 5488 Tcl_Obj *resultPtr; 5489 int length = strlen(string); 5490 int result = TCL_OK; 5491 5492 if (length > 0) { 5493 exprPtr = Tcl_NewStringObj(string, length); 5494 Tcl_IncrRefCount(exprPtr); 5495 result = Tcl_ExprObj(interp, exprPtr, &resultPtr); 5496 if (result == TCL_OK) { 5497 /* 5498 * Store a boolean based on the expression result. 5499 */ 5500 5501 if (resultPtr->typePtr == &tclIntType) { 5502 *ptr = (resultPtr->internalRep.longValue != 0); 5503 } else if (resultPtr->typePtr == &tclDoubleType) { 5504 *ptr = (resultPtr->internalRep.doubleValue != 0.0); 5505 } else if (resultPtr->typePtr == &tclWideIntType) { 5506#ifndef TCL_WIDE_INT_IS_LONG 5507 *ptr = (resultPtr->internalRep.wideValue != 0); 5508#else 5509 *ptr = (resultPtr->internalRep.longValue != 0); 5510#endif 5511 } else { 5512 result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); 5513 } 5514 Tcl_DecrRefCount(resultPtr); /* discard the result object */ 5515 } 5516 if (result != TCL_OK) { 5517 /* 5518 * Move the interpreter's object result to the string result, 5519 * then reset the object result. 5520 */ 5521 5522 Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), 5523 TCL_VOLATILE); 5524 } 5525 Tcl_DecrRefCount(exprPtr); /* discard the expression object */ 5526 } else { 5527 /* 5528 * An empty string. Just set the result boolean to 0 (false). 5529 */ 5530 5531 *ptr = 0; 5532 } 5533 return result; 5534} 5535 5536/* 5537 *-------------------------------------------------------------- 5538 * 5539 * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj -- 5540 * 5541 * Procedures to evaluate an expression in an object and return its 5542 * value in a particular form. 5543 * 5544 * Results: 5545 * Each of the procedures below returns a standard Tcl result 5546 * object. If an error occurs then an error message is left in the 5547 * interpreter's result. Otherwise the value of the expression, in the 5548 * appropriate form, is stored at *ptr. If the expression had a result 5549 * that was incompatible with the desired form then an error is 5550 * returned. 5551 * 5552 * Side effects: 5553 * None. 5554 * 5555 *-------------------------------------------------------------- 5556 */ 5557 5558int 5559Tcl_ExprLongObj(interp, objPtr, ptr) 5560 Tcl_Interp *interp; /* Context in which to evaluate the 5561 * expression. */ 5562 register Tcl_Obj *objPtr; /* Expression to evaluate. */ 5563 long *ptr; /* Where to store long result. */ 5564{ 5565 Tcl_Obj *resultPtr; 5566 int result; 5567 5568 result = Tcl_ExprObj(interp, objPtr, &resultPtr); 5569 if (result == TCL_OK) { 5570 if (resultPtr->typePtr == &tclIntType) { 5571 *ptr = resultPtr->internalRep.longValue; 5572 } else if (resultPtr->typePtr == &tclDoubleType) { 5573 *ptr = (long) resultPtr->internalRep.doubleValue; 5574 } else { 5575 result = Tcl_GetLongFromObj(interp, resultPtr, ptr); 5576 if (result != TCL_OK) { 5577 return result; 5578 } 5579 } 5580 Tcl_DecrRefCount(resultPtr); /* discard the result object */ 5581 } 5582 return result; 5583} 5584 5585int 5586Tcl_ExprDoubleObj(interp, objPtr, ptr) 5587 Tcl_Interp *interp; /* Context in which to evaluate the 5588 * expression. */ 5589 register Tcl_Obj *objPtr; /* Expression to evaluate. */ 5590 double *ptr; /* Where to store double result. */ 5591{ 5592 Tcl_Obj *resultPtr; 5593 int result; 5594 5595 result = Tcl_ExprObj(interp, objPtr, &resultPtr); 5596 if (result == TCL_OK) { 5597 if (resultPtr->typePtr == &tclIntType) { 5598 *ptr = (double) resultPtr->internalRep.longValue; 5599 } else if (resultPtr->typePtr == &tclDoubleType) { 5600 *ptr = resultPtr->internalRep.doubleValue; 5601 } else { 5602 result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr); 5603 if (result != TCL_OK) { 5604 return result; 5605 } 5606 } 5607 Tcl_DecrRefCount(resultPtr); /* discard the result object */ 5608 } 5609 return result; 5610} 5611 5612int 5613Tcl_ExprBooleanObj(interp, objPtr, ptr) 5614 Tcl_Interp *interp; /* Context in which to evaluate the 5615 * expression. */ 5616 register Tcl_Obj *objPtr; /* Expression to evaluate. */ 5617 int *ptr; /* Where to store 0/1 result. */ 5618{ 5619 Tcl_Obj *resultPtr; 5620 int result; 5621 5622 result = Tcl_ExprObj(interp, objPtr, &resultPtr); 5623 if (result == TCL_OK) { 5624 if (resultPtr->typePtr == &tclIntType) { 5625 *ptr = (resultPtr->internalRep.longValue != 0); 5626 } else if (resultPtr->typePtr == &tclDoubleType) { 5627 *ptr = (resultPtr->internalRep.doubleValue != 0.0); 5628 } else { 5629 result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); 5630 } 5631 Tcl_DecrRefCount(resultPtr); /* discard the result object */ 5632 } 5633 return result; 5634} 5635 5636/* 5637 *---------------------------------------------------------------------- 5638 * 5639 * TclInvoke -- 5640 * 5641 * Invokes a Tcl command, given an argv/argc, from either the 5642 * exposed or the hidden sets of commands in the given interpreter. 5643 * NOTE: The command is invoked in the current stack frame of 5644 * the interpreter, thus it can modify local variables. 5645 * 5646 * Results: 5647 * A standard Tcl result. 5648 * 5649 * Side effects: 5650 * Whatever the command does. 5651 * 5652 *---------------------------------------------------------------------- 5653 */ 5654 5655int 5656TclInvoke(interp, argc, argv, flags) 5657 Tcl_Interp *interp; /* Where to invoke the command. */ 5658 int argc; /* Count of args. */ 5659 register CONST char **argv; /* The arg strings; argv[0] is the name of 5660 * the command to invoke. */ 5661 int flags; /* Combination of flags controlling the 5662 * call: TCL_INVOKE_HIDDEN and 5663 * TCL_INVOKE_NO_UNKNOWN. */ 5664{ 5665 register Tcl_Obj *objPtr; 5666 register int i; 5667 int length, result; 5668 5669 /* 5670 * This procedure generates an objv array for object arguments that hold 5671 * the argv strings. It starts out with stack-allocated space but uses 5672 * dynamically-allocated storage if needed. 5673 */ 5674 5675#define NUM_ARGS 20 5676 Tcl_Obj *(objStorage[NUM_ARGS]); 5677 register Tcl_Obj **objv = objStorage; 5678 5679 /* 5680 * Create the object argument array "objv". Make sure objv is large 5681 * enough to hold the objc arguments plus 1 extra for the zero 5682 * end-of-objv word. 5683 */ 5684 5685 if ((argc + 1) > NUM_ARGS) { 5686 objv = (Tcl_Obj **) 5687 ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); 5688 } 5689 5690 for (i = 0; i < argc; i++) { 5691 length = strlen(argv[i]); 5692 objv[i] = Tcl_NewStringObj(argv[i], length); 5693 Tcl_IncrRefCount(objv[i]); 5694 } 5695 objv[argc] = 0; 5696 5697 /* 5698 * Use TclObjInterpProc to actually invoke the command. 5699 */ 5700 5701 result = TclObjInvoke(interp, argc, objv, flags); 5702 5703 /* 5704 * Move the interpreter's object result to the string result, 5705 * then reset the object result. 5706 */ 5707 5708 Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), 5709 TCL_VOLATILE); 5710 5711 /* 5712 * Decrement the ref counts on the objv elements since we are done 5713 * with them. 5714 */ 5715 5716 for (i = 0; i < argc; i++) { 5717 objPtr = objv[i]; 5718 Tcl_DecrRefCount(objPtr); 5719 } 5720 5721 /* 5722 * Free the objv array if malloc'ed storage was used. 5723 */ 5724 5725 if (objv != objStorage) { 5726 ckfree((char *) objv); 5727 } 5728 return result; 5729#undef NUM_ARGS 5730} 5731 5732/* 5733 *---------------------------------------------------------------------- 5734 * 5735 * TclGlobalInvoke -- 5736 * 5737 * Invokes a Tcl command, given an argv/argc, from either the 5738 * exposed or hidden sets of commands in the given interpreter. 5739 * NOTE: The command is invoked in the global stack frame of 5740 * the interpreter, thus it cannot see any current state on 5741 * the stack for that interpreter. 5742 * 5743 * Results: 5744 * A standard Tcl result. 5745 * 5746 * Side effects: 5747 * Whatever the command does. 5748 * 5749 *---------------------------------------------------------------------- 5750 */ 5751 5752int 5753TclGlobalInvoke(interp, argc, argv, flags) 5754 Tcl_Interp *interp; /* Where to invoke the command. */ 5755 int argc; /* Count of args. */ 5756 register CONST char **argv; /* The arg strings; argv[0] is the name of 5757 * the command to invoke. */ 5758 int flags; /* Combination of flags controlling the 5759 * call: TCL_INVOKE_HIDDEN and 5760 * TCL_INVOKE_NO_UNKNOWN. */ 5761{ 5762 register Interp *iPtr = (Interp *) interp; 5763 int result; 5764 CallFrame *savedVarFramePtr; 5765 5766 savedVarFramePtr = iPtr->varFramePtr; 5767 iPtr->varFramePtr = NULL; 5768 result = TclInvoke(interp, argc, argv, flags); 5769 iPtr->varFramePtr = savedVarFramePtr; 5770 return result; 5771} 5772 5773/* 5774 *---------------------------------------------------------------------- 5775 * 5776 * TclObjInvokeGlobal -- 5777 * 5778 * Object version: Invokes a Tcl command, given an objv/objc, from 5779 * either the exposed or hidden set of commands in the given 5780 * interpreter. 5781 * NOTE: The command is invoked in the global stack frame of the 5782 * interpreter, thus it cannot see any current state on the 5783 * stack of that interpreter. 5784 * 5785 * Results: 5786 * A standard Tcl result. 5787 * 5788 * Side effects: 5789 * Whatever the command does. 5790 * 5791 *---------------------------------------------------------------------- 5792 */ 5793 5794int 5795TclObjInvokeGlobal(interp, objc, objv, flags) 5796 Tcl_Interp *interp; /* Interpreter in which command is to be 5797 * invoked. */ 5798 int objc; /* Count of arguments. */ 5799 Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the 5800 * name of the command to invoke. */ 5801 int flags; /* Combination of flags controlling the 5802 * call: TCL_INVOKE_HIDDEN, 5803 * TCL_INVOKE_NO_UNKNOWN, or 5804 * TCL_INVOKE_NO_TRACEBACK. */ 5805{ 5806 register Interp *iPtr = (Interp *) interp; 5807 int result; 5808 CallFrame *savedVarFramePtr; 5809 5810 savedVarFramePtr = iPtr->varFramePtr; 5811 iPtr->varFramePtr = NULL; 5812 result = TclObjInvoke(interp, objc, objv, flags); 5813 iPtr->varFramePtr = savedVarFramePtr; 5814 return result; 5815} 5816 5817/* 5818 *---------------------------------------------------------------------- 5819 * 5820 * TclObjInvoke -- 5821 * 5822 * Invokes a Tcl command, given an objv/objc, from either the 5823 * exposed or the hidden sets of commands in the given interpreter. 5824 * 5825 * Results: 5826 * A standard Tcl object result. 5827 * 5828 * Side effects: 5829 * Whatever the command does. 5830 * 5831 *---------------------------------------------------------------------- 5832 */ 5833 5834int 5835TclObjInvoke(interp, objc, objv, flags) 5836 Tcl_Interp *interp; /* Interpreter in which command is to be 5837 * invoked. */ 5838 int objc; /* Count of arguments. */ 5839 Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the 5840 * name of the command to invoke. */ 5841 int flags; /* Combination of flags controlling the 5842 * call: TCL_INVOKE_HIDDEN, 5843 * TCL_INVOKE_NO_UNKNOWN, or 5844 * TCL_INVOKE_NO_TRACEBACK. */ 5845{ 5846 register Interp *iPtr = (Interp *) interp; 5847 Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ 5848 char *cmdName; /* Name of the command from objv[0]. */ 5849 register Tcl_HashEntry *hPtr; 5850 Tcl_Command cmd; 5851 Command *cmdPtr; 5852 int localObjc; /* Used to invoke "unknown" if the */ 5853 Tcl_Obj **localObjv = NULL; /* command is not found. */ 5854 register int i; 5855 int result; 5856 5857 if (interp == (Tcl_Interp *) NULL) { 5858 return TCL_ERROR; 5859 } 5860 5861 if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) { 5862 Tcl_AppendToObj(Tcl_GetObjResult(interp), 5863 "illegal argument vector", -1); 5864 return TCL_ERROR; 5865 } 5866 5867 cmdName = Tcl_GetString(objv[0]); 5868 if (flags & TCL_INVOKE_HIDDEN) { 5869 /* 5870 * We never invoke "unknown" for hidden commands. 5871 */ 5872 5873 hPtr = NULL; 5874 hTblPtr = ((Interp *) interp)->hiddenCmdTablePtr; 5875 if (hTblPtr != NULL) { 5876 hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); 5877 } 5878 if (hPtr == NULL) { 5879 Tcl_ResetResult(interp); 5880 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 5881 "invalid hidden command name \"", cmdName, "\"", 5882 (char *) NULL); 5883 return TCL_ERROR; 5884 } 5885 cmdPtr = (Command *) Tcl_GetHashValue(hPtr); 5886 } else { 5887 cmdPtr = NULL; 5888 cmd = Tcl_FindCommand(interp, cmdName, 5889 (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); 5890 if (cmd != (Tcl_Command) NULL) { 5891 cmdPtr = (Command *) cmd; 5892 } 5893 if (cmdPtr == NULL) { 5894 if (!(flags & TCL_INVOKE_NO_UNKNOWN)) { 5895 cmd = Tcl_FindCommand(interp, "unknown", 5896 (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); 5897 if (cmd != (Tcl_Command) NULL) { 5898 cmdPtr = (Command *) cmd; 5899 } 5900 if (cmdPtr != NULL) { 5901 localObjc = (objc + 1); 5902 localObjv = (Tcl_Obj **) 5903 ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc)); 5904 localObjv[0] = Tcl_NewStringObj("unknown", -1); 5905 Tcl_IncrRefCount(localObjv[0]); 5906 for (i = 0; i < objc; i++) { 5907 localObjv[i+1] = objv[i]; 5908 } 5909 objc = localObjc; 5910 objv = localObjv; 5911 } 5912 } 5913 5914 /* 5915 * Check again if we found the command. If not, "unknown" is 5916 * not present and we cannot help, or the caller said not to 5917 * call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN). 5918 */ 5919 5920 if (cmdPtr == NULL) { 5921 Tcl_ResetResult(interp); 5922 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 5923 "invalid command name \"", cmdName, "\"", 5924 (char *) NULL); 5925 return TCL_ERROR; 5926 } 5927 } 5928 } 5929 5930 /* 5931 * Invoke the command procedure. First reset the interpreter's string 5932 * and object results to their default empty values since they could 5933 * have gotten changed by earlier invocations. 5934 */ 5935 5936 Tcl_ResetResult(interp); 5937 iPtr->cmdCount++; 5938 result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); 5939 5940 /* 5941 * If an error occurred, record information about what was being 5942 * executed when the error occurred. 5943 */ 5944 5945 if ((result == TCL_ERROR) 5946 && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) 5947 && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { 5948 Tcl_Obj *msg; 5949 5950 if (!(iPtr->flags & ERR_IN_PROGRESS)) { 5951 msg = Tcl_NewStringObj("\n while invoking\n\"", -1); 5952 } else { 5953 msg = Tcl_NewStringObj("\n invoked from within\n\"", -1); 5954 } 5955 Tcl_IncrRefCount(msg); 5956 for (i = 0; i < objc; i++) { 5957 CONST char *bytes; 5958 int length; 5959 5960 Tcl_AppendObjToObj(msg, objv[i]); 5961 bytes = Tcl_GetStringFromObj(msg, &length); 5962 if (length > 100) { 5963 /* 5964 * Back up truncation point so that we don't truncate 5965 * in the middle of a multi-byte character. 5966 */ 5967 length = 100; 5968 while ( (bytes[length] & 0xC0) == 0x80 ) { 5969 length--; 5970 } 5971 Tcl_SetObjLength(msg, length); 5972 Tcl_AppendToObj(msg, "...", -1); 5973 break; 5974 } 5975 if (i != (objc - 1)) { 5976 Tcl_AppendToObj(msg, " ", -1); 5977 } 5978 } 5979 5980 Tcl_AppendToObj(msg, "\"", -1); 5981 Tcl_AddObjErrorInfo(interp, Tcl_GetString(msg), -1); 5982 Tcl_DecrRefCount(msg); 5983 iPtr->flags &= ~ERR_ALREADY_LOGGED; 5984 } 5985 5986 /* 5987 * Free any locally allocated storage used to call "unknown". 5988 */ 5989 5990 if (localObjv != (Tcl_Obj **) NULL) { 5991 Tcl_DecrRefCount(localObjv[0]); 5992 ckfree((char *) localObjv); 5993 } 5994 return result; 5995} 5996 5997/* 5998 *--------------------------------------------------------------------------- 5999 * 6000 * Tcl_ExprString -- 6001 * 6002 * Evaluate an expression in a string and return its value in string 6003 * form. 6004 * 6005 * Results: 6006 * A standard Tcl result. If the result is TCL_OK, then the interp's 6007 * result is set to the string value of the expression. If the result 6008 * is TCL_ERROR, then the interp's result contains an error message. 6009 * 6010 * Side effects: 6011 * A Tcl object is allocated to hold a copy of the expression string. 6012 * This expression object is passed to Tcl_ExprObj and then 6013 * deallocated. 6014 * 6015 *--------------------------------------------------------------------------- 6016 */ 6017 6018int 6019Tcl_ExprString(interp, string) 6020 Tcl_Interp *interp; /* Context in which to evaluate the 6021 * expression. */ 6022 CONST char *string; /* Expression to evaluate. */ 6023{ 6024 register Tcl_Obj *exprPtr; 6025 Tcl_Obj *resultPtr; 6026 int length = strlen(string); 6027 char buf[TCL_DOUBLE_SPACE]; 6028 int result = TCL_OK; 6029 6030 if (length > 0) { 6031 TclNewObj(exprPtr); 6032 TclInitStringRep(exprPtr, string, length); 6033 Tcl_IncrRefCount(exprPtr); 6034 6035 result = Tcl_ExprObj(interp, exprPtr, &resultPtr); 6036 if (result == TCL_OK) { 6037 /* 6038 * Set the interpreter's string result from the result object. 6039 */ 6040 6041 if (resultPtr->typePtr == &tclIntType) { 6042 sprintf(buf, "%ld", resultPtr->internalRep.longValue); 6043 Tcl_SetResult(interp, buf, TCL_VOLATILE); 6044 } else if (resultPtr->typePtr == &tclDoubleType) { 6045 Tcl_PrintDouble((Tcl_Interp *) NULL, 6046 resultPtr->internalRep.doubleValue, buf); 6047 Tcl_SetResult(interp, buf, TCL_VOLATILE); 6048 } else { 6049 /* 6050 * Set interpreter's string result from the result object. 6051 */ 6052 6053 Tcl_SetResult(interp, TclGetString(resultPtr), 6054 TCL_VOLATILE); 6055 } 6056 Tcl_DecrRefCount(resultPtr); /* discard the result object */ 6057 } else { 6058 /* 6059 * Move the interpreter's object result to the string result, 6060 * then reset the object result. 6061 */ 6062 6063 Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), 6064 TCL_VOLATILE); 6065 } 6066 Tcl_DecrRefCount(exprPtr); /* discard the expression object */ 6067 } else { 6068 /* 6069 * An empty string. Just set the interpreter's result to 0. 6070 */ 6071 6072 Tcl_SetResult(interp, "0", TCL_VOLATILE); 6073 } 6074 return result; 6075} 6076 6077/* 6078 *---------------------------------------------------------------------- 6079 * 6080 * Tcl_CreateObjTrace -- 6081 * 6082 * Arrange for a procedure to be called to trace command execution. 6083 * 6084 * Results: 6085 * The return value is a token for the trace, which may be passed 6086 * to Tcl_DeleteTrace to eliminate the trace. 6087 * 6088 * Side effects: 6089 * From now on, proc will be called just before a command procedure 6090 * is called to execute a Tcl command. Calls to proc will have the 6091 * following form: 6092 * 6093 * void proc( ClientData clientData, 6094 * Tcl_Interp* interp, 6095 * int level, 6096 * CONST char* command, 6097 * Tcl_Command commandInfo, 6098 * int objc, 6099 * Tcl_Obj *CONST objv[] ); 6100 * 6101 * The 'clientData' and 'interp' arguments to 'proc' will be the 6102 * same as the arguments to Tcl_CreateObjTrace. The 'level' 6103 * argument gives the nesting depth of command interpretation within 6104 * the interpreter. The 'command' argument is the ASCII text of 6105 * the command being evaluated -- before any substitutions are 6106 * performed. The 'commandInfo' argument gives a handle to the 6107 * command procedure that will be evaluated. The 'objc' and 'objv' 6108 * parameters give the parameter vector that will be passed to the 6109 * command procedure. proc does not return a value. 6110 * 6111 * It is permissible for 'proc' to call Tcl_SetCommandTokenInfo 6112 * to change the command procedure or client data for the command 6113 * being evaluated, and these changes will take effect with the 6114 * current evaluation. 6115 * 6116 * The 'level' argument specifies the maximum nesting level of calls 6117 * to be traced. If the execution depth of the interpreter exceeds 6118 * 'level', the trace callback is not executed. 6119 * 6120 * The 'flags' argument is either zero or the value, 6121 * TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION 6122 * flag is not present, the bytecode compiler will not generate inline 6123 * code for Tcl's built-in commands. This behavior will have a significant 6124 * impact on performance, but will ensure that all command evaluations are 6125 * traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the 6126 * bytecode compiler will have its normal behavior of compiling in-line 6127 * code for some of Tcl's built-in commands. In this case, the tracing 6128 * will be imprecise -- in-line code will not be traced -- but run-time 6129 * performance will be improved. The latter behavior is desired for 6130 * many applications such as profiling of run time. 6131 * 6132 * When the trace is deleted, the 'delProc' procedure will be invoked, 6133 * passing it the original client data. 6134 * 6135 *---------------------------------------------------------------------- 6136 */ 6137 6138Tcl_Trace 6139Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc ) 6140 Tcl_Interp* interp; /* Tcl interpreter */ 6141 int level; /* Maximum nesting level */ 6142 int flags; /* Flags, see above */ 6143 Tcl_CmdObjTraceProc* proc; /* Trace callback */ 6144 ClientData clientData; /* Client data for the callback */ 6145 Tcl_CmdObjTraceDeleteProc* delProc; 6146 /* Procedure to call when trace is deleted */ 6147{ 6148 register Trace *tracePtr; 6149 register Interp *iPtr = (Interp *) interp; 6150 6151 /* Test if this trace allows inline compilation of commands */ 6152 6153 if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) { 6154 if (iPtr->tracesForbiddingInline == 0) { 6155 6156 /* 6157 * When the first trace forbidding inline compilation is 6158 * created, invalidate existing compiled code for this 6159 * interpreter and arrange (by setting the 6160 * DONT_COMPILE_CMDS_INLINE flag) that when compiling new 6161 * code, no commands will be compiled inline (i.e., into 6162 * an inline sequence of instructions). We do this because 6163 * commands that were compiled inline will never result in 6164 * a command trace being called. 6165 */ 6166 6167 iPtr->compileEpoch++; 6168 iPtr->flags |= DONT_COMPILE_CMDS_INLINE; 6169 } 6170 iPtr->tracesForbiddingInline++; 6171 } 6172 6173 tracePtr = (Trace *) ckalloc(sizeof(Trace)); 6174 tracePtr->level = level; 6175 tracePtr->proc = proc; 6176 tracePtr->clientData = clientData; 6177 tracePtr->delProc = delProc; 6178 tracePtr->nextPtr = iPtr->tracePtr; 6179 tracePtr->flags = flags; 6180 iPtr->tracePtr = tracePtr; 6181 6182 return (Tcl_Trace) tracePtr; 6183} 6184 6185/* 6186 *---------------------------------------------------------------------- 6187 * 6188 * Tcl_CreateTrace -- 6189 * 6190 * Arrange for a procedure to be called to trace command execution. 6191 * 6192 * Results: 6193 * The return value is a token for the trace, which may be passed 6194 * to Tcl_DeleteTrace to eliminate the trace. 6195 * 6196 * Side effects: 6197 * From now on, proc will be called just before a command procedure 6198 * is called to execute a Tcl command. Calls to proc will have the 6199 * following form: 6200 * 6201 * void 6202 * proc(clientData, interp, level, command, cmdProc, cmdClientData, 6203 * argc, argv) 6204 * ClientData clientData; 6205 * Tcl_Interp *interp; 6206 * int level; 6207 * char *command; 6208 * int (*cmdProc)(); 6209 * ClientData cmdClientData; 6210 * int argc; 6211 * char **argv; 6212 * { 6213 * } 6214 * 6215 * The clientData and interp arguments to proc will be the same 6216 * as the corresponding arguments to this procedure. Level gives 6217 * the nesting level of command interpretation for this interpreter 6218 * (0 corresponds to top level). Command gives the ASCII text of 6219 * the raw command, cmdProc and cmdClientData give the procedure that 6220 * will be called to process the command and the ClientData value it 6221 * will receive, and argc and argv give the arguments to the 6222 * command, after any argument parsing and substitution. Proc 6223 * does not return a value. 6224 * 6225 *---------------------------------------------------------------------- 6226 */ 6227 6228Tcl_Trace 6229Tcl_CreateTrace(interp, level, proc, clientData) 6230 Tcl_Interp *interp; /* Interpreter in which to create trace. */ 6231 int level; /* Only call proc for commands at nesting 6232 * level<=argument level (1=>top level). */ 6233 Tcl_CmdTraceProc *proc; /* Procedure to call before executing each 6234 * command. */ 6235 ClientData clientData; /* Arbitrary value word to pass to proc. */ 6236{ 6237 StringTraceData* data; 6238 data = (StringTraceData*) ckalloc( sizeof( *data )); 6239 data->clientData = clientData; 6240 data->proc = proc; 6241 return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc, 6242 (ClientData) data, StringTraceDeleteProc ); 6243} 6244 6245/* 6246 *---------------------------------------------------------------------- 6247 * 6248 * StringTraceProc -- 6249 * 6250 * Invoke a string-based trace procedure from an object-based 6251 * callback. 6252 * 6253 * Results: 6254 * None. 6255 * 6256 * Side effects: 6257 * Whatever the string-based trace procedure does. 6258 * 6259 *---------------------------------------------------------------------- 6260 */ 6261 6262static int 6263StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv ) 6264 ClientData clientData; 6265 Tcl_Interp* interp; 6266 int level; 6267 CONST char* command; 6268 Tcl_Command commandInfo; 6269 int objc; 6270 Tcl_Obj *CONST *objv; 6271{ 6272 StringTraceData* data = (StringTraceData*) clientData; 6273 Command* cmdPtr = (Command*) commandInfo; 6274 6275 CONST char** argv; /* Args to pass to string trace proc */ 6276 6277 int i; 6278 6279 /* 6280 * This is a bit messy because we have to emulate the old trace 6281 * interface, which uses strings for everything. 6282 */ 6283 6284 argv = (CONST char **) ckalloc((unsigned) ( (objc + 1) 6285 * sizeof(CONST char *) )); 6286 for (i = 0; i < objc; i++) { 6287 argv[i] = Tcl_GetString(objv[i]); 6288 } 6289 argv[objc] = 0; 6290 6291 /* 6292 * Invoke the command procedure. Note that we cast away const-ness 6293 * on two parameters for compatibility with legacy code; the code 6294 * MUST NOT modify either command or argv. 6295 */ 6296 6297 ( data->proc )( data->clientData, interp, level, 6298 (char*) command, cmdPtr->proc, cmdPtr->clientData, 6299 objc, argv ); 6300 ckfree( (char*) argv ); 6301 6302 return TCL_OK; 6303} 6304 6305/* 6306 *---------------------------------------------------------------------- 6307 * 6308 * StringTraceDeleteProc -- 6309 * 6310 * Clean up memory when a string-based trace is deleted. 6311 * 6312 * Results: 6313 * None. 6314 * 6315 * Side effects: 6316 * Allocated memory is returned to the system. 6317 * 6318 *---------------------------------------------------------------------- 6319 */ 6320 6321static void 6322StringTraceDeleteProc( clientData ) 6323 ClientData clientData; 6324{ 6325 ckfree( (char*) clientData ); 6326} 6327 6328/* 6329 *---------------------------------------------------------------------- 6330 * 6331 * Tcl_DeleteTrace -- 6332 * 6333 * Remove a trace. 6334 * 6335 * Results: 6336 * None. 6337 * 6338 * Side effects: 6339 * From now on there will be no more calls to the procedure given 6340 * in trace. 6341 * 6342 *---------------------------------------------------------------------- 6343 */ 6344 6345void 6346Tcl_DeleteTrace(interp, trace) 6347 Tcl_Interp *interp; /* Interpreter that contains trace. */ 6348 Tcl_Trace trace; /* Token for trace (returned previously by 6349 * Tcl_CreateTrace). */ 6350{ 6351 Interp *iPtr = (Interp *) interp; 6352 Trace *prevPtr, *tracePtr = (Trace *) trace; 6353 register Trace **tracePtr2 = &(iPtr->tracePtr); 6354 ActiveInterpTrace *activePtr; 6355 6356 /* 6357 * Locate the trace entry in the interpreter's trace list, 6358 * and remove it from the list. 6359 */ 6360 6361 prevPtr = NULL; 6362 while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) { 6363 prevPtr = *tracePtr2; 6364 tracePtr2 = &((*tracePtr2)->nextPtr); 6365 } 6366 if (*tracePtr2 == NULL) { 6367 return; 6368 } 6369 (*tracePtr2) = (*tracePtr2)->nextPtr; 6370 6371 /* 6372 * The code below makes it possible to delete traces while traces 6373 * are active: it makes sure that the deleted trace won't be 6374 * processed by TclCheckInterpTraces. 6375 */ 6376 6377 for (activePtr = iPtr->activeInterpTracePtr; activePtr != NULL; 6378 activePtr = activePtr->nextPtr) { 6379 if (activePtr->nextTracePtr == tracePtr) { 6380 if (activePtr->reverseScan) { 6381 activePtr->nextTracePtr = prevPtr; 6382 } else { 6383 activePtr->nextTracePtr = tracePtr->nextPtr; 6384 } 6385 } 6386 } 6387 6388 /* 6389 * If the trace forbids bytecode compilation, change the interpreter's 6390 * state. If bytecode compilation is now permitted, flag the fact and 6391 * advance the compilation epoch so that procs will be recompiled to 6392 * take advantage of it. 6393 */ 6394 6395 if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) { 6396 iPtr->tracesForbiddingInline--; 6397 if (iPtr->tracesForbiddingInline == 0) { 6398 iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; 6399 iPtr->compileEpoch++; 6400 } 6401 } 6402 6403 /* 6404 * Execute any delete callback. 6405 */ 6406 6407 if (tracePtr->delProc != NULL) { 6408 (tracePtr->delProc)(tracePtr->clientData); 6409 } 6410 6411 /* Delete the trace object */ 6412 6413 Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC); 6414} 6415 6416/* 6417 *---------------------------------------------------------------------- 6418 * 6419 * Tcl_AddErrorInfo -- 6420 * 6421 * Add information to the "errorInfo" variable that describes the 6422 * current error. 6423 * 6424 * Results: 6425 * None. 6426 * 6427 * Side effects: 6428 * The contents of message are added to the "errorInfo" variable. 6429 * If Tcl_Eval has been called since the current value of errorInfo 6430 * was set, errorInfo is cleared before adding the new message. 6431 * If we are just starting to log an error, errorInfo is initialized 6432 * from the error message in the interpreter's result. 6433 * 6434 *---------------------------------------------------------------------- 6435 */ 6436 6437void 6438Tcl_AddErrorInfo(interp, message) 6439 Tcl_Interp *interp; /* Interpreter to which error information 6440 * pertains. */ 6441 CONST char *message; /* Message to record. */ 6442{ 6443 Tcl_AddObjErrorInfo(interp, message, -1); 6444} 6445 6446/* 6447 *---------------------------------------------------------------------- 6448 * 6449 * Tcl_AddObjErrorInfo -- 6450 * 6451 * Add information to the "errorInfo" variable that describes the 6452 * current error. This routine differs from Tcl_AddErrorInfo by 6453 * taking a byte pointer and length. 6454 * 6455 * Results: 6456 * None. 6457 * 6458 * Side effects: 6459 * "length" bytes from "message" are added to the "errorInfo" variable. 6460 * If "length" is negative, use bytes up to the first NULL byte. 6461 * If Tcl_EvalObj has been called since the current value of errorInfo 6462 * was set, errorInfo is cleared before adding the new message. 6463 * If we are just starting to log an error, errorInfo is initialized 6464 * from the error message in the interpreter's result. 6465 * 6466 *---------------------------------------------------------------------- 6467 */ 6468 6469void 6470Tcl_AddObjErrorInfo(interp, message, length) 6471 Tcl_Interp *interp; /* Interpreter to which error information 6472 * pertains. */ 6473 CONST char *message; /* Points to the first byte of an array of 6474 * bytes of the message. */ 6475 int length; /* The number of bytes in the message. 6476 * If < 0, then append all bytes up to a 6477 * NULL byte. */ 6478{ 6479 register Interp *iPtr = (Interp *) interp; 6480 Tcl_Obj *objPtr; 6481 6482 /* 6483 * If we are just starting to log an error, errorInfo is initialized 6484 * from the error message in the interpreter's result. 6485 */ 6486 6487 if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */ 6488 iPtr->flags |= ERR_IN_PROGRESS; 6489 6490 if (iPtr->result[0] == 0) { 6491 Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, 6492 iPtr->objResultPtr, TCL_GLOBAL_ONLY); 6493 } else { /* use the string result */ 6494 objPtr = Tcl_NewStringObj(interp->result, -1); 6495 Tcl_IncrRefCount(objPtr); 6496 Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, 6497 objPtr, TCL_GLOBAL_ONLY); 6498 Tcl_DecrRefCount(objPtr); 6499 } 6500 6501 /* 6502 * If the errorCode variable wasn't set by the code that generated 6503 * the error, set it to "NONE". 6504 */ 6505 6506 if (!(iPtr->flags & ERROR_CODE_SET)) { 6507 objPtr = Tcl_NewStringObj("NONE", -1); 6508 Tcl_IncrRefCount(objPtr); 6509 Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL, 6510 objPtr, TCL_GLOBAL_ONLY); 6511 Tcl_DecrRefCount(objPtr); 6512 } 6513 } 6514 6515 /* 6516 * Now append "message" to the end of errorInfo. 6517 */ 6518 6519 if (length != 0) { 6520 objPtr = Tcl_NewStringObj(message, length); 6521 Tcl_IncrRefCount(objPtr); 6522 Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, 6523 objPtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); 6524 Tcl_DecrRefCount(objPtr); /* free msg object appended above */ 6525 } 6526} 6527 6528/* 6529 *--------------------------------------------------------------------------- 6530 * 6531 * Tcl_VarEvalVA -- 6532 * 6533 * Given a variable number of string arguments, concatenate them 6534 * all together and execute the result as a Tcl command. 6535 * 6536 * Results: 6537 * A standard Tcl return result. An error message or other result may 6538 * be left in the interp's result. 6539 * 6540 * Side effects: 6541 * Depends on what was done by the command. 6542 * 6543 *--------------------------------------------------------------------------- 6544 */ 6545 6546int 6547Tcl_VarEvalVA (interp, argList) 6548 Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ 6549 va_list argList; /* Variable argument list. */ 6550{ 6551 Tcl_DString buf; 6552 char *string; 6553 int result; 6554 6555 /* 6556 * Copy the strings one after the other into a single larger 6557 * string. Use stack-allocated space for small commands, but if 6558 * the command gets too large than call ckalloc to create the 6559 * space. 6560 */ 6561 6562 Tcl_DStringInit(&buf); 6563 while (1) { 6564 string = va_arg(argList, char *); 6565 if (string == NULL) { 6566 break; 6567 } 6568 Tcl_DStringAppend(&buf, string, -1); 6569 } 6570 6571 result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); 6572 Tcl_DStringFree(&buf); 6573 return result; 6574} 6575 6576/* 6577 *---------------------------------------------------------------------- 6578 * 6579 * Tcl_VarEval -- 6580 * 6581 * Given a variable number of string arguments, concatenate them 6582 * all together and execute the result as a Tcl command. 6583 * 6584 * Results: 6585 * A standard Tcl return result. An error message or other 6586 * result may be left in interp->result. 6587 * 6588 * Side effects: 6589 * Depends on what was done by the command. 6590 * 6591 *---------------------------------------------------------------------- 6592 */ 6593 /* VARARGS2 */ /* ARGSUSED */ 6594int 6595Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) 6596{ 6597 Tcl_Interp *interp; 6598 va_list argList; 6599 int result; 6600 6601 interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); 6602 result = Tcl_VarEvalVA(interp, argList); 6603 va_end(argList); 6604 6605 return result; 6606} 6607 6608/* 6609 *--------------------------------------------------------------------------- 6610 * 6611 * Tcl_GlobalEval -- 6612 * 6613 * Evaluate a command at global level in an interpreter. 6614 * 6615 * Results: 6616 * A standard Tcl result is returned, and the interp's result is 6617 * modified accordingly. 6618 * 6619 * Side effects: 6620 * The command string is executed in interp, and the execution 6621 * is carried out in the variable context of global level (no 6622 * procedures active), just as if an "uplevel #0" command were 6623 * being executed. 6624 * 6625 --------------------------------------------------------------------------- 6626 */ 6627 6628int 6629Tcl_GlobalEval(interp, command) 6630 Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ 6631 CONST char *command; /* Command to evaluate. */ 6632{ 6633 register Interp *iPtr = (Interp *) interp; 6634 int result; 6635 CallFrame *savedVarFramePtr; 6636 6637 savedVarFramePtr = iPtr->varFramePtr; 6638 iPtr->varFramePtr = NULL; 6639 result = Tcl_Eval(interp, command); 6640 iPtr->varFramePtr = savedVarFramePtr; 6641 return result; 6642} 6643 6644/* 6645 *---------------------------------------------------------------------- 6646 * 6647 * Tcl_SetRecursionLimit -- 6648 * 6649 * Set the maximum number of recursive calls that may be active 6650 * for an interpreter at once. 6651 * 6652 * Results: 6653 * The return value is the old limit on nesting for interp. 6654 * 6655 * Side effects: 6656 * None. 6657 * 6658 *---------------------------------------------------------------------- 6659 */ 6660 6661int 6662Tcl_SetRecursionLimit(interp, depth) 6663 Tcl_Interp *interp; /* Interpreter whose nesting limit 6664 * is to be set. */ 6665 int depth; /* New value for maximimum depth. */ 6666{ 6667 Interp *iPtr = (Interp *) interp; 6668 int old; 6669 6670 old = iPtr->maxNestingDepth; 6671 if (depth > 0) { 6672 iPtr->maxNestingDepth = depth; 6673 } 6674 return old; 6675} 6676 6677/* 6678 *---------------------------------------------------------------------- 6679 * 6680 * Tcl_AllowExceptions -- 6681 * 6682 * Sets a flag in an interpreter so that exceptions can occur 6683 * in the next call to Tcl_Eval without them being turned into 6684 * errors. 6685 * 6686 * Results: 6687 * None. 6688 * 6689 * Side effects: 6690 * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's 6691 * evalFlags structure. See the reference documentation for 6692 * more details. 6693 * 6694 *---------------------------------------------------------------------- 6695 */ 6696 6697void 6698Tcl_AllowExceptions(interp) 6699 Tcl_Interp *interp; /* Interpreter in which to set flag. */ 6700{ 6701 Interp *iPtr = (Interp *) interp; 6702 6703 iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; 6704} 6705 6706 6707/* 6708 *---------------------------------------------------------------------- 6709 * 6710 * Tcl_GetVersion 6711 * 6712 * Get the Tcl major, minor, and patchlevel version numbers and 6713 * the release type. A patch is a release type TCL_FINAL_RELEASE 6714 * with a patchLevel > 0. 6715 * 6716 * Results: 6717 * None. 6718 * 6719 * Side effects: 6720 * None. 6721 * 6722 *---------------------------------------------------------------------- 6723 */ 6724 6725void 6726Tcl_GetVersion(majorV, minorV, patchLevelV, type) 6727 int *majorV; 6728 int *minorV; 6729 int *patchLevelV; 6730 int *type; 6731{ 6732 if (majorV != NULL) { 6733 *majorV = TCL_MAJOR_VERSION; 6734 } 6735 if (minorV != NULL) { 6736 *minorV = TCL_MINOR_VERSION; 6737 } 6738 if (patchLevelV != NULL) { 6739 *patchLevelV = TCL_RELEASE_SERIAL; 6740 } 6741 if (type != NULL) { 6742 *type = TCL_RELEASE_LEVEL; 6743 } 6744} 6745#ifdef USE_DTRACE 6746 6747/* 6748 *---------------------------------------------------------------------- 6749 * 6750 * DTraceObjCmd -- 6751 * 6752 * This function is invoked to process the "::tcl::dtrace" Tcl command. 6753 * 6754 * Results: 6755 * A standard Tcl object result. 6756 * 6757 * Side effects: 6758 * The 'tcl-probe' DTrace probe is triggered (if it is enabled). 6759 * 6760 *---------------------------------------------------------------------- 6761 */ 6762 6763static int 6764DTraceObjCmd( 6765 ClientData dummy, /* Not used. */ 6766 Tcl_Interp *interp, /* Current interpreter. */ 6767 int objc, /* Number of arguments. */ 6768 Tcl_Obj *CONST objv[]) /* Argument objects. */ 6769{ 6770 if (TCL_DTRACE_TCL_PROBE_ENABLED()) { 6771 char *a[10]; 6772 int i = 0; 6773 6774 while (i++ < 10) { 6775 a[i-1] = i < objc ? TclGetString(objv[i]) : NULL; 6776 } 6777 TCL_DTRACE_TCL_PROBE(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], 6778 a[8], a[9]); 6779 } 6780 return TCL_OK; 6781} 6782 6783TCL_DTRACE_DEBUG_LOG() 6784 6785#endif /* USE_DTRACE */ 6786 6787/* 6788 * Local Variables: 6789 * mode: c 6790 * c-basic-offset: 4 6791 * fill-column: 78 6792 * End: 6793 */ 6794