1/* 2 * tclTrace.c -- 3 * 4 * This file contains code to handle most trace management. 5 * 6 * Copyright (c) 1987-1993 The Regents of the University of California. 7 * Copyright (c) 1994-1997 Sun Microsystems, Inc. 8 * Copyright (c) 1998-2000 Scriptics Corporation. 9 * Copyright (c) 2002 ActiveState Corporation. 10 * 11 * See the file "license.terms" for information on usage and redistribution of 12 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 * 14 * RCS: @(#) $Id: tclTrace.c,v 1.47.2.3 2010/08/19 10:04:15 dkf Exp $ 15 */ 16 17#include "tclInt.h" 18 19/* 20 * Structures used to hold information about variable traces: 21 */ 22 23typedef struct { 24 int flags; /* Operations for which Tcl command is to be 25 * invoked. */ 26 size_t length; /* Number of non-NUL chars. in command. */ 27 char command[4]; /* Space for Tcl command to invoke. Actual 28 * size will be as large as necessary to hold 29 * command. This field must be the last in the 30 * structure, so that it can be larger than 4 31 * bytes. */ 32} TraceVarInfo; 33 34typedef struct { 35 VarTrace traceInfo; 36 TraceVarInfo traceCmdInfo; 37} CombinedTraceVarInfo; 38 39/* 40 * Structure used to hold information about command traces: 41 */ 42 43typedef struct { 44 int flags; /* Operations for which Tcl command is to be 45 * invoked. */ 46 size_t length; /* Number of non-NUL chars. in command. */ 47 Tcl_Trace stepTrace; /* Used for execution traces, when tracing 48 * inside the given command */ 49 int startLevel; /* Used for bookkeeping with step execution 50 * traces, store the level at which the step 51 * trace was invoked */ 52 char *startCmd; /* Used for bookkeeping with step execution 53 * traces, store the command name which 54 * invoked step trace */ 55 int curFlags; /* Trace flags for the current command */ 56 int curCode; /* Return code for the current command */ 57 int refCount; /* Used to ensure this structure is not 58 * deleted too early. Keeps track of how many 59 * pieces of code have a pointer to this 60 * structure. */ 61 char command[4]; /* Space for Tcl command to invoke. Actual 62 * size will be as large as necessary to hold 63 * command. This field must be the last in the 64 * structure, so that it can be larger than 4 65 * bytes. */ 66} TraceCommandInfo; 67 68/* 69 * Used by command execution traces. Note that we assume in the code that 70 * TCL_TRACE_ENTER_DURING_EXEC == 4 * TCL_TRACE_ENTER_EXEC and that 71 * TCL_TRACE_LEAVE_DURING_EXEC == 4 * TCL_TRACE_LEAVE_EXEC. 72 * 73 * TCL_TRACE_ENTER_DURING_EXEC - Trace each command inside the command 74 * currently being traced, before execution. 75 * TCL_TRACE_LEAVE_DURING_EXEC - Trace each command inside the command 76 * currently being traced, after execution. 77 * TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags. 78 * TCL_TRACE_EXEC_IN_PROGRESS - The callback function on this trace is 79 * currently executing. Therefore we don't let 80 * further traces execute. 81 * TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly 82 * by the command being traced, not because of 83 * an internal trace. 84 * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also be used 85 * in command execution traces. 86 */ 87 88#define TCL_TRACE_ENTER_DURING_EXEC 4 89#define TCL_TRACE_LEAVE_DURING_EXEC 8 90#define TCL_TRACE_ANY_EXEC 15 91#define TCL_TRACE_EXEC_IN_PROGRESS 0x10 92#define TCL_TRACE_EXEC_DIRECT 0x20 93 94/* 95 * Forward declarations for functions defined in this file: 96 */ 97 98typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, int optionIndex, 99 int objc, Tcl_Obj *const objv[]); 100 101static Tcl_TraceTypeObjCmd TraceVariableObjCmd; 102static Tcl_TraceTypeObjCmd TraceCommandObjCmd; 103static Tcl_TraceTypeObjCmd TraceExecutionObjCmd; 104 105/* 106 * Each subcommand has a number of 'types' to which it can apply. Currently 107 * 'execution', 'command' and 'variable' are the only types supported. These 108 * three arrays MUST be kept in sync! In the future we may provide an API to 109 * add to the list of supported trace types. 110 */ 111 112static const char *traceTypeOptions[] = { 113 "execution", "command", "variable", NULL 114}; 115static Tcl_TraceTypeObjCmd *traceSubCmds[] = { 116 TraceExecutionObjCmd, 117 TraceCommandObjCmd, 118 TraceVariableObjCmd, 119}; 120 121/* 122 * Declarations for local functions to this file: 123 */ 124 125static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr, 126 Command *cmdPtr, const char *command, int numChars, 127 int objc, Tcl_Obj *const objv[]); 128static char * TraceVarProc(ClientData clientData, Tcl_Interp *interp, 129 const char *name1, const char *name2, int flags); 130static void TraceCommandProc(ClientData clientData, 131 Tcl_Interp *interp, const char *oldName, 132 const char *newName, int flags); 133static Tcl_CmdObjTraceProc TraceExecutionProc; 134static int StringTraceProc(ClientData clientData, 135 Tcl_Interp *interp, int level, 136 const char *command, Tcl_Command commandInfo, 137 int objc, Tcl_Obj *const objv[]); 138static void StringTraceDeleteProc(ClientData clientData); 139static void DisposeTraceResult(int flags, char *result); 140static int TraceVarEx(Tcl_Interp *interp, const char *part1, 141 const char *part2, register VarTrace *tracePtr); 142 143/* 144 * The following structure holds the client data for string-based 145 * trace procs 146 */ 147 148typedef struct StringTraceData { 149 ClientData clientData; /* Client data from Tcl_CreateTrace */ 150 Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */ 151} StringTraceData; 152 153/* 154 *---------------------------------------------------------------------- 155 * 156 * Tcl_TraceObjCmd -- 157 * 158 * This function is invoked to process the "trace" Tcl command. See the 159 * user documentation for details on what it does. 160 * 161 * Standard syntax as of Tcl 8.4 is: 162 * trace {add|info|remove} {command|variable} name ops cmd 163 * 164 * Results: 165 * A standard Tcl result. 166 * 167 * Side effects: 168 * See the user documentation. 169 *---------------------------------------------------------------------- 170 */ 171 172 /* ARGSUSED */ 173int 174Tcl_TraceObjCmd( 175 ClientData dummy, /* Not used. */ 176 Tcl_Interp *interp, /* Current interpreter. */ 177 int objc, /* Number of arguments. */ 178 Tcl_Obj *const objv[]) /* Argument objects. */ 179{ 180 int optionIndex; 181 char *name, *flagOps, *p; 182 /* Main sub commands to 'trace' */ 183 static const char *traceOptions[] = { 184 "add", "info", "remove", 185#ifndef TCL_REMOVE_OBSOLETE_TRACES 186 "variable", "vdelete", "vinfo", 187#endif 188 NULL 189 }; 190 /* 'OLD' options are pre-Tcl-8.4 style */ 191 enum traceOptions { 192 TRACE_ADD, TRACE_INFO, TRACE_REMOVE, 193#ifndef TCL_REMOVE_OBSOLETE_TRACES 194 TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO 195#endif 196 }; 197 198 if (objc < 2) { 199 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); 200 return TCL_ERROR; 201 } 202 203 if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, 204 "option", 0, &optionIndex) != TCL_OK) { 205 return TCL_ERROR; 206 } 207 switch ((enum traceOptions) optionIndex) { 208 case TRACE_ADD: 209 case TRACE_REMOVE: { 210 /* 211 * All sub commands of trace add/remove must take at least one more 212 * argument. Beyond that we let the subcommand itself control the 213 * argument structure. 214 */ 215 216 int typeIndex; 217 218 if (objc < 3) { 219 Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?"); 220 return TCL_ERROR; 221 } 222 if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, "option", 223 0, &typeIndex) != TCL_OK) { 224 return TCL_ERROR; 225 } 226 return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); 227 } 228 case TRACE_INFO: { 229 /* 230 * All sub commands of trace info must take exactly two more arguments 231 * which name the type of thing being traced and the name of the thing 232 * being traced. 233 */ 234 235 int typeIndex; 236 if (objc < 3) { 237 /* 238 * Delegate other complaints to the type-specific code which can 239 * give a better error message. 240 */ 241 242 Tcl_WrongNumArgs(interp, 2, objv, "type name"); 243 return TCL_ERROR; 244 } 245 if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, "option", 246 0, &typeIndex) != TCL_OK) { 247 return TCL_ERROR; 248 } 249 return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); 250 break; 251 } 252 253#ifndef TCL_REMOVE_OBSOLETE_TRACES 254 case TRACE_OLD_VARIABLE: 255 case TRACE_OLD_VDELETE: { 256 Tcl_Obj *copyObjv[6]; 257 Tcl_Obj *opsList; 258 int code, numFlags; 259 260 if (objc != 5) { 261 Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); 262 return TCL_ERROR; 263 } 264 265 opsList = Tcl_NewObj(); 266 Tcl_IncrRefCount(opsList); 267 flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); 268 if (numFlags == 0) { 269 Tcl_DecrRefCount(opsList); 270 goto badVarOps; 271 } 272 for (p = flagOps; *p != 0; p++) { 273 Tcl_Obj *opObj; 274 275 if (*p == 'r') { 276 TclNewLiteralStringObj(opObj, "read"); 277 } else if (*p == 'w') { 278 TclNewLiteralStringObj(opObj, "write"); 279 } else if (*p == 'u') { 280 TclNewLiteralStringObj(opObj, "unset"); 281 } else if (*p == 'a') { 282 TclNewLiteralStringObj(opObj, "array"); 283 } else { 284 Tcl_DecrRefCount(opsList); 285 goto badVarOps; 286 } 287 Tcl_ListObjAppendElement(NULL, opsList, opObj); 288 } 289 copyObjv[0] = NULL; 290 memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *)); 291 copyObjv[4] = opsList; 292 if (optionIndex == TRACE_OLD_VARIABLE) { 293 code = (traceSubCmds[2])(interp, TRACE_ADD, objc+1, copyObjv); 294 } else { 295 code = (traceSubCmds[2])(interp, TRACE_REMOVE, objc+1, copyObjv); 296 } 297 Tcl_DecrRefCount(opsList); 298 return code; 299 } 300 case TRACE_OLD_VINFO: { 301 ClientData clientData; 302 char ops[5]; 303 Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; 304 305 if (objc != 3) { 306 Tcl_WrongNumArgs(interp, 2, objv, "name"); 307 return TCL_ERROR; 308 } 309 resultListPtr = Tcl_NewObj(); 310 clientData = 0; 311 name = Tcl_GetString(objv[2]); 312 while ((clientData = Tcl_VarTraceInfo(interp, name, 0, 313 TraceVarProc, clientData)) != 0) { 314 315 TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; 316 317 pairObjPtr = Tcl_NewListObj(0, NULL); 318 p = ops; 319 if (tvarPtr->flags & TCL_TRACE_READS) { 320 *p = 'r'; 321 p++; 322 } 323 if (tvarPtr->flags & TCL_TRACE_WRITES) { 324 *p = 'w'; 325 p++; 326 } 327 if (tvarPtr->flags & TCL_TRACE_UNSETS) { 328 *p = 'u'; 329 p++; 330 } 331 if (tvarPtr->flags & TCL_TRACE_ARRAY) { 332 *p = 'a'; 333 p++; 334 } 335 *p = '\0'; 336 337 /* 338 * Build a pair (2-item list) with the ops string as the first obj 339 * element and the tvarPtr->command string as the second obj 340 * element. Append the pair (as an element) to the end of the 341 * result object list. 342 */ 343 344 elemObjPtr = Tcl_NewStringObj(ops, -1); 345 Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); 346 elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); 347 Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); 348 Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr); 349 } 350 Tcl_SetObjResult(interp, resultListPtr); 351 break; 352 } 353#endif /* TCL_REMOVE_OBSOLETE_TRACES */ 354 } 355 return TCL_OK; 356 357 badVarOps: 358 Tcl_AppendResult(interp, "bad operations \"", flagOps, 359 "\": should be one or more of rwua", NULL); 360 return TCL_ERROR; 361} 362 363/* 364 *---------------------------------------------------------------------- 365 * 366 * TraceExecutionObjCmd -- 367 * 368 * Helper function for Tcl_TraceObjCmd; implements the [trace 369 * {add|remove|info} execution ...] subcommands. See the user 370 * documentation for details on what these do. 371 * 372 * Results: 373 * Standard Tcl result. 374 * 375 * Side effects: 376 * Depends on the operation (add, remove, or info) being performed; may 377 * add or remove command traces on a command. 378 * 379 *---------------------------------------------------------------------- 380 */ 381 382static int 383TraceExecutionObjCmd( 384 Tcl_Interp *interp, /* Current interpreter. */ 385 int optionIndex, /* Add, info or remove */ 386 int objc, /* Number of arguments. */ 387 Tcl_Obj *const objv[]) /* Argument objects. */ 388{ 389 int commandLength, index; 390 char *name, *command; 391 size_t length; 392 enum traceOptions { 393 TRACE_ADD, TRACE_INFO, TRACE_REMOVE 394 }; 395 static const char *opStrings[] = { 396 "enter", "leave", "enterstep", "leavestep", NULL 397 }; 398 enum operations { 399 TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE, 400 TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP 401 }; 402 403 switch ((enum traceOptions) optionIndex) { 404 case TRACE_ADD: 405 case TRACE_REMOVE: { 406 int flags = 0; 407 int i, listLen, result; 408 Tcl_Obj **elemPtrs; 409 410 if (objc != 6) { 411 Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); 412 return TCL_ERROR; 413 } 414 415 /* 416 * Make sure the ops argument is a list object; get its length and a 417 * pointer to its array of element pointers. 418 */ 419 420 result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); 421 if (result != TCL_OK) { 422 return result; 423 } 424 if (listLen == 0) { 425 Tcl_SetResult(interp, "bad operation list \"\": must be " 426 "one or more of enter, leave, enterstep, or leavestep", 427 TCL_STATIC); 428 return TCL_ERROR; 429 } 430 for (i = 0; i < listLen; i++) { 431 if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, 432 "operation", TCL_EXACT, &index) != TCL_OK) { 433 return TCL_ERROR; 434 } 435 switch ((enum operations) index) { 436 case TRACE_EXEC_ENTER: 437 flags |= TCL_TRACE_ENTER_EXEC; 438 break; 439 case TRACE_EXEC_LEAVE: 440 flags |= TCL_TRACE_LEAVE_EXEC; 441 break; 442 case TRACE_EXEC_ENTER_STEP: 443 flags |= TCL_TRACE_ENTER_DURING_EXEC; 444 break; 445 case TRACE_EXEC_LEAVE_STEP: 446 flags |= TCL_TRACE_LEAVE_DURING_EXEC; 447 break; 448 } 449 } 450 command = Tcl_GetStringFromObj(objv[5], &commandLength); 451 length = (size_t) commandLength; 452 if ((enum traceOptions) optionIndex == TRACE_ADD) { 453 TraceCommandInfo *tcmdPtr; 454 455 tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) 456 (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) 457 + length + 1)); 458 tcmdPtr->flags = flags; 459 tcmdPtr->stepTrace = NULL; 460 tcmdPtr->startLevel = 0; 461 tcmdPtr->startCmd = NULL; 462 tcmdPtr->length = length; 463 tcmdPtr->refCount = 1; 464 flags |= TCL_TRACE_DELETE; 465 if (flags & (TCL_TRACE_ENTER_DURING_EXEC | 466 TCL_TRACE_LEAVE_DURING_EXEC)) { 467 flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); 468 } 469 memcpy(tcmdPtr->command, command, length+1); 470 name = Tcl_GetString(objv[3]); 471 if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, 472 (ClientData) tcmdPtr) != TCL_OK) { 473 ckfree((char *) tcmdPtr); 474 return TCL_ERROR; 475 } 476 } else { 477 /* 478 * Search through all of our traces on this command to see if 479 * there's one with the given command. If so, then delete the 480 * first one that matches. 481 */ 482 483 TraceCommandInfo *tcmdPtr; 484 ClientData clientData = NULL; 485 name = Tcl_GetString(objv[3]); 486 487 /* 488 * First ensure the name given is valid. 489 */ 490 491 if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) { 492 return TCL_ERROR; 493 } 494 495 while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, 496 TraceCommandProc, clientData)) != NULL) { 497 tcmdPtr = (TraceCommandInfo *) clientData; 498 499 /* 500 * In checking the 'flags' field we must remove any extraneous 501 * flags which may have been temporarily added by various 502 * pieces of the trace mechanism. 503 */ 504 505 if ((tcmdPtr->length == length) 506 && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | 507 TCL_TRACE_RENAME | TCL_TRACE_DELETE)) == flags) 508 && (strncmp(command, tcmdPtr->command, 509 (size_t) length) == 0)) { 510 flags |= TCL_TRACE_DELETE; 511 if (flags & (TCL_TRACE_ENTER_DURING_EXEC | 512 TCL_TRACE_LEAVE_DURING_EXEC)) { 513 flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); 514 } 515 Tcl_UntraceCommand(interp, name, flags, 516 TraceCommandProc, clientData); 517 if (tcmdPtr->stepTrace != NULL) { 518 /* 519 * We need to remove the interpreter-wide trace which 520 * we created to allow 'step' traces. 521 */ 522 523 Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); 524 tcmdPtr->stepTrace = NULL; 525 if (tcmdPtr->startCmd != NULL) { 526 ckfree((char *) tcmdPtr->startCmd); 527 } 528 } 529 if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { 530 /* 531 * Postpone deletion. 532 */ 533 534 tcmdPtr->flags = 0; 535 } 536 if ((--tcmdPtr->refCount) <= 0) { 537 ckfree((char *) tcmdPtr); 538 } 539 break; 540 } 541 } 542 } 543 break; 544 } 545 case TRACE_INFO: { 546 ClientData clientData; 547 Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; 548 549 if (objc != 4) { 550 Tcl_WrongNumArgs(interp, 3, objv, "name"); 551 return TCL_ERROR; 552 } 553 554 clientData = NULL; 555 name = Tcl_GetString(objv[3]); 556 557 /* 558 * First ensure the name given is valid. 559 */ 560 561 if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { 562 return TCL_ERROR; 563 } 564 565 resultListPtr = Tcl_NewListObj(0, NULL); 566 while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, 567 TraceCommandProc, clientData)) != NULL) { 568 int numOps = 0; 569 Tcl_Obj *opObj; 570 TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; 571 572 /* 573 * Build a list with the ops list as the first obj element and the 574 * tcmdPtr->command string as the second obj element. Append this 575 * list (as an element) to the end of the result object list. 576 */ 577 578 elemObjPtr = Tcl_NewListObj(0, NULL); 579 Tcl_IncrRefCount(elemObjPtr); 580 if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) { 581 TclNewLiteralStringObj(opObj, "enter"); 582 Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); 583 } 584 if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) { 585 TclNewLiteralStringObj(opObj, "leave"); 586 Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); 587 } 588 if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) { 589 TclNewLiteralStringObj(opObj, "enterstep"); 590 Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); 591 } 592 if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) { 593 TclNewLiteralStringObj(opObj, "leavestep"); 594 Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); 595 } 596 Tcl_ListObjLength(NULL, elemObjPtr, &numOps); 597 if (0 == numOps) { 598 Tcl_DecrRefCount(elemObjPtr); 599 continue; 600 } 601 eachTraceObjPtr = Tcl_NewListObj(0, NULL); 602 Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); 603 Tcl_DecrRefCount(elemObjPtr); 604 elemObjPtr = NULL; 605 606 Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, 607 Tcl_NewStringObj(tcmdPtr->command, -1)); 608 Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); 609 } 610 Tcl_SetObjResult(interp, resultListPtr); 611 break; 612 } 613 } 614 return TCL_OK; 615} 616 617/* 618 *---------------------------------------------------------------------- 619 * 620 * TraceCommandObjCmd -- 621 * 622 * Helper function for Tcl_TraceObjCmd; implements the [trace 623 * {add|info|remove} command ...] subcommands. See the user documentation 624 * for details on what these do. 625 * 626 * Results: 627 * Standard Tcl result. 628 * 629 * Side effects: 630 * Depends on the operation (add, remove, or info) being performed; may 631 * add or remove command traces on a command. 632 * 633 *---------------------------------------------------------------------- 634 */ 635 636static int 637TraceCommandObjCmd( 638 Tcl_Interp *interp, /* Current interpreter. */ 639 int optionIndex, /* Add, info or remove */ 640 int objc, /* Number of arguments. */ 641 Tcl_Obj *const objv[]) /* Argument objects. */ 642{ 643 int commandLength, index; 644 char *name, *command; 645 size_t length; 646 enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; 647 static const char *opStrings[] = { "delete", "rename", NULL }; 648 enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; 649 650 switch ((enum traceOptions) optionIndex) { 651 case TRACE_ADD: 652 case TRACE_REMOVE: { 653 int flags = 0; 654 int i, listLen, result; 655 Tcl_Obj **elemPtrs; 656 657 if (objc != 6) { 658 Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); 659 return TCL_ERROR; 660 } 661 662 /* 663 * Make sure the ops argument is a list object; get its length and a 664 * pointer to its array of element pointers. 665 */ 666 667 result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); 668 if (result != TCL_OK) { 669 return result; 670 } 671 if (listLen == 0) { 672 Tcl_SetResult(interp, "bad operation list \"\": must be " 673 "one or more of delete or rename", TCL_STATIC); 674 return TCL_ERROR; 675 } 676 677 for (i = 0; i < listLen; i++) { 678 if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, 679 "operation", TCL_EXACT, &index) != TCL_OK) { 680 return TCL_ERROR; 681 } 682 switch ((enum operations) index) { 683 case TRACE_CMD_RENAME: 684 flags |= TCL_TRACE_RENAME; 685 break; 686 case TRACE_CMD_DELETE: 687 flags |= TCL_TRACE_DELETE; 688 break; 689 } 690 } 691 692 command = Tcl_GetStringFromObj(objv[5], &commandLength); 693 length = (size_t) commandLength; 694 if ((enum traceOptions) optionIndex == TRACE_ADD) { 695 TraceCommandInfo *tcmdPtr; 696 697 tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) 698 (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) 699 + length + 1)); 700 tcmdPtr->flags = flags; 701 tcmdPtr->stepTrace = NULL; 702 tcmdPtr->startLevel = 0; 703 tcmdPtr->startCmd = NULL; 704 tcmdPtr->length = length; 705 tcmdPtr->refCount = 1; 706 flags |= TCL_TRACE_DELETE; 707 memcpy(tcmdPtr->command, command, length+1); 708 name = Tcl_GetString(objv[3]); 709 if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, 710 (ClientData) tcmdPtr) != TCL_OK) { 711 ckfree((char *) tcmdPtr); 712 return TCL_ERROR; 713 } 714 } else { 715 /* 716 * Search through all of our traces on this command to see if 717 * there's one with the given command. If so, then delete the 718 * first one that matches. 719 */ 720 721 TraceCommandInfo *tcmdPtr; 722 ClientData clientData = NULL; 723 name = Tcl_GetString(objv[3]); 724 725 /* 726 * First ensure the name given is valid. 727 */ 728 729 if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) { 730 return TCL_ERROR; 731 } 732 733 while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, 734 TraceCommandProc, clientData)) != NULL) { 735 tcmdPtr = (TraceCommandInfo *) clientData; 736 if ((tcmdPtr->length == length) 737 && (tcmdPtr->flags == flags) 738 && (strncmp(command, tcmdPtr->command, 739 (size_t) length) == 0)) { 740 Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, 741 TraceCommandProc, clientData); 742 tcmdPtr->flags |= TCL_TRACE_DESTROYED; 743 if ((--tcmdPtr->refCount) <= 0) { 744 ckfree((char *) tcmdPtr); 745 } 746 break; 747 } 748 } 749 } 750 break; 751 } 752 case TRACE_INFO: { 753 ClientData clientData; 754 Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; 755 756 if (objc != 4) { 757 Tcl_WrongNumArgs(interp, 3, objv, "name"); 758 return TCL_ERROR; 759 } 760 761 clientData = NULL; 762 name = Tcl_GetString(objv[3]); 763 764 /* 765 * First ensure the name given is valid. 766 */ 767 768 if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { 769 return TCL_ERROR; 770 } 771 772 resultListPtr = Tcl_NewListObj(0, NULL); 773 while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, 774 TraceCommandProc, clientData)) != NULL) { 775 int numOps = 0; 776 Tcl_Obj *opObj; 777 TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; 778 779 /* 780 * Build a list with the ops list as the first obj element and the 781 * tcmdPtr->command string as the second obj element. Append this 782 * list (as an element) to the end of the result object list. 783 */ 784 785 elemObjPtr = Tcl_NewListObj(0, NULL); 786 Tcl_IncrRefCount(elemObjPtr); 787 if (tcmdPtr->flags & TCL_TRACE_RENAME) { 788 TclNewLiteralStringObj(opObj, "rename"); 789 Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); 790 } 791 if (tcmdPtr->flags & TCL_TRACE_DELETE) { 792 TclNewLiteralStringObj(opObj, "delete"); 793 Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); 794 } 795 Tcl_ListObjLength(NULL, elemObjPtr, &numOps); 796 if (0 == numOps) { 797 Tcl_DecrRefCount(elemObjPtr); 798 continue; 799 } 800 eachTraceObjPtr = Tcl_NewListObj(0, NULL); 801 Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); 802 Tcl_DecrRefCount(elemObjPtr); 803 804 elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); 805 Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); 806 Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); 807 } 808 Tcl_SetObjResult(interp, resultListPtr); 809 break; 810 } 811 } 812 return TCL_OK; 813} 814 815/* 816 *---------------------------------------------------------------------- 817 * 818 * TraceVariableObjCmd -- 819 * 820 * Helper function for Tcl_TraceObjCmd; implements the [trace 821 * {add|info|remove} variable ...] subcommands. See the user 822 * documentation for details on what these do. 823 * 824 * Results: 825 * Standard Tcl result. 826 * 827 * Side effects: 828 * Depends on the operation (add, remove, or info) being performed; may 829 * add or remove variable traces on a variable. 830 * 831 *---------------------------------------------------------------------- 832 */ 833 834static int 835TraceVariableObjCmd( 836 Tcl_Interp *interp, /* Current interpreter. */ 837 int optionIndex, /* Add, info or remove */ 838 int objc, /* Number of arguments. */ 839 Tcl_Obj *const objv[]) /* Argument objects. */ 840{ 841 int commandLength, index; 842 char *name, *command; 843 size_t length; 844 enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; 845 static const char *opStrings[] = { 846 "array", "read", "unset", "write", NULL 847 }; 848 enum operations { 849 TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, TRACE_VAR_WRITE 850 }; 851 852 switch ((enum traceOptions) optionIndex) { 853 case TRACE_ADD: 854 case TRACE_REMOVE: { 855 int flags = 0; 856 int i, listLen, result; 857 Tcl_Obj **elemPtrs; 858 859 if (objc != 6) { 860 Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); 861 return TCL_ERROR; 862 } 863 864 /* 865 * Make sure the ops argument is a list object; get its length and a 866 * pointer to its array of element pointers. 867 */ 868 869 result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); 870 if (result != TCL_OK) { 871 return result; 872 } 873 if (listLen == 0) { 874 Tcl_SetResult(interp, "bad operation list \"\": must be " 875 "one or more of array, read, unset, or write", TCL_STATIC); 876 return TCL_ERROR; 877 } 878 for (i = 0; i < listLen ; i++) { 879 if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, 880 "operation", TCL_EXACT, &index) != TCL_OK) { 881 return TCL_ERROR; 882 } 883 switch ((enum operations) index) { 884 case TRACE_VAR_ARRAY: 885 flags |= TCL_TRACE_ARRAY; 886 break; 887 case TRACE_VAR_READ: 888 flags |= TCL_TRACE_READS; 889 break; 890 case TRACE_VAR_UNSET: 891 flags |= TCL_TRACE_UNSETS; 892 break; 893 case TRACE_VAR_WRITE: 894 flags |= TCL_TRACE_WRITES; 895 break; 896 } 897 } 898 command = Tcl_GetStringFromObj(objv[5], &commandLength); 899 length = (size_t) commandLength; 900 if ((enum traceOptions) optionIndex == TRACE_ADD) { 901 CombinedTraceVarInfo *ctvarPtr; 902 903 ctvarPtr = (CombinedTraceVarInfo *) ckalloc((unsigned) 904 (sizeof(CombinedTraceVarInfo) + length + 1 905 - sizeof(ctvarPtr->traceCmdInfo.command))); 906 ctvarPtr->traceCmdInfo.flags = flags; 907 if (objv[0] == NULL) { 908 ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE; 909 } 910 ctvarPtr->traceCmdInfo.length = length; 911 flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; 912 memcpy(ctvarPtr->traceCmdInfo.command, command, length+1); 913 ctvarPtr->traceInfo.traceProc = TraceVarProc; 914 ctvarPtr->traceInfo.clientData = (ClientData) 915 &ctvarPtr->traceCmdInfo; 916 ctvarPtr->traceInfo.flags = flags; 917 name = Tcl_GetString(objv[3]); 918 if (TraceVarEx(interp,name,NULL,(VarTrace*)ctvarPtr) != TCL_OK) { 919 ckfree((char *) ctvarPtr); 920 return TCL_ERROR; 921 } 922 } else { 923 /* 924 * Search through all of our traces on this variable to see if 925 * there's one with the given command. If so, then delete the 926 * first one that matches. 927 */ 928 929 TraceVarInfo *tvarPtr; 930 ClientData clientData = 0; 931 name = Tcl_GetString(objv[3]); 932 while ((clientData = Tcl_VarTraceInfo(interp, name, 0, 933 TraceVarProc, clientData)) != 0) { 934 tvarPtr = (TraceVarInfo *) clientData; 935 if ((tvarPtr->length == length) 936 && ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags) 937 && (strncmp(command, tvarPtr->command, 938 (size_t) length) == 0)) { 939 Tcl_UntraceVar2(interp, name, NULL, 940 flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, 941 TraceVarProc, clientData); 942 break; 943 } 944 } 945 } 946 break; 947 } 948 case TRACE_INFO: { 949 ClientData clientData; 950 Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; 951 952 if (objc != 4) { 953 Tcl_WrongNumArgs(interp, 3, objv, "name"); 954 return TCL_ERROR; 955 } 956 957 resultListPtr = Tcl_NewObj(); 958 clientData = 0; 959 name = Tcl_GetString(objv[3]); 960 while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, 961 clientData)) != 0) { 962 Tcl_Obj *opObj; 963 TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; 964 965 /* 966 * Build a list with the ops list as the first obj element and the 967 * tcmdPtr->command string as the second obj element. Append this 968 * list (as an element) to the end of the result object list. 969 */ 970 971 elemObjPtr = Tcl_NewListObj(0, NULL); 972 if (tvarPtr->flags & TCL_TRACE_ARRAY) { 973 TclNewLiteralStringObj(opObj, "array"); 974 Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); 975 } 976 if (tvarPtr->flags & TCL_TRACE_READS) { 977 TclNewLiteralStringObj(opObj, "read"); 978 Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); 979 } 980 if (tvarPtr->flags & TCL_TRACE_WRITES) { 981 TclNewLiteralStringObj(opObj, "write"); 982 Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); 983 } 984 if (tvarPtr->flags & TCL_TRACE_UNSETS) { 985 TclNewLiteralStringObj(opObj, "unset"); 986 Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); 987 } 988 eachTraceObjPtr = Tcl_NewListObj(0, NULL); 989 Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); 990 991 elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); 992 Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); 993 Tcl_ListObjAppendElement(interp, resultListPtr, 994 eachTraceObjPtr); 995 } 996 Tcl_SetObjResult(interp, resultListPtr); 997 break; 998 } 999 } 1000 return TCL_OK; 1001} 1002 1003/* 1004 *---------------------------------------------------------------------- 1005 * 1006 * Tcl_CommandTraceInfo -- 1007 * 1008 * Return the clientData value associated with a trace on a command. 1009 * This function can also be used to step through all of the traces on a 1010 * particular command that have the same trace function. 1011 * 1012 * Results: 1013 * The return value is the clientData value associated with a trace on 1014 * the given command. Information will only be returned for a trace with 1015 * proc as trace function. If the clientData argument is NULL then the 1016 * first such trace is returned; otherwise, the next relevant one after 1017 * the one given by clientData will be returned. If the command doesn't 1018 * exist then an error message is left in the interpreter and NULL is 1019 * returned. Also, if there are no (more) traces for the given command, 1020 * NULL is returned. 1021 * 1022 * Side effects: 1023 * None. 1024 * 1025 *---------------------------------------------------------------------- 1026 */ 1027 1028ClientData 1029Tcl_CommandTraceInfo( 1030 Tcl_Interp *interp, /* Interpreter containing command. */ 1031 const char *cmdName, /* Name of command. */ 1032 int flags, /* OR-ed combo or TCL_GLOBAL_ONLY, 1033 * TCL_NAMESPACE_ONLY (can be 0). */ 1034 Tcl_CommandTraceProc *proc, /* Function assocated with trace. */ 1035 ClientData prevClientData) /* If non-NULL, gives last value returned by 1036 * this function, so this call will return the 1037 * next trace after that one. If NULL, this 1038 * call will return the first trace. */ 1039{ 1040 Command *cmdPtr; 1041 register CommandTrace *tracePtr; 1042 1043 cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, 1044 TCL_LEAVE_ERR_MSG); 1045 if (cmdPtr == NULL) { 1046 return NULL; 1047 } 1048 1049 /* 1050 * Find the relevant trace, if any, and return its clientData. 1051 */ 1052 1053 tracePtr = cmdPtr->tracePtr; 1054 if (prevClientData != NULL) { 1055 for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) { 1056 if ((tracePtr->clientData == prevClientData) 1057 && (tracePtr->traceProc == proc)) { 1058 tracePtr = tracePtr->nextPtr; 1059 break; 1060 } 1061 } 1062 } 1063 for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) { 1064 if (tracePtr->traceProc == proc) { 1065 return tracePtr->clientData; 1066 } 1067 } 1068 return NULL; 1069} 1070 1071/* 1072 *---------------------------------------------------------------------- 1073 * 1074 * Tcl_TraceCommand -- 1075 * 1076 * Arrange for rename/deletes to a command to cause a function to be 1077 * invoked, which can monitor the operations. 1078 * 1079 * Also optionally arrange for execution of that command to cause a 1080 * function to be invoked. 1081 * 1082 * Results: 1083 * A standard Tcl return value. 1084 * 1085 * Side effects: 1086 * A trace is set up on the command given by cmdName, such that future 1087 * changes to the command will be intermediated by proc. See the manual 1088 * entry for complete details on the calling sequence for proc. 1089 * 1090 *---------------------------------------------------------------------- 1091 */ 1092 1093int 1094Tcl_TraceCommand( 1095 Tcl_Interp *interp, /* Interpreter in which command is to be 1096 * traced. */ 1097 const char *cmdName, /* Name of command. */ 1098 int flags, /* OR-ed collection of bits, including any of 1099 * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any 1100 * of the TRACE_*_EXEC flags */ 1101 Tcl_CommandTraceProc *proc, /* Function to call when specified ops are 1102 * invoked upon cmdName. */ 1103 ClientData clientData) /* Arbitrary argument to pass to proc. */ 1104{ 1105 Command *cmdPtr; 1106 register CommandTrace *tracePtr; 1107 1108 cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, 1109 TCL_LEAVE_ERR_MSG); 1110 if (cmdPtr == NULL) { 1111 return TCL_ERROR; 1112 } 1113 1114 /* 1115 * Set up trace information. 1116 */ 1117 1118 tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace)); 1119 tracePtr->traceProc = proc; 1120 tracePtr->clientData = clientData; 1121 tracePtr->flags = flags & 1122 (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); 1123 tracePtr->nextPtr = cmdPtr->tracePtr; 1124 tracePtr->refCount = 1; 1125 cmdPtr->tracePtr = tracePtr; 1126 if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { 1127 cmdPtr->flags |= CMD_HAS_EXEC_TRACES; 1128 } 1129 return TCL_OK; 1130} 1131 1132/* 1133 *---------------------------------------------------------------------- 1134 * 1135 * Tcl_UntraceCommand -- 1136 * 1137 * Remove a previously-created trace for a command. 1138 * 1139 * Results: 1140 * None. 1141 * 1142 * Side effects: 1143 * If there exists a trace for the command given by cmdName with the 1144 * given flags, proc, and clientData, then that trace is removed. 1145 * 1146 *---------------------------------------------------------------------- 1147 */ 1148 1149void 1150Tcl_UntraceCommand( 1151 Tcl_Interp *interp, /* Interpreter containing command. */ 1152 const char *cmdName, /* Name of command. */ 1153 int flags, /* OR-ed collection of bits, including any of 1154 * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any 1155 * of the TRACE_*_EXEC flags */ 1156 Tcl_CommandTraceProc *proc, /* Function assocated with trace. */ 1157 ClientData clientData) /* Arbitrary argument to pass to proc. */ 1158{ 1159 register CommandTrace *tracePtr; 1160 CommandTrace *prevPtr; 1161 Command *cmdPtr; 1162 Interp *iPtr = (Interp *) interp; 1163 ActiveCommandTrace *activePtr; 1164 int hasExecTraces = 0; 1165 1166 cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, 1167 TCL_LEAVE_ERR_MSG); 1168 if (cmdPtr == NULL) { 1169 return; 1170 } 1171 1172 flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); 1173 1174 for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ; 1175 prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { 1176 if (tracePtr == NULL) { 1177 return; 1178 } 1179 if ((tracePtr->traceProc == proc) 1180 && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | 1181 TCL_TRACE_ANY_EXEC)) == flags) 1182 && (tracePtr->clientData == clientData)) { 1183 if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { 1184 hasExecTraces = 1; 1185 } 1186 break; 1187 } 1188 } 1189 1190 /* 1191 * The code below makes it possible to delete traces while traces are 1192 * active: it makes sure that the deleted trace won't be processed by 1193 * CallCommandTraces. 1194 */ 1195 1196 for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL; 1197 activePtr = activePtr->nextPtr) { 1198 if (activePtr->nextTracePtr == tracePtr) { 1199 if (activePtr->reverseScan) { 1200 activePtr->nextTracePtr = prevPtr; 1201 } else { 1202 activePtr->nextTracePtr = tracePtr->nextPtr; 1203 } 1204 } 1205 } 1206 if (prevPtr == NULL) { 1207 cmdPtr->tracePtr = tracePtr->nextPtr; 1208 } else { 1209 prevPtr->nextPtr = tracePtr->nextPtr; 1210 } 1211 tracePtr->flags = 0; 1212 1213 if ((--tracePtr->refCount) <= 0) { 1214 ckfree((char *) tracePtr); 1215 } 1216 1217 if (hasExecTraces) { 1218 for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ; 1219 prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { 1220 if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { 1221 return; 1222 } 1223 } 1224 1225 /* 1226 * None of the remaining traces on this command are execution traces. 1227 * We therefore remove this flag: 1228 */ 1229 1230 cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES; 1231 } 1232} 1233 1234/* 1235 *---------------------------------------------------------------------- 1236 * 1237 * TraceCommandProc -- 1238 * 1239 * This function is called to handle command changes that have been 1240 * traced using the "trace" command, when using the 'rename' or 'delete' 1241 * options. 1242 * 1243 * Results: 1244 * None. 1245 * 1246 * Side effects: 1247 * Depends on the command associated with the trace. 1248 * 1249 *---------------------------------------------------------------------- 1250 */ 1251 1252 /* ARGSUSED */ 1253static void 1254TraceCommandProc( 1255 ClientData clientData, /* Information about the command trace. */ 1256 Tcl_Interp *interp, /* Interpreter containing command. */ 1257 const char *oldName, /* Name of command being changed. */ 1258 const char *newName, /* New name of command. Empty string or NULL 1259 * means command is being deleted (renamed to 1260 * ""). */ 1261 int flags) /* OR-ed bits giving operation and other 1262 * information. */ 1263{ 1264 TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; 1265 int code; 1266 Tcl_DString cmd; 1267 1268 tcmdPtr->refCount++; 1269 1270 if ((tcmdPtr->flags & flags) && !Tcl_InterpDeleted(interp) 1271 && !Tcl_LimitExceeded(interp)) { 1272 /* 1273 * Generate a command to execute by appending list elements for the 1274 * old and new command name and the operation. 1275 */ 1276 1277 Tcl_DStringInit(&cmd); 1278 Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); 1279 Tcl_DStringAppendElement(&cmd, oldName); 1280 Tcl_DStringAppendElement(&cmd, (newName ? newName : "")); 1281 if (flags & TCL_TRACE_RENAME) { 1282 Tcl_DStringAppend(&cmd, " rename", 7); 1283 } else if (flags & TCL_TRACE_DELETE) { 1284 Tcl_DStringAppend(&cmd, " delete", 7); 1285 } 1286 1287 /* 1288 * Execute the command. We discard any object result the command 1289 * returns. 1290 * 1291 * Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to other 1292 * areas that this will be destroyed by us, otherwise a double-free 1293 * might occur depending on what the eval does. 1294 */ 1295 1296 if (flags & TCL_TRACE_DESTROYED) { 1297 tcmdPtr->flags |= TCL_TRACE_DESTROYED; 1298 } 1299 code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), 1300 Tcl_DStringLength(&cmd), 0); 1301 if (code != TCL_OK) { 1302 /* We ignore errors in these traced commands */ 1303 /*** QUESTION: Use Tcl_BackgroundError(interp); instead? ***/ 1304 } 1305 Tcl_DStringFree(&cmd); 1306 } 1307 1308 /* 1309 * We delete when the trace was destroyed or if this is a delete trace, 1310 * because command deletes are unconditional, so the trace must go away. 1311 */ 1312 1313 if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) { 1314 int untraceFlags = tcmdPtr->flags; 1315 Tcl_InterpState state; 1316 1317 if (tcmdPtr->stepTrace != NULL) { 1318 Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); 1319 tcmdPtr->stepTrace = NULL; 1320 if (tcmdPtr->startCmd != NULL) { 1321 ckfree((char *) tcmdPtr->startCmd); 1322 } 1323 } 1324 if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { 1325 /* 1326 * Postpone deletion, until exec trace returns. 1327 */ 1328 1329 tcmdPtr->flags = 0; 1330 } 1331 1332 /* 1333 * We need to construct the same flags for Tcl_UntraceCommand as were 1334 * passed to Tcl_TraceCommand. Reproduce the processing of [trace add 1335 * execution/command]. Be careful to keep this code in sync with that. 1336 */ 1337 1338 if (untraceFlags & TCL_TRACE_ANY_EXEC) { 1339 untraceFlags |= TCL_TRACE_DELETE; 1340 if (untraceFlags & (TCL_TRACE_ENTER_DURING_EXEC 1341 | TCL_TRACE_LEAVE_DURING_EXEC)) { 1342 untraceFlags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); 1343 } 1344 } else if (untraceFlags & TCL_TRACE_RENAME) { 1345 untraceFlags |= TCL_TRACE_DELETE; 1346 } 1347 1348 /* 1349 * Remove the trace since TCL_TRACE_DESTROYED tells us to, or the 1350 * command we're tracing has just gone away. Then decrement the 1351 * clientData refCount that was set up by trace creation. 1352 * 1353 * Note that we save the (return) state of the interpreter to prevent 1354 * bizarre error messages. 1355 */ 1356 1357 state = Tcl_SaveInterpState(interp, TCL_OK); 1358 Tcl_UntraceCommand(interp, oldName, untraceFlags, 1359 TraceCommandProc, clientData); 1360 (void) Tcl_RestoreInterpState(interp, state); 1361 tcmdPtr->refCount--; 1362 } 1363 if ((--tcmdPtr->refCount) <= 0) { 1364 ckfree((char *) tcmdPtr); 1365 } 1366} 1367 1368/* 1369 *---------------------------------------------------------------------- 1370 * 1371 * TclCheckExecutionTraces -- 1372 * 1373 * Checks on all current command execution traces, and invokes functions 1374 * which have been registered. This function can be used by other code 1375 * which performs execution to unify the tracing system, so that 1376 * execution traces will function for that other code. 1377 * 1378 * For instance extensions like [incr Tcl] which use their own execution 1379 * technique can make use of Tcl's tracing. 1380 * 1381 * This function is called by 'TclEvalObjvInternal' 1382 * 1383 * Results: 1384 * The return value is a standard Tcl completion code such as TCL_OK or 1385 * TCL_ERROR, etc. 1386 * 1387 * Side effects: 1388 * Those side effects made by any trace functions called. 1389 * 1390 *---------------------------------------------------------------------- 1391 */ 1392 1393int 1394TclCheckExecutionTraces( 1395 Tcl_Interp *interp, /* The current interpreter. */ 1396 const char *command, /* Pointer to beginning of the current command 1397 * string. */ 1398 int numChars, /* The number of characters in 'command' which 1399 * are part of the command string. */ 1400 Command *cmdPtr, /* Points to command's Command struct. */ 1401 int code, /* The current result code. */ 1402 int traceFlags, /* Current tracing situation. */ 1403 int objc, /* Number of arguments for the command. */ 1404 Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ 1405{ 1406 Interp *iPtr = (Interp *) interp; 1407 CommandTrace *tracePtr, *lastTracePtr; 1408 ActiveCommandTrace active; 1409 int curLevel; 1410 int traceCode = TCL_OK; 1411 Tcl_InterpState state = NULL; 1412 1413 if (cmdPtr->tracePtr == NULL) { 1414 return traceCode; 1415 } 1416 1417 curLevel = iPtr->varFramePtr->level; 1418 1419 active.nextPtr = iPtr->activeCmdTracePtr; 1420 iPtr->activeCmdTracePtr = &active; 1421 1422 active.cmdPtr = cmdPtr; 1423 lastTracePtr = NULL; 1424 for (tracePtr = cmdPtr->tracePtr; 1425 (traceCode == TCL_OK) && (tracePtr != NULL); 1426 tracePtr = active.nextTracePtr) { 1427 if (traceFlags & TCL_TRACE_LEAVE_EXEC) { 1428 /* 1429 * Execute the trace command in order of creation for "leave". 1430 */ 1431 1432 active.reverseScan = 1; 1433 active.nextTracePtr = NULL; 1434 tracePtr = cmdPtr->tracePtr; 1435 while (tracePtr->nextPtr != lastTracePtr) { 1436 active.nextTracePtr = tracePtr; 1437 tracePtr = tracePtr->nextPtr; 1438 } 1439 } else { 1440 active.reverseScan = 0; 1441 active.nextTracePtr = tracePtr->nextPtr; 1442 } 1443 if (tracePtr->traceProc == TraceCommandProc) { 1444 TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) 1445 tracePtr->clientData; 1446 1447 if (tcmdPtr->flags != 0) { 1448 tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; 1449 tcmdPtr->curCode = code; 1450 tcmdPtr->refCount++; 1451 if (state == NULL) { 1452 state = Tcl_SaveInterpState(interp, code); 1453 } 1454 traceCode = TraceExecutionProc((ClientData) tcmdPtr, interp, 1455 curLevel, command, (Tcl_Command) cmdPtr, objc, objv); 1456 if ((--tcmdPtr->refCount) <= 0) { 1457 ckfree((char *) tcmdPtr); 1458 } 1459 } 1460 } 1461 if (active.nextTracePtr) { 1462 lastTracePtr = active.nextTracePtr->nextPtr; 1463 } 1464 } 1465 iPtr->activeCmdTracePtr = active.nextPtr; 1466 if (state) { 1467 (void) Tcl_RestoreInterpState(interp, state); 1468 } 1469 1470 return(traceCode); 1471} 1472 1473/* 1474 *---------------------------------------------------------------------- 1475 * 1476 * TclCheckInterpTraces -- 1477 * 1478 * Checks on all current traces, and invokes functions which have been 1479 * registered. This function can be used by other code which performs 1480 * execution to unify the tracing system. For instance extensions like 1481 * [incr Tcl] which use their own execution technique can make use of 1482 * Tcl's tracing. 1483 * 1484 * This function is called by 'TclEvalObjvInternal' 1485 * 1486 * Results: 1487 * The return value is a standard Tcl completion code such as TCL_OK or 1488 * TCL_ERROR, etc. 1489 * 1490 * Side effects: 1491 * Those side effects made by any trace functions called. 1492 * 1493 *---------------------------------------------------------------------- 1494 */ 1495 1496int 1497TclCheckInterpTraces( 1498 Tcl_Interp *interp, /* The current interpreter. */ 1499 const char *command, /* Pointer to beginning of the current command 1500 * string. */ 1501 int numChars, /* The number of characters in 'command' which 1502 * are part of the command string. */ 1503 Command *cmdPtr, /* Points to command's Command struct. */ 1504 int code, /* The current result code. */ 1505 int traceFlags, /* Current tracing situation. */ 1506 int objc, /* Number of arguments for the command. */ 1507 Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ 1508{ 1509 Interp *iPtr = (Interp *) interp; 1510 Trace *tracePtr, *lastTracePtr; 1511 ActiveInterpTrace active; 1512 int curLevel; 1513 int traceCode = TCL_OK; 1514 Tcl_InterpState state = NULL; 1515 1516 if ((iPtr->tracePtr == NULL) 1517 || (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) { 1518 return(traceCode); 1519 } 1520 1521 curLevel = iPtr->numLevels; 1522 1523 active.nextPtr = iPtr->activeInterpTracePtr; 1524 iPtr->activeInterpTracePtr = &active; 1525 1526 lastTracePtr = NULL; 1527 for (tracePtr = iPtr->tracePtr; 1528 (traceCode == TCL_OK) && (tracePtr != NULL); 1529 tracePtr = active.nextTracePtr) { 1530 if (traceFlags & TCL_TRACE_ENTER_EXEC) { 1531 /* 1532 * Execute the trace command in reverse order of creation for 1533 * "enterstep" operation. The order is changed for "enterstep" 1534 * instead of for "leavestep" as was done in 1535 * TclCheckExecutionTraces because for step traces, 1536 * Tcl_CreateObjTrace creates one more linked list of traces which 1537 * results in one more reversal of trace invocation. 1538 */ 1539 1540 active.reverseScan = 1; 1541 active.nextTracePtr = NULL; 1542 tracePtr = iPtr->tracePtr; 1543 while (tracePtr->nextPtr != lastTracePtr) { 1544 active.nextTracePtr = tracePtr; 1545 tracePtr = tracePtr->nextPtr; 1546 } 1547 if (active.nextTracePtr) { 1548 lastTracePtr = active.nextTracePtr->nextPtr; 1549 } 1550 } else { 1551 active.reverseScan = 0; 1552 active.nextTracePtr = tracePtr->nextPtr; 1553 } 1554 1555 if (tracePtr->level > 0 && curLevel > tracePtr->level) { 1556 continue; 1557 } 1558 1559 if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) { 1560 /* 1561 * The proc invoked might delete the traced command which which 1562 * might try to free tracePtr. We want to use tracePtr until the 1563 * end of this if section, so we use Tcl_Preserve() and 1564 * Tcl_Release() to be sure it is not freed while we still need 1565 * it. 1566 */ 1567 1568 Tcl_Preserve((ClientData) tracePtr); 1569 tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; 1570 if (state == NULL) { 1571 state = Tcl_SaveInterpState(interp, code); 1572 } 1573 1574 if (tracePtr->flags & 1575 (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) { 1576 /* 1577 * New style trace. 1578 */ 1579 1580 if (tracePtr->flags & traceFlags) { 1581 if (tracePtr->proc == TraceExecutionProc) { 1582 TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) 1583 tracePtr->clientData; 1584 1585 tcmdPtr->curFlags = traceFlags; 1586 tcmdPtr->curCode = code; 1587 } 1588 traceCode = (tracePtr->proc)(tracePtr->clientData, 1589 interp, curLevel, command, (Tcl_Command) cmdPtr, 1590 objc, objv); 1591 } 1592 } else { 1593 /* 1594 * Old-style trace. 1595 */ 1596 1597 if (traceFlags & TCL_TRACE_ENTER_EXEC) { 1598 /* 1599 * Old-style interpreter-wide traces only trigger before 1600 * the command is executed. 1601 */ 1602 1603 traceCode = CallTraceFunction(interp, tracePtr, cmdPtr, 1604 command, numChars, objc, objv); 1605 } 1606 } 1607 tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; 1608 Tcl_Release((ClientData) tracePtr); 1609 } 1610 } 1611 iPtr->activeInterpTracePtr = active.nextPtr; 1612 if (state) { 1613 if (traceCode == TCL_OK) { 1614 (void) Tcl_RestoreInterpState(interp, state); 1615 } else { 1616 Tcl_DiscardInterpState(state); 1617 } 1618 } 1619 1620 return(traceCode); 1621} 1622 1623/* 1624 *---------------------------------------------------------------------- 1625 * 1626 * CallTraceFunction -- 1627 * 1628 * Invokes a trace function registered with an interpreter. These 1629 * functions trace command execution. Currently this trace function is 1630 * called with the address of the string-based Tcl_CmdProc for the 1631 * command, not the Tcl_ObjCmdProc. 1632 * 1633 * Results: 1634 * None. 1635 * 1636 * Side effects: 1637 * Those side effects made by the trace function. 1638 * 1639 *---------------------------------------------------------------------- 1640 */ 1641 1642static int 1643CallTraceFunction( 1644 Tcl_Interp *interp, /* The current interpreter. */ 1645 register Trace *tracePtr, /* Describes the trace function to call. */ 1646 Command *cmdPtr, /* Points to command's Command struct. */ 1647 const char *command, /* Points to the first character of the 1648 * command's source before substitutions. */ 1649 int numChars, /* The number of characters in the command's 1650 * source. */ 1651 register int objc, /* Number of arguments for the command. */ 1652 Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ 1653{ 1654 Interp *iPtr = (Interp *) interp; 1655 char *commandCopy; 1656 int traceCode; 1657 1658 /* 1659 * Copy the command characters into a new string. 1660 */ 1661 1662 commandCopy = TclStackAlloc(interp, (unsigned) (numChars + 1)); 1663 memcpy(commandCopy, command, (size_t) numChars); 1664 commandCopy[numChars] = '\0'; 1665 1666 /* 1667 * Call the trace function then free allocated storage. 1668 */ 1669 1670 traceCode = (tracePtr->proc)(tracePtr->clientData, (Tcl_Interp *) iPtr, 1671 iPtr->numLevels, commandCopy, (Tcl_Command) cmdPtr, objc, objv); 1672 1673 TclStackFree(interp, commandCopy); 1674 return traceCode; 1675} 1676 1677/* 1678 *---------------------------------------------------------------------- 1679 * 1680 * CommandObjTraceDeleted -- 1681 * 1682 * Ensure the trace is correctly deleted by decrementing its refCount and 1683 * only deleting if no other references exist. 1684 * 1685 * Results: 1686 * None. 1687 * 1688 * Side effects: 1689 * May release memory. 1690 * 1691 *---------------------------------------------------------------------- 1692 */ 1693 1694static void 1695CommandObjTraceDeleted( 1696 ClientData clientData) 1697{ 1698 TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; 1699 1700 if ((--tcmdPtr->refCount) <= 0) { 1701 ckfree((char *) tcmdPtr); 1702 } 1703} 1704 1705/* 1706 *---------------------------------------------------------------------- 1707 * 1708 * TraceExecutionProc -- 1709 * 1710 * This function is invoked whenever code relevant to a 'trace execution' 1711 * command is executed. It is called in one of two ways in Tcl's core: 1712 * 1713 * (i) by the TclCheckExecutionTraces, when an execution trace has been 1714 * triggered. 1715 * (ii) by TclCheckInterpTraces, when a prior execution trace has created 1716 * a trace of the internals of a procedure, passing in this function as 1717 * the one to be called. 1718 * 1719 * Results: 1720 * The return value is a standard Tcl completion code such as TCL_OK or 1721 * TCL_ERROR, etc. 1722 * 1723 * Side effects: 1724 * May invoke an arbitrary Tcl procedure, and may create or delete an 1725 * interpreter-wide trace. 1726 * 1727 *---------------------------------------------------------------------- 1728 */ 1729 1730static int 1731TraceExecutionProc( 1732 ClientData clientData, 1733 Tcl_Interp *interp, 1734 int level, 1735 const char *command, 1736 Tcl_Command cmdInfo, 1737 int objc, 1738 struct Tcl_Obj *const objv[]) 1739{ 1740 int call = 0; 1741 Interp *iPtr = (Interp *) interp; 1742 TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; 1743 int flags = tcmdPtr->curFlags; 1744 int code = tcmdPtr->curCode; 1745 int traceCode = TCL_OK; 1746 1747 if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { 1748 /* 1749 * Inside any kind of execution trace callback, we do not allow any 1750 * further execution trace callbacks to be called for the same trace. 1751 */ 1752 1753 return traceCode; 1754 } 1755 1756 if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { 1757 /* 1758 * Check whether the current call is going to eval arbitrary Tcl code 1759 * with a generated trace, or whether we are only going to setup 1760 * interpreter-wide traces to implement the 'step' traces. This latter 1761 * situation can happen if we create a command trace without either 1762 * before or after operations, but with either of the step operations. 1763 */ 1764 1765 if (flags & TCL_TRACE_EXEC_DIRECT) { 1766 call = flags & tcmdPtr->flags & 1767 (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); 1768 } else { 1769 call = 1; 1770 } 1771 1772 /* 1773 * First, if we have returned back to the level at which we created an 1774 * interpreter trace for enterstep and/or leavestep execution traces, 1775 * we remove it here. 1776 */ 1777 1778 if ((flags & TCL_TRACE_LEAVE_EXEC) && (tcmdPtr->stepTrace != NULL) 1779 && (level == tcmdPtr->startLevel) 1780 && (strcmp(command, tcmdPtr->startCmd) == 0)) { 1781 Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); 1782 tcmdPtr->stepTrace = NULL; 1783 if (tcmdPtr->startCmd != NULL) { 1784 ckfree((char *) tcmdPtr->startCmd); 1785 } 1786 } 1787 1788 /* 1789 * Second, create the tcl callback, if required. 1790 */ 1791 1792 if (call) { 1793 Tcl_DString cmd; 1794 Tcl_DString sub; 1795 int i, saveInterpFlags; 1796 1797 Tcl_DStringInit(&cmd); 1798 Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length); 1799 1800 /* 1801 * Append command with arguments. 1802 */ 1803 1804 Tcl_DStringInit(&sub); 1805 for (i = 0; i < objc; i++) { 1806 Tcl_DStringAppendElement(&sub, Tcl_GetString(objv[i])); 1807 } 1808 Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub)); 1809 Tcl_DStringFree(&sub); 1810 1811 if (flags & TCL_TRACE_ENTER_EXEC) { 1812 /* 1813 * Append trace operation. 1814 */ 1815 1816 if (flags & TCL_TRACE_EXEC_DIRECT) { 1817 Tcl_DStringAppendElement(&cmd, "enter"); 1818 } else { 1819 Tcl_DStringAppendElement(&cmd, "enterstep"); 1820 } 1821 } else if (flags & TCL_TRACE_LEAVE_EXEC) { 1822 Tcl_Obj *resultCode; 1823 char *resultCodeStr; 1824 1825 /* 1826 * Append result code. 1827 */ 1828 1829 resultCode = Tcl_NewIntObj(code); 1830 resultCodeStr = Tcl_GetString(resultCode); 1831 Tcl_DStringAppendElement(&cmd, resultCodeStr); 1832 Tcl_DecrRefCount(resultCode); 1833 1834 /* 1835 * Append result string. 1836 */ 1837 1838 Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp)); 1839 1840 /* 1841 * Append trace operation. 1842 */ 1843 1844 if (flags & TCL_TRACE_EXEC_DIRECT) { 1845 Tcl_DStringAppendElement(&cmd, "leave"); 1846 } else { 1847 Tcl_DStringAppendElement(&cmd, "leavestep"); 1848 } 1849 } else { 1850 Tcl_Panic("TraceExecutionProc: bad flag combination"); 1851 } 1852 1853 /* 1854 * Execute the command. We discard any object result the command 1855 * returns. 1856 */ 1857 1858 saveInterpFlags = iPtr->flags; 1859 iPtr->flags |= INTERP_TRACE_IN_PROGRESS; 1860 tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; 1861 tcmdPtr->refCount++; 1862 1863 /* 1864 * This line can have quite arbitrary side-effects, including 1865 * deleting the trace, the command being traced, or even the 1866 * interpreter. 1867 */ 1868 1869 traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); 1870 tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; 1871 1872 /* 1873 * Restore the interp tracing flag to prevent cmd traces from 1874 * affecting interp traces. 1875 */ 1876 1877 iPtr->flags = saveInterpFlags; 1878 if (tcmdPtr->flags == 0) { 1879 flags |= TCL_TRACE_DESTROYED; 1880 } 1881 Tcl_DStringFree(&cmd); 1882 } 1883 1884 /* 1885 * Third, if there are any step execution traces for this proc, we 1886 * register an interpreter trace to invoke enterstep and/or leavestep 1887 * traces. We also need to save the current stack level and the proc 1888 * string in startLevel and startCmd so that we can delete this 1889 * interpreter trace when it reaches the end of this proc. 1890 */ 1891 1892 if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL) 1893 && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | 1894 TCL_TRACE_LEAVE_DURING_EXEC))) { 1895 register unsigned len = strlen(command) + 1; 1896 1897 tcmdPtr->startLevel = level; 1898 tcmdPtr->startCmd = ckalloc(len); 1899 memcpy(tcmdPtr->startCmd, command, len); 1900 tcmdPtr->refCount++; 1901 tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, 1902 (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, 1903 TraceExecutionProc, (ClientData)tcmdPtr, 1904 CommandObjTraceDeleted); 1905 } 1906 } 1907 if (flags & TCL_TRACE_DESTROYED) { 1908 if (tcmdPtr->stepTrace != NULL) { 1909 Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); 1910 tcmdPtr->stepTrace = NULL; 1911 if (tcmdPtr->startCmd != NULL) { 1912 ckfree(tcmdPtr->startCmd); 1913 } 1914 } 1915 } 1916 if (call) { 1917 if ((--tcmdPtr->refCount) <= 0) { 1918 ckfree((char *) tcmdPtr); 1919 } 1920 } 1921 return traceCode; 1922} 1923 1924/* 1925 *---------------------------------------------------------------------- 1926 * 1927 * TraceVarProc -- 1928 * 1929 * This function is called to handle variable accesses that have been 1930 * traced using the "trace" command. 1931 * 1932 * Results: 1933 * Normally returns NULL. If the trace command returns an error, then 1934 * this function returns an error string. 1935 * 1936 * Side effects: 1937 * Depends on the command associated with the trace. 1938 * 1939 *---------------------------------------------------------------------- 1940 */ 1941 1942 /* ARGSUSED */ 1943static char * 1944TraceVarProc( 1945 ClientData clientData, /* Information about the variable trace. */ 1946 Tcl_Interp *interp, /* Interpreter containing variable. */ 1947 const char *name1, /* Name of variable or array. */ 1948 const char *name2, /* Name of element within array; NULL means 1949 * scalar variable is being referenced. */ 1950 int flags) /* OR-ed bits giving operation and other 1951 * information. */ 1952{ 1953 TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; 1954 char *result; 1955 int code, destroy = 0; 1956 Tcl_DString cmd; 1957 1958 /* 1959 * We might call Tcl_Eval() below, and that might evaluate [trace vdelete] 1960 * which might try to free tvarPtr. We want to use tvarPtr until the end 1961 * of this function, so we use Tcl_Preserve() and Tcl_Release() to be sure 1962 * it is not freed while we still need it. 1963 */ 1964 1965 result = NULL; 1966 if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp) 1967 && !Tcl_LimitExceeded(interp)) { 1968 if (tvarPtr->length != (size_t) 0) { 1969 /* 1970 * Generate a command to execute by appending list elements for 1971 * the two variable names and the operation. 1972 */ 1973 1974 Tcl_DStringInit(&cmd); 1975 Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); 1976 Tcl_DStringAppendElement(&cmd, name1); 1977 Tcl_DStringAppendElement(&cmd, (name2 ? name2 : "")); 1978#ifndef TCL_REMOVE_OBSOLETE_TRACES 1979 if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) { 1980 if (flags & TCL_TRACE_ARRAY) { 1981 Tcl_DStringAppend(&cmd, " a", 2); 1982 } else if (flags & TCL_TRACE_READS) { 1983 Tcl_DStringAppend(&cmd, " r", 2); 1984 } else if (flags & TCL_TRACE_WRITES) { 1985 Tcl_DStringAppend(&cmd, " w", 2); 1986 } else if (flags & TCL_TRACE_UNSETS) { 1987 Tcl_DStringAppend(&cmd, " u", 2); 1988 } 1989 } else { 1990#endif 1991 if (flags & TCL_TRACE_ARRAY) { 1992 Tcl_DStringAppend(&cmd, " array", 6); 1993 } else if (flags & TCL_TRACE_READS) { 1994 Tcl_DStringAppend(&cmd, " read", 5); 1995 } else if (flags & TCL_TRACE_WRITES) { 1996 Tcl_DStringAppend(&cmd, " write", 6); 1997 } else if (flags & TCL_TRACE_UNSETS) { 1998 Tcl_DStringAppend(&cmd, " unset", 6); 1999 } 2000#ifndef TCL_REMOVE_OBSOLETE_TRACES 2001 } 2002#endif 2003 2004 /* 2005 * Execute the command. We discard any object result the command 2006 * returns. 2007 * 2008 * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to 2009 * other areas that this will be destroyed by us, otherwise a 2010 * double-free might occur depending on what the eval does. 2011 */ 2012 2013 if ((flags & TCL_TRACE_DESTROYED) 2014 && !(tvarPtr->flags & TCL_TRACE_DESTROYED)) { 2015 destroy = 1; 2016 tvarPtr->flags |= TCL_TRACE_DESTROYED; 2017 } 2018 code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), 2019 Tcl_DStringLength(&cmd), 0); 2020 if (code != TCL_OK) { /* copy error msg to result */ 2021 Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); 2022 Tcl_IncrRefCount(errMsgObj); 2023 result = (char *) errMsgObj; 2024 } 2025 Tcl_DStringFree(&cmd); 2026 } 2027 } 2028 if (destroy && result != NULL) { 2029 register Tcl_Obj *errMsgObj = (Tcl_Obj *) result; 2030 2031 Tcl_DecrRefCount(errMsgObj); 2032 result = NULL; 2033 } 2034 return result; 2035} 2036 2037/* 2038 *---------------------------------------------------------------------- 2039 * 2040 * Tcl_CreateObjTrace -- 2041 * 2042 * Arrange for a function to be called to trace command execution. 2043 * 2044 * Results: 2045 * The return value is a token for the trace, which may be passed to 2046 * Tcl_DeleteTrace to eliminate the trace. 2047 * 2048 * Side effects: 2049 * From now on, proc will be called just before a command function is 2050 * called to execute a Tcl command. Calls to proc will have the following 2051 * form: 2052 * 2053 * void proc(ClientData clientData, 2054 * Tcl_Interp * interp, 2055 * int level, 2056 * const char * command, 2057 * Tcl_Command commandInfo, 2058 * int objc, 2059 * Tcl_Obj *const objv[]); 2060 * 2061 * The 'clientData' and 'interp' arguments to 'proc' will be the same as 2062 * the arguments to Tcl_CreateObjTrace. The 'level' argument gives the 2063 * nesting depth of command interpretation within the interpreter. The 2064 * 'command' argument is the ASCII text of the command being evaluated - 2065 * before any substitutions are performed. The 'commandInfo' argument 2066 * gives a handle to the command procedure that will be evaluated. The 2067 * 'objc' and 'objv' parameters give the parameter vector that will be 2068 * passed to the command procedure. Proc does not return a value. 2069 * 2070 * It is permissible for 'proc' to call Tcl_SetCommandTokenInfo to change 2071 * the command procedure or client data for the command being evaluated, 2072 * and these changes will take effect with the current evaluation. 2073 * 2074 * The 'level' argument specifies the maximum nesting level of calls to 2075 * be traced. If the execution depth of the interpreter exceeds 'level', 2076 * the trace callback is not executed. 2077 * 2078 * The 'flags' argument is either zero or the value, 2079 * TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION flag 2080 * is not present, the bytecode compiler will not generate inline code 2081 * for Tcl's built-in commands. This behavior will have a significant 2082 * impact on performance, but will ensure that all command evaluations 2083 * are traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the 2084 * bytecode compiler will have its normal behavior of compiling in-line 2085 * code for some of Tcl's built-in commands. In this case, the tracing 2086 * will be imprecise - in-line code will not be traced - but run-time 2087 * performance will be improved. The latter behavior is desired for many 2088 * applications such as profiling of run time. 2089 * 2090 * When the trace is deleted, the 'delProc' function will be invoked, 2091 * passing it the original client data. 2092 * 2093 *---------------------------------------------------------------------- 2094 */ 2095 2096Tcl_Trace 2097Tcl_CreateObjTrace( 2098 Tcl_Interp *interp, /* Tcl interpreter */ 2099 int level, /* Maximum nesting level */ 2100 int flags, /* Flags, see above */ 2101 Tcl_CmdObjTraceProc *proc, /* Trace callback */ 2102 ClientData clientData, /* Client data for the callback */ 2103 Tcl_CmdObjTraceDeleteProc *delProc) 2104 /* Function to call when trace is deleted */ 2105{ 2106 register Trace *tracePtr; 2107 register Interp *iPtr = (Interp *) interp; 2108 2109 /* 2110 * Test if this trace allows inline compilation of commands. 2111 */ 2112 2113 if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) { 2114 if (iPtr->tracesForbiddingInline == 0) { 2115 /* 2116 * When the first trace forbidding inline compilation is created, 2117 * invalidate existing compiled code for this interpreter and 2118 * arrange (by setting the DONT_COMPILE_CMDS_INLINE flag) that 2119 * when compiling new code, no commands will be compiled inline 2120 * (i.e., into an inline sequence of instructions). We do this 2121 * because commands that were compiled inline will never result in 2122 * a command trace being called. 2123 */ 2124 2125 iPtr->compileEpoch++; 2126 iPtr->flags |= DONT_COMPILE_CMDS_INLINE; 2127 } 2128 iPtr->tracesForbiddingInline++; 2129 } 2130 2131 tracePtr = (Trace *) ckalloc(sizeof(Trace)); 2132 tracePtr->level = level; 2133 tracePtr->proc = proc; 2134 tracePtr->clientData = clientData; 2135 tracePtr->delProc = delProc; 2136 tracePtr->nextPtr = iPtr->tracePtr; 2137 tracePtr->flags = flags; 2138 iPtr->tracePtr = tracePtr; 2139 2140 return (Tcl_Trace) tracePtr; 2141} 2142 2143/* 2144 *---------------------------------------------------------------------- 2145 * 2146 * Tcl_CreateTrace -- 2147 * 2148 * Arrange for a function to be called to trace command execution. 2149 * 2150 * Results: 2151 * The return value is a token for the trace, which may be passed to 2152 * Tcl_DeleteTrace to eliminate the trace. 2153 * 2154 * Side effects: 2155 * From now on, proc will be called just before a command procedure is 2156 * called to execute a Tcl command. Calls to proc will have the following 2157 * form: 2158 * 2159 * void 2160 * proc(clientData, interp, level, command, cmdProc, cmdClientData, 2161 * argc, argv) 2162 * ClientData clientData; 2163 * Tcl_Interp *interp; 2164 * int level; 2165 * char *command; 2166 * int (*cmdProc)(); 2167 * ClientData cmdClientData; 2168 * int argc; 2169 * char **argv; 2170 * { 2171 * } 2172 * 2173 * The clientData and interp arguments to proc will be the same as the 2174 * corresponding arguments to this function. Level gives the nesting 2175 * level of command interpretation for this interpreter (0 corresponds to 2176 * top level). Command gives the ASCII text of the raw command, cmdProc 2177 * and cmdClientData give the function that will be called to process the 2178 * command and the ClientData value it will receive, and argc and argv 2179 * give the arguments to the command, after any argument parsing and 2180 * substitution. Proc does not return a value. 2181 * 2182 *---------------------------------------------------------------------- 2183 */ 2184 2185Tcl_Trace 2186Tcl_CreateTrace( 2187 Tcl_Interp *interp, /* Interpreter in which to create trace. */ 2188 int level, /* Only call proc for commands at nesting 2189 * level<=argument level (1=>top level). */ 2190 Tcl_CmdTraceProc *proc, /* Function to call before executing each 2191 * command. */ 2192 ClientData clientData) /* Arbitrary value word to pass to proc. */ 2193{ 2194 StringTraceData *data = (StringTraceData *) 2195 ckalloc(sizeof(StringTraceData)); 2196 2197 data->clientData = clientData; 2198 data->proc = proc; 2199 return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc, 2200 (ClientData) data, StringTraceDeleteProc); 2201} 2202 2203/* 2204 *---------------------------------------------------------------------- 2205 * 2206 * StringTraceProc -- 2207 * 2208 * Invoke a string-based trace function from an object-based callback. 2209 * 2210 * Results: 2211 * None. 2212 * 2213 * Side effects: 2214 * Whatever the string-based trace function does. 2215 * 2216 *---------------------------------------------------------------------- 2217 */ 2218 2219static int 2220StringTraceProc( 2221 ClientData clientData, 2222 Tcl_Interp *interp, 2223 int level, 2224 const char *command, 2225 Tcl_Command commandInfo, 2226 int objc, 2227 Tcl_Obj *const *objv) 2228{ 2229 StringTraceData *data = (StringTraceData *) clientData; 2230 Command *cmdPtr = (Command *) commandInfo; 2231 const char **argv; /* Args to pass to string trace proc */ 2232 int i; 2233 2234 /* 2235 * This is a bit messy because we have to emulate the old trace interface, 2236 * which uses strings for everything. 2237 */ 2238 2239 argv = (const char **) TclStackAlloc(interp, 2240 (unsigned) ((objc + 1) * sizeof(const char *))); 2241 for (i = 0; i < objc; i++) { 2242 argv[i] = Tcl_GetString(objv[i]); 2243 } 2244 argv[objc] = 0; 2245 2246 /* 2247 * Invoke the command function. Note that we cast away const-ness on two 2248 * parameters for compatibility with legacy code; the code MUST NOT modify 2249 * either command or argv. 2250 */ 2251 2252 (data->proc)(data->clientData, interp, level, (char *) command, 2253 cmdPtr->proc, cmdPtr->clientData, objc, argv); 2254 TclStackFree(interp, (void *) argv); 2255 2256 return TCL_OK; 2257} 2258 2259/* 2260 *---------------------------------------------------------------------- 2261 * 2262 * StringTraceDeleteProc -- 2263 * 2264 * Clean up memory when a string-based trace is deleted. 2265 * 2266 * Results: 2267 * None. 2268 * 2269 * Side effects: 2270 * Allocated memory is returned to the system. 2271 * 2272 *---------------------------------------------------------------------- 2273 */ 2274 2275static void 2276StringTraceDeleteProc( 2277 ClientData clientData) 2278{ 2279 ckfree((char *) clientData); 2280} 2281 2282/* 2283 *---------------------------------------------------------------------- 2284 * 2285 * Tcl_DeleteTrace -- 2286 * 2287 * Remove a trace. 2288 * 2289 * Results: 2290 * None. 2291 * 2292 * Side effects: 2293 * From now on there will be no more calls to the function given in 2294 * trace. 2295 * 2296 *---------------------------------------------------------------------- 2297 */ 2298 2299void 2300Tcl_DeleteTrace( 2301 Tcl_Interp *interp, /* Interpreter that contains trace. */ 2302 Tcl_Trace trace) /* Token for trace (returned previously by 2303 * Tcl_CreateTrace). */ 2304{ 2305 Interp *iPtr = (Interp *) interp; 2306 Trace *prevPtr, *tracePtr = (Trace *) trace; 2307 register Trace **tracePtr2 = &(iPtr->tracePtr); 2308 ActiveInterpTrace *activePtr; 2309 2310 /* 2311 * Locate the trace entry in the interpreter's trace list, and remove it 2312 * from the list. 2313 */ 2314 2315 prevPtr = NULL; 2316 while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) { 2317 prevPtr = *tracePtr2; 2318 tracePtr2 = &((*tracePtr2)->nextPtr); 2319 } 2320 if (*tracePtr2 == NULL) { 2321 return; 2322 } 2323 (*tracePtr2) = (*tracePtr2)->nextPtr; 2324 2325 /* 2326 * The code below makes it possible to delete traces while traces are 2327 * active: it makes sure that the deleted trace won't be processed by 2328 * TclCheckInterpTraces. 2329 */ 2330 2331 for (activePtr = iPtr->activeInterpTracePtr; activePtr != NULL; 2332 activePtr = activePtr->nextPtr) { 2333 if (activePtr->nextTracePtr == tracePtr) { 2334 if (activePtr->reverseScan) { 2335 activePtr->nextTracePtr = prevPtr; 2336 } else { 2337 activePtr->nextTracePtr = tracePtr->nextPtr; 2338 } 2339 } 2340 } 2341 2342 /* 2343 * If the trace forbids bytecode compilation, change the interpreter's 2344 * state. If bytecode compilation is now permitted, flag the fact and 2345 * advance the compilation epoch so that procs will be recompiled to take 2346 * advantage of it. 2347 */ 2348 2349 if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) { 2350 iPtr->tracesForbiddingInline--; 2351 if (iPtr->tracesForbiddingInline == 0) { 2352 iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; 2353 iPtr->compileEpoch++; 2354 } 2355 } 2356 2357 /* 2358 * Execute any delete callback. 2359 */ 2360 2361 if (tracePtr->delProc != NULL) { 2362 (tracePtr->delProc)(tracePtr->clientData); 2363 } 2364 2365 /* 2366 * Delete the trace object. 2367 */ 2368 2369 Tcl_EventuallyFree((char *) tracePtr, TCL_DYNAMIC); 2370} 2371 2372/* 2373 *---------------------------------------------------------------------- 2374 * 2375 * TclTraceVarExists -- 2376 * 2377 * This is called from info exists. We need to trigger read and/or array 2378 * traces because they may end up creating a variable that doesn't 2379 * currently exist. 2380 * 2381 * Results: 2382 * A pointer to the Var structure, or NULL. 2383 * 2384 * Side effects: 2385 * May fill in error messages in the interp. 2386 * 2387 *---------------------------------------------------------------------- 2388 */ 2389 2390Var * 2391TclVarTraceExists( 2392 Tcl_Interp *interp, /* The interpreter */ 2393 const char *varName) /* The variable name */ 2394{ 2395 Var *varPtr; 2396 Var *arrayPtr; 2397 2398 /* 2399 * The choice of "create" flag values is delicate here, and matches the 2400 * semantics of GetVar. Things are still not perfect, however, because if 2401 * you do "info exists x" you get a varPtr and therefore trigger traces. 2402 * However, if you do "info exists x(i)", then you only get a varPtr if x 2403 * is already known to be an array. Otherwise you get NULL, and no trace 2404 * is triggered. This matches Tcl 7.6 semantics. 2405 */ 2406 2407 varPtr = TclLookupVar(interp, varName, NULL, 0, "access", 2408 /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); 2409 2410 if (varPtr == NULL) { 2411 return NULL; 2412 } 2413 2414 if ((varPtr->flags & VAR_TRACED_READ) 2415 || (arrayPtr && (arrayPtr->flags & VAR_TRACED_READ))) { 2416 TclCallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL, 2417 TCL_TRACE_READS, /* leaveErrMsg */ 0); 2418 } 2419 2420 /* 2421 * If the variable doesn't exist anymore and no-one's using it, then free 2422 * up the relevant structures and hash table entries. 2423 */ 2424 2425 if (TclIsVarUndefined(varPtr)) { 2426 TclCleanupVar(varPtr, arrayPtr); 2427 return NULL; 2428 } 2429 2430 return varPtr; 2431} 2432 2433/* 2434 *---------------------------------------------------------------------- 2435 * 2436 * TclCallVarTraces -- 2437 * 2438 * This function is invoked to find and invoke relevant trace functions 2439 * associated with a particular operation on a variable. This function 2440 * invokes traces both on the variable and on its containing array (where 2441 * relevant). 2442 * 2443 * Results: 2444 * Returns TCL_OK to indicate normal operation. Returns TCL_ERROR if 2445 * invocation of a trace function indicated an error. When TCL_ERROR is 2446 * returned and leaveErrMsg is true, then the errorInfo field of iPtr has 2447 * information about the error placed in it. 2448 * 2449 * Side effects: 2450 * Almost anything can happen, depending on trace; this function itself 2451 * doesn't have any side effects. 2452 * 2453 *---------------------------------------------------------------------- 2454 */ 2455 2456int 2457TclObjCallVarTraces( 2458 Interp *iPtr, /* Interpreter containing variable. */ 2459 register Var *arrayPtr, /* Pointer to array variable that contains the 2460 * variable, or NULL if the variable isn't an 2461 * element of an array. */ 2462 Var *varPtr, /* Variable whose traces are to be invoked. */ 2463 Tcl_Obj *part1Ptr, 2464 Tcl_Obj *part2Ptr, /* Variable's two-part name. */ 2465 int flags, /* Flags passed to trace functions: indicates 2466 * what's happening to variable, plus maybe 2467 * TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY */ 2468 int leaveErrMsg, /* If true, and one of the traces indicates an 2469 * error, then leave an error message and 2470 * stack trace information in *iPTr. */ 2471 int index) /* Index into the local variable table of the 2472 * variable, or -1. Only used when part1Ptr is 2473 * NULL. */ 2474{ 2475 char *part1, *part2; 2476 2477 if (!part1Ptr) { 2478 part1Ptr = localName(iPtr->varFramePtr, index); 2479 } 2480 part1 = TclGetString(part1Ptr); 2481 part2 = part2Ptr? TclGetString(part2Ptr) : NULL; 2482 2483 return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, 2484 leaveErrMsg); 2485} 2486 2487int 2488TclCallVarTraces( 2489 Interp *iPtr, /* Interpreter containing variable. */ 2490 register Var *arrayPtr, /* Pointer to array variable that contains the 2491 * variable, or NULL if the variable isn't an 2492 * element of an array. */ 2493 Var *varPtr, /* Variable whose traces are to be invoked. */ 2494 const char *part1, 2495 const char *part2, /* Variable's two-part name. */ 2496 int flags, /* Flags passed to trace functions: indicates 2497 * what's happening to variable, plus maybe 2498 * TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY */ 2499 int leaveErrMsg) /* If true, and one of the traces indicates an 2500 * error, then leave an error message and 2501 * stack trace information in *iPTr. */ 2502{ 2503 register VarTrace *tracePtr; 2504 ActiveVarTrace active; 2505 char *result; 2506 const char *openParen, *p; 2507 Tcl_DString nameCopy; 2508 int copiedName; 2509 int code = TCL_OK; 2510 int disposeFlags = 0; 2511 Tcl_InterpState state = NULL; 2512 Tcl_HashEntry *hPtr; 2513 int traceflags = flags & VAR_ALL_TRACES; 2514 2515 /* 2516 * If there are already similar trace functions active for the variable, 2517 * don't call them again. 2518 */ 2519 2520 if (TclIsVarTraceActive(varPtr)) { 2521 return code; 2522 } 2523 TclSetVarTraceActive(varPtr); 2524 if (TclIsVarInHash(varPtr)) { 2525 VarHashRefCount(varPtr)++; 2526 } 2527 if (arrayPtr && TclIsVarInHash(arrayPtr)) { 2528 VarHashRefCount(arrayPtr)++; 2529 } 2530 2531 /* 2532 * If the variable name hasn't been parsed into array name and element, do 2533 * it here. If there really is an array element, make a copy of the 2534 * original name so that NULLs can be inserted into it to separate the 2535 * names (can't modify the name string in place, because the string might 2536 * get used by the callbacks we invoke). 2537 */ 2538 2539 copiedName = 0; 2540 if (part2 == NULL) { 2541 for (p = part1; *p ; p++) { 2542 if (*p == '(') { 2543 openParen = p; 2544 do { 2545 p++; 2546 } while (*p != '\0'); 2547 p--; 2548 if (*p == ')') { 2549 int offset = (openParen - part1); 2550 char *newPart1; 2551 2552 Tcl_DStringInit(&nameCopy); 2553 Tcl_DStringAppend(&nameCopy, part1, (p-part1)); 2554 newPart1 = Tcl_DStringValue(&nameCopy); 2555 newPart1[offset] = 0; 2556 part1 = newPart1; 2557 part2 = newPart1 + offset + 1; 2558 copiedName = 1; 2559 } 2560 break; 2561 } 2562 } 2563 } 2564 2565 /* 2566 * Ignore any caller-provided TCL_INTERP_DESTROYED flag. Only we can 2567 * set it correctly. 2568 */ 2569 2570 flags &= ~TCL_INTERP_DESTROYED; 2571 2572 /* 2573 * Invoke traces on the array containing the variable, if relevant. 2574 */ 2575 2576 result = NULL; 2577 active.nextPtr = iPtr->activeVarTracePtr; 2578 iPtr->activeVarTracePtr = &active; 2579 Tcl_Preserve((ClientData) iPtr); 2580 if (arrayPtr && !TclIsVarTraceActive(arrayPtr) 2581 && (arrayPtr->flags & traceflags)) { 2582 hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) arrayPtr); 2583 active.varPtr = arrayPtr; 2584 for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr); 2585 tracePtr != NULL; tracePtr = active.nextTracePtr) { 2586 active.nextTracePtr = tracePtr->nextPtr; 2587 if (!(tracePtr->flags & flags)) { 2588 continue; 2589 } 2590 Tcl_Preserve((ClientData) tracePtr); 2591 if (state == NULL) { 2592 state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code); 2593 } 2594 if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) { 2595 flags |= TCL_INTERP_DESTROYED; 2596 } 2597 result = (*tracePtr->traceProc)(tracePtr->clientData, 2598 (Tcl_Interp *) iPtr, part1, part2, flags); 2599 if (result != NULL) { 2600 if (flags & TCL_TRACE_UNSETS) { 2601 /* 2602 * Ignore errors in unset traces. 2603 */ 2604 2605 DisposeTraceResult(tracePtr->flags, result); 2606 } else { 2607 disposeFlags = tracePtr->flags; 2608 code = TCL_ERROR; 2609 } 2610 } 2611 Tcl_Release((ClientData) tracePtr); 2612 if (code == TCL_ERROR) { 2613 goto done; 2614 } 2615 } 2616 } 2617 2618 /* 2619 * Invoke traces on the variable itself. 2620 */ 2621 2622 if (flags & TCL_TRACE_UNSETS) { 2623 flags |= TCL_TRACE_DESTROYED; 2624 } 2625 active.varPtr = varPtr; 2626 if (varPtr->flags & traceflags) { 2627 hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); 2628 for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr); 2629 tracePtr != NULL; tracePtr = active.nextTracePtr) { 2630 active.nextTracePtr = tracePtr->nextPtr; 2631 if (!(tracePtr->flags & flags)) { 2632 continue; 2633 } 2634 Tcl_Preserve((ClientData) tracePtr); 2635 if (state == NULL) { 2636 state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code); 2637 } 2638 if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) { 2639 flags |= TCL_INTERP_DESTROYED; 2640 } 2641 result = (*tracePtr->traceProc)(tracePtr->clientData, 2642 (Tcl_Interp *) iPtr, part1, part2, flags); 2643 if (result != NULL) { 2644 if (flags & TCL_TRACE_UNSETS) { 2645 /* 2646 * Ignore errors in unset traces. 2647 */ 2648 2649 DisposeTraceResult(tracePtr->flags, result); 2650 } else { 2651 disposeFlags = tracePtr->flags; 2652 code = TCL_ERROR; 2653 } 2654 } 2655 Tcl_Release((ClientData) tracePtr); 2656 if (code == TCL_ERROR) { 2657 goto done; 2658 } 2659 } 2660 } 2661 2662 /* 2663 * Restore the variable's flags, remove the record of our active traces, 2664 * and then return. 2665 */ 2666 2667 done: 2668 if (code == TCL_ERROR) { 2669 if (leaveErrMsg) { 2670 const char *verb = ""; 2671 const char *type = ""; 2672 2673 switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) { 2674 case TCL_TRACE_READS: 2675 verb = "read"; 2676 type = verb; 2677 break; 2678 case TCL_TRACE_WRITES: 2679 verb = "set"; 2680 type = "write"; 2681 break; 2682 case TCL_TRACE_ARRAY: 2683 verb = "trace array"; 2684 type = "array"; 2685 break; 2686 } 2687 2688 if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { 2689 Tcl_SetObjResult((Tcl_Interp *)iPtr, (Tcl_Obj *) result); 2690 } else { 2691 Tcl_SetResult((Tcl_Interp *)iPtr, result, TCL_STATIC); 2692 } 2693 Tcl_AddErrorInfo((Tcl_Interp *)iPtr, ""); 2694 2695 Tcl_AppendObjToErrorInfo((Tcl_Interp *)iPtr, Tcl_ObjPrintf( 2696 "\n (%s trace on \"%s%s%s%s\")", type, part1, 2697 (part2 ? "(" : ""), (part2 ? part2 : ""), 2698 (part2 ? ")" : "") )); 2699 if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { 2700 TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, 2701 Tcl_GetString((Tcl_Obj *) result)); 2702 } else { 2703 TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, result); 2704 } 2705 iPtr->flags &= ~(ERR_ALREADY_LOGGED); 2706 Tcl_DiscardInterpState(state); 2707 } else { 2708 (void) Tcl_RestoreInterpState((Tcl_Interp *)iPtr, state); 2709 } 2710 DisposeTraceResult(disposeFlags,result); 2711 } else if (state) { 2712 if (code == TCL_OK) { 2713 code = Tcl_RestoreInterpState((Tcl_Interp *)iPtr, state); 2714 } else { 2715 Tcl_DiscardInterpState(state); 2716 } 2717 } 2718 2719 if (arrayPtr && TclIsVarInHash(arrayPtr)) { 2720 VarHashRefCount(arrayPtr)--; 2721 } 2722 if (copiedName) { 2723 Tcl_DStringFree(&nameCopy); 2724 } 2725 TclClearVarTraceActive(varPtr); 2726 if (TclIsVarInHash(varPtr)) { 2727 VarHashRefCount(varPtr)--; 2728 } 2729 iPtr->activeVarTracePtr = active.nextPtr; 2730 Tcl_Release((ClientData) iPtr); 2731 return code; 2732} 2733 2734/* 2735 *---------------------------------------------------------------------- 2736 * 2737 * DisposeTraceResult-- 2738 * 2739 * This function is called to dispose of the result returned from a trace 2740 * function. The disposal method appropriate to the type of result is 2741 * determined by flags. 2742 * 2743 * Results: 2744 * None. 2745 * 2746 * Side effects: 2747 * The memory allocated for the trace result may be freed. 2748 * 2749 *---------------------------------------------------------------------- 2750 */ 2751 2752static void 2753DisposeTraceResult( 2754 int flags, /* Indicates type of result to determine 2755 * proper disposal method. */ 2756 char *result) /* The result returned from a trace function 2757 * to be disposed. */ 2758{ 2759 if (flags & TCL_TRACE_RESULT_DYNAMIC) { 2760 ckfree(result); 2761 } else if (flags & TCL_TRACE_RESULT_OBJECT) { 2762 Tcl_DecrRefCount((Tcl_Obj *) result); 2763 } 2764} 2765 2766/* 2767 *---------------------------------------------------------------------- 2768 * 2769 * Tcl_UntraceVar -- 2770 * 2771 * Remove a previously-created trace for a variable. 2772 * 2773 * Results: 2774 * None. 2775 * 2776 * Side effects: 2777 * If there exists a trace for the variable given by varName with the 2778 * given flags, proc, and clientData, then that trace is removed. 2779 * 2780 *---------------------------------------------------------------------- 2781 */ 2782 2783void 2784Tcl_UntraceVar( 2785 Tcl_Interp *interp, /* Interpreter containing variable. */ 2786 const char *varName, /* Name of variable; may end with "(index)" to 2787 * signify an array reference. */ 2788 int flags, /* OR-ed collection of bits describing current 2789 * trace, including any of TCL_TRACE_READS, 2790 * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, 2791 * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY. */ 2792 Tcl_VarTraceProc *proc, /* Function assocated with trace. */ 2793 ClientData clientData) /* Arbitrary argument to pass to proc. */ 2794{ 2795 Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData); 2796} 2797 2798/* 2799 *---------------------------------------------------------------------- 2800 * 2801 * Tcl_UntraceVar2 -- 2802 * 2803 * Remove a previously-created trace for a variable. 2804 * 2805 * Results: 2806 * None. 2807 * 2808 * Side effects: 2809 * If there exists a trace for the variable given by part1 and part2 with 2810 * the given flags, proc, and clientData, then that trace is removed. 2811 * 2812 *---------------------------------------------------------------------- 2813 */ 2814 2815void 2816Tcl_UntraceVar2( 2817 Tcl_Interp *interp, /* Interpreter containing variable. */ 2818 const char *part1, /* Name of variable or array. */ 2819 const char *part2, /* Name of element within array; NULL means 2820 * trace applies to scalar variable or array 2821 * as-a-whole. */ 2822 int flags, /* OR-ed collection of bits describing current 2823 * trace, including any of TCL_TRACE_READS, 2824 * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, 2825 * TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */ 2826 Tcl_VarTraceProc *proc, /* Function assocated with trace. */ 2827 ClientData clientData) /* Arbitrary argument to pass to proc. */ 2828{ 2829 register VarTrace *tracePtr; 2830 VarTrace *prevPtr, *nextPtr; 2831 Var *varPtr, *arrayPtr; 2832 Interp *iPtr = (Interp *) interp; 2833 ActiveVarTrace *activePtr; 2834 int flagMask, allFlags = 0; 2835 Tcl_HashEntry *hPtr; 2836 2837 /* 2838 * Set up a mask to mask out the parts of the flags that we are not 2839 * interested in now. 2840 */ 2841 2842 flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; 2843 varPtr = TclLookupVar(interp, part1, part2, flags & flagMask, /*msg*/ NULL, 2844 /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); 2845 if (varPtr == NULL || !(varPtr->flags & VAR_ALL_TRACES & flags)) { 2846 return; 2847 } 2848 2849 /* 2850 * Set up a mask to mask out the parts of the flags that we are not 2851 * interested in now. 2852 */ 2853 2854 flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | 2855 TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; 2856#ifndef TCL_REMOVE_OBSOLETE_TRACES 2857 flagMask |= TCL_TRACE_OLD_STYLE; 2858#endif 2859 flags &= flagMask; 2860 2861 hPtr = Tcl_FindHashEntry(&iPtr->varTraces, 2862 (char *) varPtr); 2863 for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr), prevPtr = NULL; ; 2864 prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { 2865 if (tracePtr == NULL) { 2866 goto updateFlags; 2867 } 2868 if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags) 2869 && (tracePtr->clientData == clientData)) { 2870 break; 2871 } 2872 allFlags |= tracePtr->flags; 2873 } 2874 2875 /* 2876 * The code below makes it possible to delete traces while traces are 2877 * active: it makes sure that the deleted trace won't be processed by 2878 * TclCallVarTraces. 2879 */ 2880 2881 for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; 2882 activePtr = activePtr->nextPtr) { 2883 if (activePtr->nextTracePtr == tracePtr) { 2884 activePtr->nextTracePtr = tracePtr->nextPtr; 2885 } 2886 } 2887 nextPtr = tracePtr->nextPtr; 2888 if (prevPtr == NULL) { 2889 if (nextPtr) { 2890 Tcl_SetHashValue(hPtr, nextPtr); 2891 } else { 2892 Tcl_DeleteHashEntry(hPtr); 2893 } 2894 } else { 2895 prevPtr->nextPtr = nextPtr; 2896 } 2897 tracePtr->nextPtr = NULL; 2898 Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); 2899 2900 for (tracePtr = nextPtr; tracePtr != NULL; 2901 tracePtr = tracePtr->nextPtr) { 2902 allFlags |= tracePtr->flags; 2903 } 2904 2905 updateFlags: 2906 varPtr->flags &= ~VAR_ALL_TRACES; 2907 if (allFlags & VAR_ALL_TRACES) { 2908 varPtr->flags |= (allFlags & VAR_ALL_TRACES); 2909 } else if (TclIsVarUndefined(varPtr)) { 2910 /* 2911 * If this is the last trace on the variable, and the variable is 2912 * unset and unused, then free up the variable. 2913 */ 2914 2915 TclCleanupVar(varPtr, NULL); 2916 } 2917} 2918 2919/* 2920 *---------------------------------------------------------------------- 2921 * 2922 * Tcl_VarTraceInfo -- 2923 * 2924 * Return the clientData value associated with a trace on a variable. 2925 * This function can also be used to step through all of the traces on a 2926 * particular variable that have the same trace function. 2927 * 2928 * Results: 2929 * The return value is the clientData value associated with a trace on 2930 * the given variable. Information will only be returned for a trace with 2931 * proc as trace function. If the clientData argument is NULL then the 2932 * first such trace is returned; otherwise, the next relevant one after 2933 * the one given by clientData will be returned. If the variable doesn't 2934 * exist, or if there are no (more) traces for it, then NULL is returned. 2935 * 2936 * Side effects: 2937 * None. 2938 * 2939 *---------------------------------------------------------------------- 2940 */ 2941 2942ClientData 2943Tcl_VarTraceInfo( 2944 Tcl_Interp *interp, /* Interpreter containing variable. */ 2945 const char *varName, /* Name of variable; may end with "(index)" to 2946 * signify an array reference. */ 2947 int flags, /* OR-ed combo or TCL_GLOBAL_ONLY, 2948 * TCL_NAMESPACE_ONLY (can be 0). */ 2949 Tcl_VarTraceProc *proc, /* Function assocated with trace. */ 2950 ClientData prevClientData) /* If non-NULL, gives last value returned by 2951 * this function, so this call will return the 2952 * next trace after that one. If NULL, this 2953 * call will return the first trace. */ 2954{ 2955 return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, 2956 prevClientData); 2957} 2958 2959/* 2960 *---------------------------------------------------------------------- 2961 * 2962 * Tcl_VarTraceInfo2 -- 2963 * 2964 * Same as Tcl_VarTraceInfo, except takes name in two pieces instead of 2965 * one. 2966 * 2967 * Results: 2968 * Same as Tcl_VarTraceInfo. 2969 * 2970 * Side effects: 2971 * None. 2972 * 2973 *---------------------------------------------------------------------- 2974 */ 2975 2976ClientData 2977Tcl_VarTraceInfo2( 2978 Tcl_Interp *interp, /* Interpreter containing variable. */ 2979 const char *part1, /* Name of variable or array. */ 2980 const char *part2, /* Name of element within array; NULL means 2981 * trace applies to scalar variable or array 2982 * as-a-whole. */ 2983 int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, 2984 * TCL_NAMESPACE_ONLY. */ 2985 Tcl_VarTraceProc *proc, /* Function assocated with trace. */ 2986 ClientData prevClientData) /* If non-NULL, gives last value returned by 2987 * this function, so this call will return the 2988 * next trace after that one. If NULL, this 2989 * call will return the first trace. */ 2990{ 2991 Interp *iPtr = (Interp *) interp; 2992 register VarTrace *tracePtr; 2993 Var *varPtr, *arrayPtr; 2994 Tcl_HashEntry *hPtr; 2995 2996 varPtr = TclLookupVar(interp, part1, part2, 2997 flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), /*msg*/ NULL, 2998 /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); 2999 if (varPtr == NULL) { 3000 return NULL; 3001 } 3002 3003 /* 3004 * Find the relevant trace, if any, and return its clientData. 3005 */ 3006 3007 hPtr = Tcl_FindHashEntry(&iPtr->varTraces, 3008 (char *) varPtr); 3009 3010 if (hPtr) { 3011 tracePtr = Tcl_GetHashValue(hPtr); 3012 3013 if (prevClientData != NULL) { 3014 for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { 3015 if ((tracePtr->clientData == prevClientData) 3016 && (tracePtr->traceProc == proc)) { 3017 tracePtr = tracePtr->nextPtr; 3018 break; 3019 } 3020 } 3021 } 3022 for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) { 3023 if (tracePtr->traceProc == proc) { 3024 return tracePtr->clientData; 3025 } 3026 } 3027 } 3028 return NULL; 3029} 3030 3031/* 3032 *---------------------------------------------------------------------- 3033 * 3034 * Tcl_TraceVar -- 3035 * 3036 * Arrange for reads and/or writes to a variable to cause a function to 3037 * be invoked, which can monitor the operations and/or change their 3038 * actions. 3039 * 3040 * Results: 3041 * A standard Tcl return value. 3042 * 3043 * Side effects: 3044 * A trace is set up on the variable given by varName, such that future 3045 * references to the variable will be intermediated by proc. See the 3046 * manual entry for complete details on the calling sequence for proc. 3047 * The variable's flags are updated. 3048 * 3049 *---------------------------------------------------------------------- 3050 */ 3051 3052int 3053Tcl_TraceVar( 3054 Tcl_Interp *interp, /* Interpreter in which variable is to be 3055 * traced. */ 3056 const char *varName, /* Name of variable; may end with "(index)" to 3057 * signify an array reference. */ 3058 int flags, /* OR-ed collection of bits, including any of 3059 * TCL_TRACE_READS, TCL_TRACE_WRITES, 3060 * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and 3061 * TCL_NAMESPACE_ONLY. */ 3062 Tcl_VarTraceProc *proc, /* Function to call when specified ops are 3063 * invoked upon varName. */ 3064 ClientData clientData) /* Arbitrary argument to pass to proc. */ 3065{ 3066 return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData); 3067} 3068 3069/* 3070 *---------------------------------------------------------------------- 3071 * 3072 * Tcl_TraceVar2 -- 3073 * 3074 * Arrange for reads and/or writes to a variable to cause a function to 3075 * be invoked, which can monitor the operations and/or change their 3076 * actions. 3077 * 3078 * Results: 3079 * A standard Tcl return value. 3080 * 3081 * Side effects: 3082 * A trace is set up on the variable given by part1 and part2, such that 3083 * future references to the variable will be intermediated by proc. See 3084 * the manual entry for complete details on the calling sequence for 3085 * proc. The variable's flags are updated. 3086 * 3087 *---------------------------------------------------------------------- 3088 */ 3089 3090int 3091Tcl_TraceVar2( 3092 Tcl_Interp *interp, /* Interpreter in which variable is to be 3093 * traced. */ 3094 const char *part1, /* Name of scalar variable or array. */ 3095 const char *part2, /* Name of element within array; NULL means 3096 * trace applies to scalar variable or array 3097 * as-a-whole. */ 3098 int flags, /* OR-ed collection of bits, including any of 3099 * TCL_TRACE_READS, TCL_TRACE_WRITES, 3100 * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and 3101 * TCL_NAMESPACE_ONLY. */ 3102 Tcl_VarTraceProc *proc, /* Function to call when specified ops are 3103 * invoked upon varName. */ 3104 ClientData clientData) /* Arbitrary argument to pass to proc. */ 3105{ 3106 register VarTrace *tracePtr; 3107 int result; 3108 3109 tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); 3110 tracePtr->traceProc = proc; 3111 tracePtr->clientData = clientData; 3112 tracePtr->flags = flags; 3113 3114 result = TraceVarEx(interp, part1, part2, tracePtr); 3115 3116 if (result != TCL_OK) { 3117 ckfree((char *) tracePtr); 3118 } 3119 return result; 3120} 3121 3122/* 3123 *---------------------------------------------------------------------- 3124 * 3125 * TraceVarEx -- 3126 * 3127 * Arrange for reads and/or writes to a variable to cause a function to 3128 * be invoked, which can monitor the operations and/or change their 3129 * actions. 3130 * 3131 * Results: 3132 * A standard Tcl return value. 3133 * 3134 * Side effects: 3135 * A trace is set up on the variable given by part1 and part2, such that 3136 * future references to the variable will be intermediated by the 3137 * traceProc listed in tracePtr. See the manual entry for complete 3138 * details on the calling sequence for proc. 3139 * 3140 *---------------------------------------------------------------------- 3141 */ 3142 3143static int 3144TraceVarEx( 3145 Tcl_Interp *interp, /* Interpreter in which variable is to be 3146 * traced. */ 3147 const char *part1, /* Name of scalar variable or array. */ 3148 const char *part2, /* Name of element within array; NULL means 3149 * trace applies to scalar variable or array 3150 * as-a-whole. */ 3151 register VarTrace *tracePtr)/* Structure containing flags, traceProc and 3152 * clientData fields. Others should be left 3153 * blank. Will be ckfree()d (eventually) if 3154 * this function returns TCL_OK, and up to 3155 * caller to free if this function returns 3156 * TCL_ERROR. */ 3157{ 3158 Interp *iPtr = (Interp *) interp; 3159 Var *varPtr, *arrayPtr; 3160 int flagMask, isNew; 3161 Tcl_HashEntry *hPtr; 3162 3163 /* 3164 * We strip 'flags' down to just the parts which are relevant to 3165 * TclLookupVar, to avoid conflicts between trace flags and internal 3166 * namespace flags such as 'TCL_FIND_ONLY_NS'. This can now occur since we 3167 * have trace flags with values 0x1000 and higher. 3168 */ 3169 3170 flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; 3171 varPtr = TclLookupVar(interp, part1, part2, 3172 (tracePtr->flags & flagMask) | TCL_LEAVE_ERR_MSG, 3173 "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); 3174 if (varPtr == NULL) { 3175 return TCL_ERROR; 3176 } 3177 3178 /* 3179 * Check for a nonsense flag combination. Note that this is a Tcl_Panic() 3180 * because there should be no code path that ever sets both flags. 3181 */ 3182 3183 if ((tracePtr->flags&TCL_TRACE_RESULT_DYNAMIC) 3184 && (tracePtr->flags&TCL_TRACE_RESULT_OBJECT)) { 3185 Tcl_Panic("bad result flag combination"); 3186 } 3187 3188 /* 3189 * Set up trace information. 3190 */ 3191 3192 flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | 3193 TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; 3194#ifndef TCL_REMOVE_OBSOLETE_TRACES 3195 flagMask |= TCL_TRACE_OLD_STYLE; 3196#endif 3197 tracePtr->flags = tracePtr->flags & flagMask; 3198 3199 hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, (char *) varPtr, &isNew); 3200 if (isNew) { 3201 tracePtr->nextPtr = NULL; 3202 } else { 3203 tracePtr->nextPtr = (VarTrace *) Tcl_GetHashValue(hPtr); 3204 } 3205 Tcl_SetHashValue(hPtr, (char *) tracePtr); 3206 3207 /* 3208 * Mark the variable as traced so we know to call them. 3209 */ 3210 3211 varPtr->flags |= (tracePtr->flags & VAR_ALL_TRACES); 3212 3213 return TCL_OK; 3214} 3215 3216/* 3217 * Local Variables: 3218 * mode: c 3219 * c-basic-offset: 4 3220 * fill-column: 78 3221 * End: 3222 */ 3223