1/* 2 * tclCmdMZ.c -- 3 * 4 * This file contains the top-level command routines for most of 5 * the Tcl built-in commands whose names begin with the letters 6 * M to Z. It contains only commands in the generic core (i.e. 7 * those that don't depend much upon UNIX facilities). 8 * 9 * Copyright (c) 1987-1993 The Regents of the University of California. 10 * Copyright (c) 1994-1997 Sun Microsystems, Inc. 11 * Copyright (c) 1998-2000 Scriptics Corporation. 12 * Copyright (c) 2002 ActiveState Corporation. 13 * 14 * See the file "license.terms" for information on usage and redistribution 15 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 16 * 17 * RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.29 2007/06/27 17:29:22 dgp Exp $ 18 */ 19 20#include "tclInt.h" 21#include "tclPort.h" 22#include "tclRegexp.h" 23#include "tclCompile.h" 24 25/* 26 * Structures used to hold information about variable traces: 27 */ 28 29typedef struct { 30 int flags; /* Operations for which Tcl command is 31 * to be invoked. */ 32 size_t length; /* Number of non-NULL chars. in command. */ 33 char command[4]; /* Space for Tcl command to invoke. Actual 34 * size will be as large as necessary to 35 * hold command. This field must be the 36 * last in the structure, so that it can 37 * be larger than 4 bytes. */ 38} TraceVarInfo; 39 40typedef struct { 41 VarTrace trace; 42 TraceVarInfo tvar; 43} CompoundVarTrace; 44 45/* 46 * Structure used to hold information about command traces: 47 */ 48 49typedef struct { 50 int flags; /* Operations for which Tcl command is 51 * to be invoked. */ 52 size_t length; /* Number of non-NULL chars. in command. */ 53 Tcl_Trace stepTrace; /* Used for execution traces, when tracing 54 * inside the given command */ 55 int startLevel; /* Used for bookkeeping with step execution 56 * traces, store the level at which the step 57 * trace was invoked */ 58 char *startCmd; /* Used for bookkeeping with step execution 59 * traces, store the command name which invoked 60 * step trace */ 61 int curFlags; /* Trace flags for the current command */ 62 int curCode; /* Return code for the current command */ 63 int refCount; /* Used to ensure this structure is 64 * not deleted too early. Keeps track 65 * of how many pieces of code have 66 * a pointer to this structure. */ 67 char command[4]; /* Space for Tcl command to invoke. Actual 68 * size will be as large as necessary to 69 * hold command. This field must be the 70 * last in the structure, so that it can 71 * be larger than 4 bytes. */ 72} TraceCommandInfo; 73 74/* 75 * Used by command execution traces. Note that we assume in the code 76 * that the first two defines are exactly 4 times the 77 * 'TCL_TRACE_ENTER_EXEC' and 'TCL_TRACE_LEAVE_EXEC' constants. 78 * 79 * TCL_TRACE_ENTER_DURING_EXEC - Trace each command inside the command 80 * currently being traced, before execution. 81 * TCL_TRACE_LEAVE_DURING_EXEC - Trace each command inside the command 82 * currently being traced, after execution. 83 * TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags. 84 * TCL_TRACE_EXEC_IN_PROGRESS - The callback procedure on this trace 85 * is currently executing. Therefore we 86 * don't let further traces execute. 87 * TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly 88 * by the command being traced, not because 89 * of an internal trace. 90 * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also 91 * be used in command execution traces. 92 */ 93#define TCL_TRACE_ENTER_DURING_EXEC 4 94#define TCL_TRACE_LEAVE_DURING_EXEC 8 95#define TCL_TRACE_ANY_EXEC 15 96#define TCL_TRACE_EXEC_IN_PROGRESS 0x10 97#define TCL_TRACE_EXEC_DIRECT 0x20 98 99/* 100 * Forward declarations for procedures defined in this file: 101 */ 102 103typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp, 104 int optionIndex, int objc, Tcl_Obj *CONST objv[])); 105 106Tcl_TraceTypeObjCmd TclTraceVariableObjCmd; 107Tcl_TraceTypeObjCmd TclTraceCommandObjCmd; 108Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd; 109 110/* 111 * Each subcommand has a number of 'types' to which it can apply. 112 * Currently 'execution', 'command' and 'variable' are the only 113 * types supported. These three arrays MUST be kept in sync! 114 * In the future we may provide an API to add to the list of 115 * supported trace types. 116 */ 117static CONST char *traceTypeOptions[] = { 118 "execution", "command", "variable", (char*) NULL 119}; 120static Tcl_TraceTypeObjCmd* traceSubCmds[] = { 121 TclTraceExecutionObjCmd, 122 TclTraceCommandObjCmd, 123 TclTraceVariableObjCmd, 124}; 125 126/* 127 * Declarations for local procedures to this file: 128 */ 129static int CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp, 130 Trace *tracePtr, Command *cmdPtr, 131 CONST char *command, int numChars, 132 int objc, Tcl_Obj *CONST objv[])); 133static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, 134 Tcl_Interp *interp, CONST char *name1, 135 CONST char *name2, int flags)); 136static void TraceCommandProc _ANSI_ARGS_((ClientData clientData, 137 Tcl_Interp *interp, CONST char *oldName, 138 CONST char *newName, int flags)); 139static Tcl_CmdObjTraceProc TraceExecutionProc; 140 141#ifdef TCL_TIP280 142static void ListLines _ANSI_ARGS_((Tcl_Obj* listObj, int line, 143 int n, int* lines, 144 Tcl_Obj* const* elems)); 145#endif 146/* 147 *---------------------------------------------------------------------- 148 * 149 * Tcl_PwdObjCmd -- 150 * 151 * This procedure is invoked to process the "pwd" Tcl command. 152 * See the user documentation for details on what it does. 153 * 154 * Results: 155 * A standard Tcl result. 156 * 157 * Side effects: 158 * See the user documentation. 159 * 160 *---------------------------------------------------------------------- 161 */ 162 163 /* ARGSUSED */ 164int 165Tcl_PwdObjCmd(dummy, interp, objc, objv) 166 ClientData dummy; /* Not used. */ 167 Tcl_Interp *interp; /* Current interpreter. */ 168 int objc; /* Number of arguments. */ 169 Tcl_Obj *CONST objv[]; /* Argument objects. */ 170{ 171 Tcl_Obj *retVal; 172 173 if (objc != 1) { 174 Tcl_WrongNumArgs(interp, 1, objv, NULL); 175 return TCL_ERROR; 176 } 177 178 retVal = Tcl_FSGetCwd(interp); 179 if (retVal == NULL) { 180 return TCL_ERROR; 181 } 182 Tcl_SetObjResult(interp, retVal); 183 Tcl_DecrRefCount(retVal); 184 return TCL_OK; 185} 186 187/* 188 *---------------------------------------------------------------------- 189 * 190 * Tcl_RegexpObjCmd -- 191 * 192 * This procedure is invoked to process the "regexp" Tcl command. 193 * See the user documentation for details on what it does. 194 * 195 * Results: 196 * A standard Tcl result. 197 * 198 * Side effects: 199 * See the user documentation. 200 * 201 *---------------------------------------------------------------------- 202 */ 203 204 /* ARGSUSED */ 205int 206Tcl_RegexpObjCmd(dummy, interp, objc, objv) 207 ClientData dummy; /* Not used. */ 208 Tcl_Interp *interp; /* Current interpreter. */ 209 int objc; /* Number of arguments. */ 210 Tcl_Obj *CONST objv[]; /* Argument objects. */ 211{ 212 int i, indices, match, about, offset, all, doinline, numMatchesSaved; 213 int cflags, eflags, stringLength; 214 Tcl_RegExp regExpr; 215 Tcl_Obj *objPtr, *resultPtr; 216 Tcl_RegExpInfo info; 217 static CONST char *options[] = { 218 "-all", "-about", "-indices", "-inline", 219 "-expanded", "-line", "-linestop", "-lineanchor", 220 "-nocase", "-start", "--", (char *) NULL 221 }; 222 enum options { 223 REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE, 224 REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR, 225 REGEXP_NOCASE, REGEXP_START, REGEXP_LAST 226 }; 227 228 indices = 0; 229 about = 0; 230 cflags = TCL_REG_ADVANCED; 231 eflags = 0; 232 offset = 0; 233 all = 0; 234 doinline = 0; 235 236 for (i = 1; i < objc; i++) { 237 char *name; 238 int index; 239 240 name = Tcl_GetString(objv[i]); 241 if (name[0] != '-') { 242 break; 243 } 244 if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, 245 &index) != TCL_OK) { 246 return TCL_ERROR; 247 } 248 switch ((enum options) index) { 249 case REGEXP_ALL: { 250 all = 1; 251 break; 252 } 253 case REGEXP_INDICES: { 254 indices = 1; 255 break; 256 } 257 case REGEXP_INLINE: { 258 doinline = 1; 259 break; 260 } 261 case REGEXP_NOCASE: { 262 cflags |= TCL_REG_NOCASE; 263 break; 264 } 265 case REGEXP_ABOUT: { 266 about = 1; 267 break; 268 } 269 case REGEXP_EXPANDED: { 270 cflags |= TCL_REG_EXPANDED; 271 break; 272 } 273 case REGEXP_LINE: { 274 cflags |= TCL_REG_NEWLINE; 275 break; 276 } 277 case REGEXP_LINESTOP: { 278 cflags |= TCL_REG_NLSTOP; 279 break; 280 } 281 case REGEXP_LINEANCHOR: { 282 cflags |= TCL_REG_NLANCH; 283 break; 284 } 285 case REGEXP_START: { 286 if (++i >= objc) { 287 goto endOfForLoop; 288 } 289 if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) { 290 return TCL_ERROR; 291 } 292 if (offset < 0) { 293 offset = 0; 294 } 295 break; 296 } 297 case REGEXP_LAST: { 298 i++; 299 goto endOfForLoop; 300 } 301 } 302 } 303 304 endOfForLoop: 305 if ((objc - i) < (2 - about)) { 306 Tcl_WrongNumArgs(interp, 1, objv, 307 "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); 308 return TCL_ERROR; 309 } 310 objc -= i; 311 objv += i; 312 313 if (doinline && ((objc - 2) != 0)) { 314 /* 315 * User requested -inline, but specified match variables - a no-no. 316 */ 317 Tcl_AppendResult(interp, "regexp match variables not allowed", 318 " when using -inline", (char *) NULL); 319 return TCL_ERROR; 320 } 321 322 /* 323 * Handle the odd about case separately. 324 */ 325 if (about) { 326 regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); 327 if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) { 328 return TCL_ERROR; 329 } 330 return TCL_OK; 331 } 332 333 /* 334 * Get the length of the string that we are matching against so 335 * we can do the termination test for -all matches. Do this before 336 * getting the regexp to avoid shimmering problems. 337 */ 338 objPtr = objv[1]; 339 stringLength = Tcl_GetCharLength(objPtr); 340 341 regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); 342 if (regExpr == NULL) { 343 return TCL_ERROR; 344 } 345 346 if (offset > 0) { 347 /* 348 * Add flag if using offset (string is part of a larger string), 349 * so that "^" won't match. 350 */ 351 eflags |= TCL_REG_NOTBOL; 352 } 353 354 objc -= 2; 355 objv += 2; 356 resultPtr = Tcl_GetObjResult(interp); 357 358 if (doinline) { 359 /* 360 * Save all the subexpressions, as we will return them as a list 361 */ 362 numMatchesSaved = -1; 363 } else { 364 /* 365 * Save only enough subexpressions for matches we want to keep, 366 * expect in the case of -all, where we need to keep at least 367 * one to know where to move the offset. 368 */ 369 numMatchesSaved = (objc == 0) ? all : objc; 370 } 371 372 /* 373 * The following loop is to handle multiple matches within the 374 * same source string; each iteration handles one match. If "-all" 375 * hasn't been specified then the loop body only gets executed once. 376 * We terminate the loop when the starting offset is past the end of the 377 * string. 378 */ 379 380 while (1) { 381 match = Tcl_RegExpExecObj(interp, regExpr, objPtr, 382 offset /* offset */, numMatchesSaved, eflags 383 | ((offset > 0 && 384 (Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n')) 385 ? TCL_REG_NOTBOL : 0)); 386 387 if (match < 0) { 388 return TCL_ERROR; 389 } 390 391 if (match == 0) { 392 /* 393 * We want to set the value of the intepreter result only when 394 * this is the first time through the loop. 395 */ 396 if (all <= 1) { 397 /* 398 * If inlining, set the interpreter's object result to an 399 * empty list, otherwise set it to an integer object w/ 400 * value 0. 401 */ 402 if (doinline) { 403 Tcl_SetListObj(resultPtr, 0, NULL); 404 } else { 405 Tcl_SetIntObj(resultPtr, 0); 406 } 407 return TCL_OK; 408 } 409 break; 410 } 411 412 /* 413 * If additional variable names have been specified, return 414 * index information in those variables. 415 */ 416 417 Tcl_RegExpGetInfo(regExpr, &info); 418 if (doinline) { 419 /* 420 * It's the number of substitutions, plus one for the matchVar 421 * at index 0 422 */ 423 objc = info.nsubs + 1; 424 } 425 for (i = 0; i < objc; i++) { 426 Tcl_Obj *newPtr; 427 428 if (indices) { 429 int start, end; 430 Tcl_Obj *objs[2]; 431 432 /* 433 * Only adjust the match area if there was a match for 434 * that area. (Scriptics Bug 4391/SF Bug #219232) 435 */ 436 if (i <= info.nsubs && info.matches[i].start >= 0) { 437 start = offset + info.matches[i].start; 438 end = offset + info.matches[i].end; 439 440 /* 441 * Adjust index so it refers to the last character in the 442 * match instead of the first character after the match. 443 */ 444 445 if (end >= offset) { 446 end--; 447 } 448 } else { 449 start = -1; 450 end = -1; 451 } 452 453 objs[0] = Tcl_NewLongObj(start); 454 objs[1] = Tcl_NewLongObj(end); 455 456 newPtr = Tcl_NewListObj(2, objs); 457 } else { 458 if (i <= info.nsubs) { 459 newPtr = Tcl_GetRange(objPtr, 460 offset + info.matches[i].start, 461 offset + info.matches[i].end - 1); 462 } else { 463 newPtr = Tcl_NewObj(); 464 } 465 } 466 if (doinline) { 467 if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr) 468 != TCL_OK) { 469 Tcl_DecrRefCount(newPtr); 470 return TCL_ERROR; 471 } 472 } else { 473 Tcl_Obj *valuePtr; 474 valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); 475 if (valuePtr == NULL) { 476 Tcl_AppendResult(interp, "couldn't set variable \"", 477 Tcl_GetString(objv[i]), "\"", (char *) NULL); 478 Tcl_DecrRefCount(newPtr); 479 return TCL_ERROR; 480 } 481 } 482 } 483 484 if (all == 0) { 485 break; 486 } 487 /* 488 * Adjust the offset to the character just after the last one 489 * in the matchVar and increment all to count how many times 490 * we are making a match. We always increment the offset by at least 491 * one to prevent endless looping (as in the case: 492 * regexp -all {a*} a). Otherwise, when we match the NULL string at 493 * the end of the input string, we will loop indefinately (because the 494 * length of the match is 0, so offset never changes). 495 */ 496 if (info.matches[0].end == 0) { 497 offset++; 498 } 499 offset += info.matches[0].end; 500 all++; 501 eflags |= TCL_REG_NOTBOL; 502 if (offset >= stringLength) { 503 break; 504 } 505 } 506 507 /* 508 * Set the interpreter's object result to an integer object 509 * with value 1 if -all wasn't specified, otherwise it's all-1 510 * (the number of times through the while - 1). 511 * Get the resultPtr again as the Tcl_ObjSetVar2 above may have 512 * cause the result to change. [Patch #558324] (watson). 513 */ 514 515 if (!doinline) { 516 resultPtr = Tcl_GetObjResult(interp); 517 Tcl_SetIntObj(resultPtr, (all ? all-1 : 1)); 518 } 519 return TCL_OK; 520} 521 522/* 523 *---------------------------------------------------------------------- 524 * 525 * Tcl_RegsubObjCmd -- 526 * 527 * This procedure is invoked to process the "regsub" Tcl command. 528 * See the user documentation for details on what it does. 529 * 530 * Results: 531 * A standard Tcl result. 532 * 533 * Side effects: 534 * See the user documentation. 535 * 536 *---------------------------------------------------------------------- 537 */ 538 539 /* ARGSUSED */ 540int 541Tcl_RegsubObjCmd(dummy, interp, objc, objv) 542 ClientData dummy; /* Not used. */ 543 Tcl_Interp *interp; /* Current interpreter. */ 544 int objc; /* Number of arguments. */ 545 Tcl_Obj *CONST objv[]; /* Argument objects. */ 546{ 547 int idx, result, cflags, all, wlen, wsublen, numMatches, offset; 548 int start, end, subStart, subEnd, match; 549 Tcl_RegExp regExpr; 550 Tcl_RegExpInfo info; 551 Tcl_Obj *resultPtr, *subPtr, *objPtr; 552 Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; 553 554 static CONST char *options[] = { 555 "-all", "-nocase", "-expanded", 556 "-line", "-linestop", "-lineanchor", "-start", 557 "--", NULL 558 }; 559 enum options { 560 REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED, 561 REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START, 562 REGSUB_LAST 563 }; 564 565 cflags = TCL_REG_ADVANCED; 566 all = 0; 567 offset = 0; 568 resultPtr = NULL; 569 570 for (idx = 1; idx < objc; idx++) { 571 char *name; 572 int index; 573 574 name = Tcl_GetString(objv[idx]); 575 if (name[0] != '-') { 576 break; 577 } 578 if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", 579 TCL_EXACT, &index) != TCL_OK) { 580 return TCL_ERROR; 581 } 582 switch ((enum options) index) { 583 case REGSUB_ALL: { 584 all = 1; 585 break; 586 } 587 case REGSUB_NOCASE: { 588 cflags |= TCL_REG_NOCASE; 589 break; 590 } 591 case REGSUB_EXPANDED: { 592 cflags |= TCL_REG_EXPANDED; 593 break; 594 } 595 case REGSUB_LINE: { 596 cflags |= TCL_REG_NEWLINE; 597 break; 598 } 599 case REGSUB_LINESTOP: { 600 cflags |= TCL_REG_NLSTOP; 601 break; 602 } 603 case REGSUB_LINEANCHOR: { 604 cflags |= TCL_REG_NLANCH; 605 break; 606 } 607 case REGSUB_START: { 608 if (++idx >= objc) { 609 goto endOfForLoop; 610 } 611 if (Tcl_GetIntFromObj(interp, objv[idx], &offset) != TCL_OK) { 612 return TCL_ERROR; 613 } 614 if (offset < 0) { 615 offset = 0; 616 } 617 break; 618 } 619 case REGSUB_LAST: { 620 idx++; 621 goto endOfForLoop; 622 } 623 } 624 } 625 endOfForLoop: 626 if (objc-idx < 3 || objc-idx > 4) { 627 Tcl_WrongNumArgs(interp, 1, objv, 628 "?switches? exp string subSpec ?varName?"); 629 return TCL_ERROR; 630 } 631 632 objc -= idx; 633 objv += idx; 634 635 if (all && (offset == 0) 636 && (strpbrk(Tcl_GetString(objv[2]), "&\\") == NULL) 637 && (strpbrk(Tcl_GetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { 638 /* 639 * This is a simple one pair string map situation. We make use of 640 * a slightly modified version of the one pair STR_MAP code. 641 */ 642 int slen, nocase; 643 int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar *, CONST Tcl_UniChar *, 644 unsigned long)); 645 Tcl_UniChar *p, wsrclc; 646 647 numMatches = 0; 648 nocase = (cflags & TCL_REG_NOCASE); 649 strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; 650 651 wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); 652 wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); 653 wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen); 654 wend = wstring + wlen - (slen ? slen - 1 : 0); 655 result = TCL_OK; 656 657 if (slen == 0) { 658 /* 659 * regsub behavior for "" matches between each character. 660 * 'string map' skips the "" case. 661 */ 662 if (wstring < wend) { 663 resultPtr = Tcl_NewUnicodeObj(wstring, 0); 664 Tcl_IncrRefCount(resultPtr); 665 for (; wstring < wend; wstring++) { 666 Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); 667 Tcl_AppendUnicodeToObj(resultPtr, wstring, 1); 668 numMatches++; 669 } 670 wlen = 0; 671 } 672 } else { 673 wsrclc = Tcl_UniCharToLower(*wsrc); 674 for (p = wfirstChar = wstring; wstring < wend; wstring++) { 675 if (((*wstring == *wsrc) || 676 (nocase && (Tcl_UniCharToLower(*wstring) == 677 wsrclc))) && 678 ((slen == 1) || (strCmpFn(wstring, wsrc, 679 (unsigned long) slen) == 0))) { 680 if (numMatches == 0) { 681 resultPtr = Tcl_NewUnicodeObj(wstring, 0); 682 Tcl_IncrRefCount(resultPtr); 683 } 684 if (p != wstring) { 685 Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p); 686 p = wstring + slen; 687 } else { 688 p += slen; 689 } 690 wstring = p - 1; 691 692 Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); 693 numMatches++; 694 } 695 } 696 if (numMatches) { 697 wlen = wfirstChar + wlen - p; 698 wstring = p; 699 } 700 } 701 objPtr = NULL; 702 subPtr = NULL; 703 goto regsubDone; 704 } 705 706 regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); 707 if (regExpr == NULL) { 708 return TCL_ERROR; 709 } 710 711 /* 712 * Make sure to avoid problems where the objects are shared. This 713 * can cause RegExpObj <> UnicodeObj shimmering that causes data 714 * corruption. [Bug #461322] 715 */ 716 717 if (objv[1] == objv[0]) { 718 objPtr = Tcl_DuplicateObj(objv[1]); 719 } else { 720 objPtr = objv[1]; 721 } 722 wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); 723 if (objv[2] == objv[0]) { 724 subPtr = Tcl_DuplicateObj(objv[2]); 725 } else { 726 subPtr = objv[2]; 727 } 728 wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); 729 730 result = TCL_OK; 731 732 /* 733 * The following loop is to handle multiple matches within the 734 * same source string; each iteration handles one match and its 735 * corresponding substitution. If "-all" hasn't been specified 736 * then the loop body only gets executed once. We must use 737 * 'offset <= wlen' in particular for the case where the regexp 738 * pattern can match the empty string - this is useful when 739 * doing, say, 'regsub -- ^ $str ...' when $str might be empty. 740 */ 741 742 numMatches = 0; 743 for ( ; offset <= wlen; ) { 744 745 /* 746 * The flags argument is set if string is part of a larger string, 747 * so that "^" won't match. 748 */ 749 750 match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset, 751 10 /* matches */, ((offset > 0 && 752 (wstring[offset-1] != (Tcl_UniChar)'\n')) 753 ? TCL_REG_NOTBOL : 0)); 754 755 if (match < 0) { 756 result = TCL_ERROR; 757 goto done; 758 } 759 if (match == 0) { 760 break; 761 } 762 if (numMatches == 0) { 763 resultPtr = Tcl_NewUnicodeObj(wstring, 0); 764 Tcl_IncrRefCount(resultPtr); 765 if (offset > 0) { 766 /* 767 * Copy the initial portion of the string in if an offset 768 * was specified. 769 */ 770 Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); 771 } 772 } 773 numMatches++; 774 775 /* 776 * Copy the portion of the source string before the match to the 777 * result variable. 778 */ 779 780 Tcl_RegExpGetInfo(regExpr, &info); 781 start = info.matches[0].start; 782 end = info.matches[0].end; 783 Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); 784 785 /* 786 * Append the subSpec argument to the variable, making appropriate 787 * substitutions. This code is a bit hairy because of the backslash 788 * conventions and because the code saves up ranges of characters in 789 * subSpec to reduce the number of calls to Tcl_SetVar. 790 */ 791 792 wsrc = wfirstChar = wsubspec; 793 wend = wsubspec + wsublen; 794 for (ch = *wsrc; wsrc != wend; wsrc++, ch = *wsrc) { 795 if (ch == '&') { 796 idx = 0; 797 } else if (ch == '\\') { 798 ch = wsrc[1]; 799 if ((ch >= '0') && (ch <= '9')) { 800 idx = ch - '0'; 801 } else if ((ch == '\\') || (ch == '&')) { 802 *wsrc = ch; 803 Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, 804 wsrc - wfirstChar + 1); 805 *wsrc = '\\'; 806 wfirstChar = wsrc + 2; 807 wsrc++; 808 continue; 809 } else { 810 continue; 811 } 812 } else { 813 continue; 814 } 815 if (wfirstChar != wsrc) { 816 Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, 817 wsrc - wfirstChar); 818 } 819 if (idx <= info.nsubs) { 820 subStart = info.matches[idx].start; 821 subEnd = info.matches[idx].end; 822 if ((subStart >= 0) && (subEnd >= 0)) { 823 Tcl_AppendUnicodeToObj(resultPtr, 824 wstring + offset + subStart, subEnd - subStart); 825 } 826 } 827 if (*wsrc == '\\') { 828 wsrc++; 829 } 830 wfirstChar = wsrc + 1; 831 } 832 if (wfirstChar != wsrc) { 833 Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); 834 } 835 if (end == 0) { 836 /* 837 * Always consume at least one character of the input string 838 * in order to prevent infinite loops. 839 */ 840 841 if (offset < wlen) { 842 Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); 843 } 844 offset++; 845 } else { 846 offset += end; 847 if (start == end) { 848 /* 849 * We matched an empty string, which means we must go 850 * forward one more step so we don't match again at the 851 * same spot. 852 */ 853 if (offset < wlen) { 854 Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); 855 } 856 offset++; 857 } 858 } 859 if (!all) { 860 break; 861 } 862 } 863 864 /* 865 * Copy the portion of the source string after the last match to the 866 * result variable. 867 */ 868 regsubDone: 869 if (numMatches == 0) { 870 /* 871 * On zero matches, just ignore the offset, since it shouldn't 872 * matter to us in this case, and the user may have skewed it. 873 */ 874 resultPtr = objv[1]; 875 Tcl_IncrRefCount(resultPtr); 876 } else if (offset < wlen) { 877 Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); 878 } 879 if (objc == 4) { 880 if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) { 881 Tcl_AppendResult(interp, "couldn't set variable \"", 882 Tcl_GetString(objv[3]), "\"", (char *) NULL); 883 result = TCL_ERROR; 884 } else { 885 /* 886 * Set the interpreter's object result to an integer object 887 * holding the number of matches. 888 */ 889 890 Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches); 891 } 892 } else { 893 /* 894 * No varname supplied, so just return the modified string. 895 */ 896 Tcl_SetObjResult(interp, resultPtr); 897 } 898 899 done: 900 if (objPtr && (objv[1] == objv[0])) { Tcl_DecrRefCount(objPtr); } 901 if (subPtr && (objv[2] == objv[0])) { Tcl_DecrRefCount(subPtr); } 902 if (resultPtr) { Tcl_DecrRefCount(resultPtr); } 903 return result; 904} 905 906/* 907 *---------------------------------------------------------------------- 908 * 909 * Tcl_RenameObjCmd -- 910 * 911 * This procedure is invoked to process the "rename" Tcl command. 912 * See the user documentation for details on what it does. 913 * 914 * Results: 915 * A standard Tcl object result. 916 * 917 * Side effects: 918 * See the user documentation. 919 * 920 *---------------------------------------------------------------------- 921 */ 922 923 /* ARGSUSED */ 924int 925Tcl_RenameObjCmd(dummy, interp, objc, objv) 926 ClientData dummy; /* Arbitrary value passed to the command. */ 927 Tcl_Interp *interp; /* Current interpreter. */ 928 int objc; /* Number of arguments. */ 929 Tcl_Obj *CONST objv[]; /* Argument objects. */ 930{ 931 char *oldName, *newName; 932 933 if (objc != 3) { 934 Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); 935 return TCL_ERROR; 936 } 937 938 oldName = Tcl_GetString(objv[1]); 939 newName = Tcl_GetString(objv[2]); 940 return TclRenameCommand(interp, oldName, newName); 941} 942 943/* 944 *---------------------------------------------------------------------- 945 * 946 * Tcl_ReturnObjCmd -- 947 * 948 * This object-based procedure is invoked to process the "return" Tcl 949 * command. See the user documentation for details on what it does. 950 * 951 * Results: 952 * A standard Tcl object result. 953 * 954 * Side effects: 955 * See the user documentation. 956 * 957 *---------------------------------------------------------------------- 958 */ 959 960 /* ARGSUSED */ 961int 962Tcl_ReturnObjCmd(dummy, interp, objc, objv) 963 ClientData dummy; /* Not used. */ 964 Tcl_Interp *interp; /* Current interpreter. */ 965 int objc; /* Number of arguments. */ 966 Tcl_Obj *CONST objv[]; /* Argument objects. */ 967{ 968 Interp *iPtr = (Interp *) interp; 969 int optionLen, argLen, code, result; 970 971 if (iPtr->errorInfo != NULL) { 972 ckfree(iPtr->errorInfo); 973 iPtr->errorInfo = NULL; 974 } 975 if (iPtr->errorCode != NULL) { 976 ckfree(iPtr->errorCode); 977 iPtr->errorCode = NULL; 978 } 979 code = TCL_OK; 980 981 for (objv++, objc--; objc > 1; objv += 2, objc -= 2) { 982 char *option = Tcl_GetStringFromObj(objv[0], &optionLen); 983 char *arg = Tcl_GetStringFromObj(objv[1], &argLen); 984 985 if (strcmp(option, "-code") == 0) { 986 register int c = arg[0]; 987 if ((c == 'o') && (strcmp(arg, "ok") == 0)) { 988 code = TCL_OK; 989 } else if ((c == 'e') && (strcmp(arg, "error") == 0)) { 990 code = TCL_ERROR; 991 } else if ((c == 'r') && (strcmp(arg, "return") == 0)) { 992 code = TCL_RETURN; 993 } else if ((c == 'b') && (strcmp(arg, "break") == 0)) { 994 code = TCL_BREAK; 995 } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) { 996 code = TCL_CONTINUE; 997 } else { 998 result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1], 999 &code); 1000 if (result != TCL_OK) { 1001 Tcl_ResetResult(interp); 1002 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1003 "bad completion code \"", 1004 Tcl_GetString(objv[1]), 1005 "\": must be ok, error, return, break, ", 1006 "continue, or an integer", (char *) NULL); 1007 return result; 1008 } 1009 } 1010 } else if (strcmp(option, "-errorinfo") == 0) { 1011 iPtr->errorInfo = 1012 (char *) ckalloc((unsigned) (strlen(arg) + 1)); 1013 strcpy(iPtr->errorInfo, arg); 1014 } else if (strcmp(option, "-errorcode") == 0) { 1015 iPtr->errorCode = 1016 (char *) ckalloc((unsigned) (strlen(arg) + 1)); 1017 strcpy(iPtr->errorCode, arg); 1018 } else { 1019 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1020 "bad option \"", option, 1021 "\": must be -code, -errorcode, or -errorinfo", 1022 (char *) NULL); 1023 return TCL_ERROR; 1024 } 1025 } 1026 1027 if (objc == 1) { 1028 /* 1029 * Set the interpreter's object result. An inline version of 1030 * Tcl_SetObjResult. 1031 */ 1032 1033 Tcl_SetObjResult(interp, objv[0]); 1034 } 1035 iPtr->returnCode = code; 1036 return TCL_RETURN; 1037} 1038 1039/* 1040 *---------------------------------------------------------------------- 1041 * 1042 * Tcl_SourceObjCmd -- 1043 * 1044 * This procedure is invoked to process the "source" Tcl command. 1045 * See the user documentation for details on what it does. 1046 * 1047 * Results: 1048 * A standard Tcl object result. 1049 * 1050 * Side effects: 1051 * See the user documentation. 1052 * 1053 *---------------------------------------------------------------------- 1054 */ 1055 1056 /* ARGSUSED */ 1057int 1058Tcl_SourceObjCmd(dummy, interp, objc, objv) 1059 ClientData dummy; /* Not used. */ 1060 Tcl_Interp *interp; /* Current interpreter. */ 1061 int objc; /* Number of arguments. */ 1062 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1063{ 1064 if (objc != 2) { 1065 Tcl_WrongNumArgs(interp, 1, objv, "fileName"); 1066 return TCL_ERROR; 1067 } 1068 1069 return Tcl_FSEvalFile(interp, objv[1]); 1070} 1071 1072/* 1073 *---------------------------------------------------------------------- 1074 * 1075 * Tcl_SplitObjCmd -- 1076 * 1077 * This procedure is invoked to process the "split" Tcl command. 1078 * See the user documentation for details on what it does. 1079 * 1080 * Results: 1081 * A standard Tcl result. 1082 * 1083 * Side effects: 1084 * See the user documentation. 1085 * 1086 *---------------------------------------------------------------------- 1087 */ 1088 1089 /* ARGSUSED */ 1090int 1091Tcl_SplitObjCmd(dummy, interp, objc, objv) 1092 ClientData dummy; /* Not used. */ 1093 Tcl_Interp *interp; /* Current interpreter. */ 1094 int objc; /* Number of arguments. */ 1095 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1096{ 1097 Tcl_UniChar ch; 1098 int len; 1099 char *splitChars, *string, *end; 1100 int splitCharLen, stringLen; 1101 Tcl_Obj *listPtr, *objPtr; 1102 1103 if (objc == 2) { 1104 splitChars = " \n\t\r"; 1105 splitCharLen = 4; 1106 } else if (objc == 3) { 1107 splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen); 1108 } else { 1109 Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?"); 1110 return TCL_ERROR; 1111 } 1112 1113 string = Tcl_GetStringFromObj(objv[1], &stringLen); 1114 end = string + stringLen; 1115 listPtr = Tcl_GetObjResult(interp); 1116 1117 if (stringLen == 0) { 1118 /* 1119 * Do nothing. 1120 */ 1121 } else if (splitCharLen == 0) { 1122 Tcl_HashTable charReuseTable; 1123 Tcl_HashEntry *hPtr; 1124 int isNew; 1125 1126 /* 1127 * Handle the special case of splitting on every character. 1128 * 1129 * Uses a hash table to ensure that each kind of character has 1130 * only one Tcl_Obj instance (multiply-referenced) in the 1131 * final list. This is a *major* win when splitting on a long 1132 * string (especially in the megabyte range!) - DKF 1133 */ 1134 1135 Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); 1136 for ( ; string < end; string += len) { 1137 len = TclUtfToUniChar(string, &ch); 1138 /* Assume Tcl_UniChar is an integral type... */ 1139 hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew); 1140 if (isNew) { 1141 objPtr = Tcl_NewStringObj(string, len); 1142 /* Don't need to fiddle with refcount... */ 1143 Tcl_SetHashValue(hPtr, (ClientData) objPtr); 1144 } else { 1145 objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr); 1146 } 1147 Tcl_ListObjAppendElement(NULL, listPtr, objPtr); 1148 } 1149 Tcl_DeleteHashTable(&charReuseTable); 1150 } else if (splitCharLen == 1) { 1151 char *p; 1152 1153 /* 1154 * Handle the special case of splitting on a single character. 1155 * This is only true for the one-char ASCII case, as one unicode 1156 * char is > 1 byte in length. 1157 */ 1158 1159 while (*string && (p = strchr(string, (int) *splitChars)) != NULL) { 1160 objPtr = Tcl_NewStringObj(string, p - string); 1161 Tcl_ListObjAppendElement(NULL, listPtr, objPtr); 1162 string = p + 1; 1163 } 1164 objPtr = Tcl_NewStringObj(string, end - string); 1165 Tcl_ListObjAppendElement(NULL, listPtr, objPtr); 1166 } else { 1167 char *element, *p, *splitEnd; 1168 int splitLen; 1169 Tcl_UniChar splitChar; 1170 1171 /* 1172 * Normal case: split on any of a given set of characters. 1173 * Discard instances of the split characters. 1174 */ 1175 1176 splitEnd = splitChars + splitCharLen; 1177 1178 for (element = string; string < end; string += len) { 1179 len = TclUtfToUniChar(string, &ch); 1180 for (p = splitChars; p < splitEnd; p += splitLen) { 1181 splitLen = TclUtfToUniChar(p, &splitChar); 1182 if (ch == splitChar) { 1183 objPtr = Tcl_NewStringObj(element, string - element); 1184 Tcl_ListObjAppendElement(NULL, listPtr, objPtr); 1185 element = string + len; 1186 break; 1187 } 1188 } 1189 } 1190 objPtr = Tcl_NewStringObj(element, string - element); 1191 Tcl_ListObjAppendElement(NULL, listPtr, objPtr); 1192 } 1193 return TCL_OK; 1194} 1195 1196/* 1197 *---------------------------------------------------------------------- 1198 * 1199 * Tcl_StringObjCmd -- 1200 * 1201 * This procedure is invoked to process the "string" Tcl command. 1202 * See the user documentation for details on what it does. Note 1203 * that this command only functions correctly on properly formed 1204 * Tcl UTF strings. 1205 * 1206 * Note that the primary methods here (equal, compare, match, ...) 1207 * have bytecode equivalents. You will find the code for those in 1208 * tclExecute.c. The code here will only be used in the non-bc 1209 * case (like in an 'eval'). 1210 * 1211 * Results: 1212 * A standard Tcl result. 1213 * 1214 * Side effects: 1215 * See the user documentation. 1216 * 1217 *---------------------------------------------------------------------- 1218 */ 1219 1220 /* ARGSUSED */ 1221int 1222Tcl_StringObjCmd(dummy, interp, objc, objv) 1223 ClientData dummy; /* Not used. */ 1224 Tcl_Interp *interp; /* Current interpreter. */ 1225 int objc; /* Number of arguments. */ 1226 Tcl_Obj *CONST objv[]; /* Argument objects. */ 1227{ 1228 int index, left, right; 1229 Tcl_Obj *resultPtr; 1230 char *string1, *string2; 1231 int length1, length2; 1232 static CONST char *options[] = { 1233 "bytelength", "compare", "equal", "first", 1234 "index", "is", "last", "length", 1235 "map", "match", "range", "repeat", 1236 "replace", "tolower", "toupper", "totitle", 1237 "trim", "trimleft", "trimright", 1238 "wordend", "wordstart", (char *) NULL 1239 }; 1240 enum options { 1241 STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST, 1242 STR_INDEX, STR_IS, STR_LAST, STR_LENGTH, 1243 STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT, 1244 STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE, 1245 STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, 1246 STR_WORDEND, STR_WORDSTART 1247 }; 1248 1249 if (objc < 2) { 1250 Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); 1251 return TCL_ERROR; 1252 } 1253 1254 if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, 1255 &index) != TCL_OK) { 1256 return TCL_ERROR; 1257 } 1258 1259 resultPtr = Tcl_GetObjResult(interp); 1260 switch ((enum options) index) { 1261 case STR_EQUAL: 1262 case STR_COMPARE: { 1263 /* 1264 * Remember to keep code here in some sync with the 1265 * byte-compiled versions in tclExecute.c (INST_STR_EQ, 1266 * INST_STR_NEQ and INST_STR_CMP as well as the expr string 1267 * comparison in INST_EQ/INST_NEQ/INST_LT/...). 1268 */ 1269 int i, match, length, nocase = 0, reqlength = -1; 1270 int (*strCmpFn)(); 1271 1272 if (objc < 4 || objc > 7) { 1273 str_cmp_args: 1274 Tcl_WrongNumArgs(interp, 2, objv, 1275 "?-nocase? ?-length int? string1 string2"); 1276 return TCL_ERROR; 1277 } 1278 1279 for (i = 2; i < objc-2; i++) { 1280 string2 = Tcl_GetStringFromObj(objv[i], &length2); 1281 if ((length2 > 1) 1282 && strncmp(string2, "-nocase", (size_t)length2) == 0) { 1283 nocase = 1; 1284 } else if ((length2 > 1) 1285 && strncmp(string2, "-length", (size_t)length2) == 0) { 1286 if (i+1 >= objc-2) { 1287 goto str_cmp_args; 1288 } 1289 if (Tcl_GetIntFromObj(interp, objv[++i], 1290 &reqlength) != TCL_OK) { 1291 return TCL_ERROR; 1292 } 1293 } else { 1294 Tcl_AppendStringsToObj(resultPtr, "bad option \"", 1295 string2, "\": must be -nocase or -length", 1296 (char *) NULL); 1297 return TCL_ERROR; 1298 } 1299 } 1300 1301 /* 1302 * From now on, we only access the two objects at the end 1303 * of the argument array. 1304 */ 1305 objv += objc-2; 1306 1307 if ((reqlength == 0) || (objv[0] == objv[1])) { 1308 /* 1309 * Alway match at 0 chars of if it is the same obj. 1310 */ 1311 1312 Tcl_SetBooleanObj(resultPtr, 1313 ((enum options) index == STR_EQUAL)); 1314 break; 1315 } else if (!nocase && objv[0]->typePtr == &tclByteArrayType && 1316 objv[1]->typePtr == &tclByteArrayType) { 1317 /* 1318 * Use binary versions of comparisons since that won't 1319 * cause undue type conversions and it is much faster. 1320 * Only do this if we're case-sensitive (which is all 1321 * that really makes sense with byte arrays anyway, and 1322 * we have no memcasecmp() for some reason... :^) 1323 */ 1324 string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1); 1325 string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2); 1326 strCmpFn = memcmp; 1327 } else if ((objv[0]->typePtr == &tclStringType) 1328 && (objv[1]->typePtr == &tclStringType)) { 1329 /* 1330 * Do a unicode-specific comparison if both of the args 1331 * are of String type. In benchmark testing this proved 1332 * the most efficient check between the unicode and 1333 * string comparison operations. 1334 */ 1335 string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1); 1336 string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2); 1337 strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; 1338 } else { 1339 /* 1340 * As a catch-all we will work with UTF-8. We cannot use 1341 * memcmp() as that is unsafe with any string containing 1342 * NULL (\xC0\x80 in Tcl's utf rep). We can use the more 1343 * efficient TclpUtfNcmp2 if we are case-sensitive and no 1344 * specific length was requested. 1345 */ 1346 string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1); 1347 string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2); 1348 if ((reqlength < 0) && !nocase) { 1349 strCmpFn = TclpUtfNcmp2; 1350 } else { 1351 length1 = Tcl_NumUtfChars(string1, length1); 1352 length2 = Tcl_NumUtfChars(string2, length2); 1353 strCmpFn = nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp; 1354 } 1355 } 1356 1357 if (((enum options) index == STR_EQUAL) 1358 && (reqlength < 0) && (length1 != length2)) { 1359 match = 1; /* this will be reversed below */ 1360 } else { 1361 length = (length1 < length2) ? length1 : length2; 1362 if (reqlength > 0 && reqlength < length) { 1363 length = reqlength; 1364 } else if (reqlength < 0) { 1365 /* 1366 * The requested length is negative, so we ignore it by 1367 * setting it to length + 1 so we correct the match var. 1368 */ 1369 reqlength = length + 1; 1370 } 1371 match = strCmpFn(string1, string2, (unsigned) length); 1372 if ((match == 0) && (reqlength > length)) { 1373 match = length1 - length2; 1374 } 1375 } 1376 1377 if ((enum options) index == STR_EQUAL) { 1378 Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1); 1379 } else { 1380 Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 : 1381 (match < 0) ? -1 : 0)); 1382 } 1383 break; 1384 } 1385 case STR_FIRST: { 1386 Tcl_UniChar *ustring1, *ustring2; 1387 int match, start; 1388 1389 if (objc < 4 || objc > 5) { 1390 Tcl_WrongNumArgs(interp, 2, objv, 1391 "subString string ?startIndex?"); 1392 return TCL_ERROR; 1393 } 1394 1395 /* 1396 * We are searching string2 for the sequence string1. 1397 */ 1398 1399 match = -1; 1400 start = 0; 1401 length2 = -1; 1402 1403 ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); 1404 ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); 1405 1406 if (objc == 5) { 1407 /* 1408 * If a startIndex is specified, we will need to fast 1409 * forward to that point in the string before we think 1410 * about a match 1411 */ 1412 if (TclGetIntForIndex(interp, objv[4], length2 - 1, 1413 &start) != TCL_OK) { 1414 return TCL_ERROR; 1415 } 1416 if (start >= length2) { 1417 goto str_first_done; 1418 } else if (start > 0) { 1419 ustring2 += start; 1420 length2 -= start; 1421 } else if (start < 0) { 1422 /* 1423 * Invalid start index mapped to string start; 1424 * Bug #423581 1425 */ 1426 start = 0; 1427 } 1428 } 1429 1430 if (length1 > 0) { 1431 register Tcl_UniChar *p, *end; 1432 1433 end = ustring2 + length2 - length1 + 1; 1434 for (p = ustring2; p < end; p++) { 1435 /* 1436 * Scan forward to find the first character. 1437 */ 1438 if ((*p == *ustring1) && 1439 (TclUniCharNcmp(ustring1, p, 1440 (unsigned long) length1) == 0)) { 1441 match = p - ustring2; 1442 break; 1443 } 1444 } 1445 } 1446 /* 1447 * Compute the character index of the matching string by 1448 * counting the number of characters before the match. 1449 */ 1450 if ((match != -1) && (objc == 5)) { 1451 match += start; 1452 } 1453 1454 str_first_done: 1455 Tcl_SetIntObj(resultPtr, match); 1456 break; 1457 } 1458 case STR_INDEX: { 1459 if (objc != 4) { 1460 Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); 1461 return TCL_ERROR; 1462 } 1463 1464 /* 1465 * If we have a ByteArray object, avoid indexing in the 1466 * Utf string since the byte array contains one byte per 1467 * character. Otherwise, use the Unicode string rep to 1468 * get the index'th char. 1469 */ 1470 1471 if (objv[2]->typePtr == &tclByteArrayType) { 1472 string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1); 1473 1474 if (TclGetIntForIndex(interp, objv[3], length1 - 1, 1475 &index) != TCL_OK) { 1476 return TCL_ERROR; 1477 } 1478 if ((index >= 0) && (index < length1)) { 1479 Tcl_SetByteArrayObj(resultPtr, 1480 (unsigned char *)(&string1[index]), 1); 1481 } 1482 } else { 1483 /* 1484 * Get Unicode char length to calulate what 'end' means. 1485 */ 1486 length1 = Tcl_GetCharLength(objv[2]); 1487 1488 if (TclGetIntForIndex(interp, objv[3], length1 - 1, 1489 &index) != TCL_OK) { 1490 return TCL_ERROR; 1491 } 1492 if ((index >= 0) && (index < length1)) { 1493 char buf[TCL_UTF_MAX]; 1494 Tcl_UniChar ch; 1495 1496 ch = Tcl_GetUniChar(objv[2], index); 1497 length1 = Tcl_UniCharToUtf(ch, buf); 1498 Tcl_SetStringObj(resultPtr, buf, length1); 1499 } 1500 } 1501 break; 1502 } 1503 case STR_IS: { 1504 char *end; 1505 Tcl_UniChar ch; 1506 1507 /* 1508 * The UniChar comparison function 1509 */ 1510 1511 int (*chcomp)_ANSI_ARGS_((int)) = NULL; 1512 int i, failat = 0, result = 1, strict = 0; 1513 Tcl_Obj *objPtr, *failVarObj = NULL; 1514 1515 static CONST char *isOptions[] = { 1516 "alnum", "alpha", "ascii", "control", 1517 "boolean", "digit", "double", "false", 1518 "graph", "integer", "lower", "print", 1519 "punct", "space", "true", "upper", 1520 "wordchar", "xdigit", (char *) NULL 1521 }; 1522 enum isOptions { 1523 STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, 1524 STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE, 1525 STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT, 1526 STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, 1527 STR_IS_WORD, STR_IS_XDIGIT 1528 }; 1529 1530 if (objc < 4 || objc > 7) { 1531 Tcl_WrongNumArgs(interp, 2, objv, 1532 "class ?-strict? ?-failindex var? str"); 1533 return TCL_ERROR; 1534 } 1535 if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0, 1536 &index) != TCL_OK) { 1537 return TCL_ERROR; 1538 } 1539 if (objc != 4) { 1540 for (i = 3; i < objc-1; i++) { 1541 string2 = Tcl_GetStringFromObj(objv[i], &length2); 1542 if ((length2 > 1) && 1543 strncmp(string2, "-strict", (size_t) length2) == 0) { 1544 strict = 1; 1545 } else if ((length2 > 1) && 1546 strncmp(string2, "-failindex", 1547 (size_t) length2) == 0) { 1548 if (i+1 >= objc-1) { 1549 Tcl_WrongNumArgs(interp, 3, objv, 1550 "?-strict? ?-failindex var? str"); 1551 return TCL_ERROR; 1552 } 1553 failVarObj = objv[++i]; 1554 } else { 1555 Tcl_AppendStringsToObj(resultPtr, "bad option \"", 1556 string2, "\": must be -strict or -failindex", 1557 (char *) NULL); 1558 return TCL_ERROR; 1559 } 1560 } 1561 } 1562 1563 /* 1564 * We get the objPtr so that we can short-cut for some classes 1565 * by checking the object type (int and double), but we need 1566 * the string otherwise, because we don't want any conversion 1567 * of type occuring (as, for example, Tcl_Get*FromObj would do 1568 */ 1569 objPtr = objv[objc-1]; 1570 string1 = Tcl_GetStringFromObj(objPtr, &length1); 1571 if (length1 == 0) { 1572 if (strict) { 1573 result = 0; 1574 } 1575 goto str_is_done; 1576 } 1577 end = string1 + length1; 1578 1579 /* 1580 * When entering here, result == 1 and failat == 0 1581 */ 1582 switch ((enum isOptions) index) { 1583 case STR_IS_ALNUM: 1584 chcomp = Tcl_UniCharIsAlnum; 1585 break; 1586 case STR_IS_ALPHA: 1587 chcomp = Tcl_UniCharIsAlpha; 1588 break; 1589 case STR_IS_ASCII: 1590 for (; string1 < end; string1++, failat++) { 1591 /* 1592 * This is a valid check in unicode, because all 1593 * bytes < 0xC0 are single byte chars (but isascii 1594 * limits that def'n to 0x80). 1595 */ 1596 if (*((unsigned char *)string1) >= 0x80) { 1597 result = 0; 1598 break; 1599 } 1600 } 1601 break; 1602 case STR_IS_BOOL: 1603 case STR_IS_TRUE: 1604 case STR_IS_FALSE: 1605 /* Optimizers, beware Bug 1187123 ! */ 1606 if ((Tcl_GetBoolean(NULL, string1, &i) 1607 == TCL_ERROR) || 1608 (((enum isOptions) index == STR_IS_TRUE) && 1609 i == 0) || 1610 (((enum isOptions) index == STR_IS_FALSE) && 1611 i != 0)) { 1612 result = 0; 1613 } 1614 break; 1615 case STR_IS_CONTROL: 1616 chcomp = Tcl_UniCharIsControl; 1617 break; 1618 case STR_IS_DIGIT: 1619 chcomp = Tcl_UniCharIsDigit; 1620 break; 1621 case STR_IS_DOUBLE: { 1622 char *stop; 1623 1624 if ((objPtr->typePtr == &tclDoubleType) || 1625 (objPtr->typePtr == &tclIntType)) { 1626 break; 1627 } 1628 /* 1629 * This is adapted from Tcl_GetDouble 1630 * 1631 * The danger in this function is that 1632 * "12345678901234567890" is an acceptable 'double', 1633 * but will later be interp'd as an int by something 1634 * like [expr]. Therefore, we check to see if it looks 1635 * like an int, and if so we do a range check on it. 1636 * If strtoul gets to the end, we know we either 1637 * received an acceptable int, or over/underflow 1638 */ 1639 if (TclLooksLikeInt(string1, length1)) { 1640 errno = 0; 1641#ifdef TCL_WIDE_INT_IS_LONG 1642 strtoul(string1, &stop, 0); /* INTL: Tcl source. */ 1643#else 1644 strtoull(string1, &stop, 0); /* INTL: Tcl source. */ 1645#endif 1646 if (stop == end) { 1647 if (errno == ERANGE) { 1648 result = 0; 1649 failat = -1; 1650 } 1651 break; 1652 } 1653 } 1654 errno = 0; 1655 strtod(string1, &stop); /* INTL: Tcl source. */ 1656 if (errno == ERANGE) { 1657 /* 1658 * if (errno == ERANGE), then it was an over/underflow 1659 * problem, but in this method, we only want to know 1660 * yes or no, so bad flow returns 0 (false) and sets 1661 * the failVarObj to the string length. 1662 */ 1663 result = 0; 1664 failat = -1; 1665 } else if (stop == string1) { 1666 /* 1667 * In this case, nothing like a number was found 1668 */ 1669 result = 0; 1670 failat = 0; 1671 } else { 1672 /* 1673 * Assume we sucked up one char per byte 1674 * and then we go onto SPACE, since we are 1675 * allowed trailing whitespace 1676 */ 1677 failat = stop - string1; 1678 string1 = stop; 1679 chcomp = Tcl_UniCharIsSpace; 1680 } 1681 break; 1682 } 1683 case STR_IS_GRAPH: 1684 chcomp = Tcl_UniCharIsGraph; 1685 break; 1686 case STR_IS_INT: { 1687 char *stop; 1688 long int l = 0; 1689 1690 if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) { 1691 break; 1692 } 1693 /* 1694 * Like STR_IS_DOUBLE, but we use strtoul. 1695 * Since Tcl_GetIntFromObj already failed, 1696 * we set result to 0. 1697 */ 1698 result = 0; 1699 errno = 0; 1700 l = strtol(string1, &stop, 0); /* INTL: Tcl source. */ 1701 if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) { 1702 /* 1703 * if (errno == ERANGE), then it was an over/underflow 1704 * problem, but in this method, we only want to know 1705 * yes or no, so bad flow returns 0 (false) and sets 1706 * the failVarObj to the string length. 1707 */ 1708 failat = -1; 1709 1710 } else if (stop == string1) { 1711 /* 1712 * In this case, nothing like a number was found 1713 */ 1714 failat = 0; 1715 } else { 1716 /* 1717 * Assume we sucked up one char per byte 1718 * and then we go onto SPACE, since we are 1719 * allowed trailing whitespace 1720 */ 1721 failat = stop - string1; 1722 string1 = stop; 1723 chcomp = Tcl_UniCharIsSpace; 1724 } 1725 break; 1726 } 1727 case STR_IS_LOWER: 1728 chcomp = Tcl_UniCharIsLower; 1729 break; 1730 case STR_IS_PRINT: 1731 chcomp = Tcl_UniCharIsPrint; 1732 break; 1733 case STR_IS_PUNCT: 1734 chcomp = Tcl_UniCharIsPunct; 1735 break; 1736 case STR_IS_SPACE: 1737 chcomp = Tcl_UniCharIsSpace; 1738 break; 1739 case STR_IS_UPPER: 1740 chcomp = Tcl_UniCharIsUpper; 1741 break; 1742 case STR_IS_WORD: 1743 chcomp = Tcl_UniCharIsWordChar; 1744 break; 1745 case STR_IS_XDIGIT: { 1746 for (; string1 < end; string1++, failat++) { 1747 /* INTL: We assume unicode is bad for this class */ 1748 if ((*((unsigned char *)string1) >= 0xC0) || 1749 !isxdigit(*(unsigned char *)string1)) { 1750 result = 0; 1751 break; 1752 } 1753 } 1754 break; 1755 } 1756 } 1757 if (chcomp != NULL) { 1758 for (; string1 < end; string1 += length2, failat++) { 1759 length2 = TclUtfToUniChar(string1, &ch); 1760 if (!chcomp(ch)) { 1761 result = 0; 1762 break; 1763 } 1764 } 1765 } 1766 str_is_done: 1767 /* 1768 * Only set the failVarObj when we will return 0 1769 * and we have indicated a valid fail index (>= 0) 1770 */ 1771 if ((result == 0) && (failVarObj != NULL)) { 1772 Tcl_Obj *resPtr, *tmpPtr = Tcl_NewIntObj(failat); 1773 1774 Tcl_IncrRefCount(tmpPtr); 1775 resPtr = Tcl_ObjSetVar2(interp, failVarObj, NULL, tmpPtr, 1776 TCL_LEAVE_ERR_MSG); 1777 Tcl_DecrRefCount(tmpPtr); 1778 if (resPtr == NULL) { 1779 return TCL_ERROR; 1780 } 1781 } 1782 Tcl_SetBooleanObj(resultPtr, result); 1783 break; 1784 } 1785 case STR_LAST: { 1786 Tcl_UniChar *ustring1, *ustring2, *p; 1787 int match, start; 1788 1789 if (objc < 4 || objc > 5) { 1790 Tcl_WrongNumArgs(interp, 2, objv, 1791 "subString string ?startIndex?"); 1792 return TCL_ERROR; 1793 } 1794 1795 /* 1796 * We are searching string2 for the sequence string1. 1797 */ 1798 1799 match = -1; 1800 start = 0; 1801 length2 = -1; 1802 1803 ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); 1804 ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); 1805 1806 if (objc == 5) { 1807 /* 1808 * If a startIndex is specified, we will need to restrict 1809 * the string range to that char index in the string 1810 */ 1811 if (TclGetIntForIndex(interp, objv[4], length2 - 1, 1812 &start) != TCL_OK) { 1813 return TCL_ERROR; 1814 } 1815 if (start < 0) { 1816 goto str_last_done; 1817 } else if (start < length2) { 1818 p = ustring2 + start + 1 - length1; 1819 } else { 1820 p = ustring2 + length2 - length1; 1821 } 1822 } else { 1823 p = ustring2 + length2 - length1; 1824 } 1825 1826 if (length1 > 0) { 1827 for (; p >= ustring2; p--) { 1828 /* 1829 * Scan backwards to find the first character. 1830 */ 1831 if ((*p == *ustring1) && 1832 (memcmp((char *) ustring1, (char *) p, (size_t) 1833 (length1 * sizeof(Tcl_UniChar))) == 0)) { 1834 match = p - ustring2; 1835 break; 1836 } 1837 } 1838 } 1839 1840 str_last_done: 1841 Tcl_SetIntObj(resultPtr, match); 1842 break; 1843 } 1844 case STR_BYTELENGTH: 1845 case STR_LENGTH: { 1846 if (objc != 3) { 1847 Tcl_WrongNumArgs(interp, 2, objv, "string"); 1848 return TCL_ERROR; 1849 } 1850 1851 if ((enum options) index == STR_BYTELENGTH) { 1852 (void) Tcl_GetStringFromObj(objv[2], &length1); 1853 } else { 1854 /* 1855 * If we have a ByteArray object, avoid recomputing the 1856 * string since the byte array contains one byte per 1857 * character. Otherwise, use the Unicode string rep to 1858 * calculate the length. 1859 */ 1860 1861 if (objv[2]->typePtr == &tclByteArrayType) { 1862 (void) Tcl_GetByteArrayFromObj(objv[2], &length1); 1863 } else { 1864 length1 = Tcl_GetCharLength(objv[2]); 1865 } 1866 } 1867 Tcl_SetIntObj(resultPtr, length1); 1868 break; 1869 } 1870 case STR_MAP: { 1871 int mapElemc, nocase = 0, copySource = 0; 1872 Tcl_Obj **mapElemv, *sourceObj; 1873 Tcl_UniChar *ustring1, *ustring2, *p, *end; 1874 int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*, 1875 CONST Tcl_UniChar*, unsigned long)); 1876 1877 if (objc < 4 || objc > 5) { 1878 Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string"); 1879 return TCL_ERROR; 1880 } 1881 1882 if (objc == 5) { 1883 string2 = Tcl_GetStringFromObj(objv[2], &length2); 1884 if ((length2 > 1) && 1885 strncmp(string2, "-nocase", (size_t) length2) == 0) { 1886 nocase = 1; 1887 } else { 1888 Tcl_AppendStringsToObj(resultPtr, "bad option \"", 1889 string2, "\": must be -nocase", 1890 (char *) NULL); 1891 return TCL_ERROR; 1892 } 1893 } 1894 1895 if (Tcl_ListObjGetElements(interp, objv[objc-2], &mapElemc, 1896 &mapElemv) != TCL_OK) { 1897 return TCL_ERROR; 1898 } 1899 if (mapElemc == 0) { 1900 /* 1901 * empty charMap, just return whatever string was given 1902 */ 1903 Tcl_SetObjResult(interp, objv[objc-1]); 1904 return TCL_OK; 1905 } else if (mapElemc & 1) { 1906 /* 1907 * The charMap must be an even number of key/value items 1908 */ 1909 Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1); 1910 return TCL_ERROR; 1911 } 1912 1913 /* 1914 * Take a copy of the source string object if it is the 1915 * same as the map string to cut out nasty sharing 1916 * crashes. [Bug 1018562] 1917 */ 1918 if (objv[objc-2] == objv[objc-1]) { 1919 sourceObj = Tcl_DuplicateObj(objv[objc-1]); 1920 copySource = 1; 1921 } else { 1922 sourceObj = objv[objc-1]; 1923 } 1924 ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1); 1925 if (length1 == 0) { 1926 /* 1927 * Empty input string, just stop now 1928 */ 1929 if (copySource) { 1930 Tcl_DecrRefCount(sourceObj); 1931 } 1932 break; 1933 } 1934 end = ustring1 + length1; 1935 1936 strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; 1937 1938 /* 1939 * Force result to be Unicode 1940 */ 1941 Tcl_SetUnicodeObj(resultPtr, ustring1, 0); 1942 1943 if (mapElemc == 2) { 1944 /* 1945 * Special case for one map pair which avoids the extra 1946 * for loop and extra calls to get Unicode data. The 1947 * algorithm is otherwise identical to the multi-pair case. 1948 * This will be >30% faster on larger strings. 1949 */ 1950 int mapLen; 1951 Tcl_UniChar *mapString, u2lc; 1952 1953 ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); 1954 p = ustring1; 1955 if ((length2 > length1) || (length2 == 0)) { 1956 /* match string is either longer than input or empty */ 1957 ustring1 = end; 1958 } else { 1959 mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); 1960 u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); 1961 for (; ustring1 < end; ustring1++) { 1962 if (((*ustring1 == *ustring2) || 1963 (nocase && (Tcl_UniCharToLower(*ustring1) == 1964 u2lc))) && 1965 ((length2 == 1) || strCmpFn(ustring1, ustring2, 1966 (unsigned long) length2) == 0)) { 1967 if (p != ustring1) { 1968 Tcl_AppendUnicodeToObj(resultPtr, p, 1969 ustring1 - p); 1970 p = ustring1 + length2; 1971 } else { 1972 p += length2; 1973 } 1974 ustring1 = p - 1; 1975 1976 Tcl_AppendUnicodeToObj(resultPtr, mapString, 1977 mapLen); 1978 } 1979 } 1980 } 1981 } else { 1982 Tcl_UniChar **mapStrings, *u2lc = NULL; 1983 int *mapLens; 1984 /* 1985 * Precompute pointers to the unicode string and length. 1986 * This saves us repeated function calls later, 1987 * significantly speeding up the algorithm. We only need 1988 * the lowercase first char in the nocase case. 1989 */ 1990 mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2) 1991 * sizeof(Tcl_UniChar *)); 1992 mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int)); 1993 if (nocase) { 1994 u2lc = (Tcl_UniChar *) 1995 ckalloc((mapElemc) * sizeof(Tcl_UniChar)); 1996 } 1997 for (index = 0; index < mapElemc; index++) { 1998 mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], 1999 &(mapLens[index])); 2000 if (nocase && ((index % 2) == 0)) { 2001 u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); 2002 } 2003 } 2004 for (p = ustring1; ustring1 < end; ustring1++) { 2005 for (index = 0; index < mapElemc; index += 2) { 2006 /* 2007 * Get the key string to match on. 2008 */ 2009 ustring2 = mapStrings[index]; 2010 length2 = mapLens[index]; 2011 if ((length2 > 0) && ((*ustring1 == *ustring2) || 2012 (nocase && (Tcl_UniCharToLower(*ustring1) == 2013 u2lc[index/2]))) && 2014 /* restrict max compare length */ 2015 ((end - ustring1) >= length2) && 2016 ((length2 == 1) || strCmpFn(ustring2, ustring1, 2017 (unsigned long) length2) == 0)) { 2018 if (p != ustring1) { 2019 /* 2020 * Put the skipped chars onto the result first 2021 */ 2022 Tcl_AppendUnicodeToObj(resultPtr, p, 2023 ustring1 - p); 2024 p = ustring1 + length2; 2025 } else { 2026 p += length2; 2027 } 2028 /* 2029 * Adjust len to be full length of matched string 2030 */ 2031 ustring1 = p - 1; 2032 2033 /* 2034 * Append the map value to the unicode string 2035 */ 2036 Tcl_AppendUnicodeToObj(resultPtr, 2037 mapStrings[index+1], mapLens[index+1]); 2038 break; 2039 } 2040 } 2041 } 2042 ckfree((char *) mapStrings); 2043 ckfree((char *) mapLens); 2044 if (nocase) { 2045 ckfree((char *) u2lc); 2046 } 2047 } 2048 if (p != ustring1) { 2049 /* 2050 * Put the rest of the unmapped chars onto result 2051 */ 2052 Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); 2053 } 2054 if (copySource) { 2055 Tcl_DecrRefCount(sourceObj); 2056 } 2057 break; 2058 } 2059 case STR_MATCH: { 2060 Tcl_UniChar *ustring1, *ustring2; 2061 int nocase = 0; 2062 2063 if (objc < 4 || objc > 5) { 2064 Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string"); 2065 return TCL_ERROR; 2066 } 2067 2068 if (objc == 5) { 2069 string2 = Tcl_GetStringFromObj(objv[2], &length2); 2070 if ((length2 > 1) && 2071 strncmp(string2, "-nocase", (size_t) length2) == 0) { 2072 nocase = 1; 2073 } else { 2074 Tcl_AppendStringsToObj(resultPtr, "bad option \"", 2075 string2, "\": must be -nocase", 2076 (char *) NULL); 2077 return TCL_ERROR; 2078 } 2079 } 2080 ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1); 2081 ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2); 2082 Tcl_SetBooleanObj(resultPtr, TclUniCharMatch(ustring1, length1, 2083 ustring2, length2, nocase)); 2084 break; 2085 } 2086 case STR_RANGE: { 2087 int first, last; 2088 2089 if (objc != 5) { 2090 Tcl_WrongNumArgs(interp, 2, objv, "string first last"); 2091 return TCL_ERROR; 2092 } 2093 2094 /* 2095 * If we have a ByteArray object, avoid indexing in the 2096 * Utf string since the byte array contains one byte per 2097 * character. Otherwise, use the Unicode string rep to 2098 * get the range. 2099 */ 2100 2101 if (objv[2]->typePtr == &tclByteArrayType) { 2102 string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1); 2103 length1--; 2104 } else { 2105 /* 2106 * Get the length in actual characters. 2107 */ 2108 string1 = NULL; 2109 length1 = Tcl_GetCharLength(objv[2]) - 1; 2110 } 2111 2112 if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) 2113 || (TclGetIntForIndex(interp, objv[4], length1, 2114 &last) != TCL_OK)) { 2115 return TCL_ERROR; 2116 } 2117 2118 if (first < 0) { 2119 first = 0; 2120 } 2121 if (last >= length1) { 2122 last = length1; 2123 } 2124 if (last >= first) { 2125 if (string1 != NULL) { 2126 int numBytes = last - first + 1; 2127 resultPtr = Tcl_NewByteArrayObj( 2128 (unsigned char *) &string1[first], numBytes); 2129 Tcl_SetObjResult(interp, resultPtr); 2130 } else { 2131 Tcl_SetObjResult(interp, 2132 Tcl_GetRange(objv[2], first, last)); 2133 } 2134 } 2135 break; 2136 } 2137 case STR_REPEAT: { 2138 int count; 2139 2140 if (objc != 4) { 2141 Tcl_WrongNumArgs(interp, 2, objv, "string count"); 2142 return TCL_ERROR; 2143 } 2144 2145 if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) { 2146 return TCL_ERROR; 2147 } 2148 2149 if (count == 1) { 2150 Tcl_SetObjResult(interp, objv[2]); 2151 } else if (count > 1) { 2152 string1 = Tcl_GetStringFromObj(objv[2], &length1); 2153 if (length1 > 0) { 2154 /* 2155 * Only build up a string that has data. Instead of 2156 * building it up with repeated appends, we just allocate 2157 * the necessary space once and copy the string value in. 2158 * Check for overflow with back-division. [Bug #714106] 2159 */ 2160 length2 = length1 * count; 2161 if ((length2 / count) != length1) { 2162 char buf[TCL_INTEGER_SPACE+1]; 2163 sprintf(buf, "%d", INT_MAX); 2164 Tcl_AppendStringsToObj(resultPtr, 2165 "string size overflow, must be less than ", 2166 buf, (char *) NULL); 2167 return TCL_ERROR; 2168 } 2169 /* 2170 * Include space for the NULL 2171 */ 2172 string2 = (char *) ckalloc((size_t) length2+1); 2173 for (index = 0; index < count; index++) { 2174 memcpy(string2 + (length1 * index), string1, 2175 (size_t) length1); 2176 } 2177 string2[length2] = '\0'; 2178 /* 2179 * We have to directly assign this instead of using 2180 * Tcl_SetStringObj (and indirectly TclInitStringRep) 2181 * because that makes another copy of the data. 2182 */ 2183 resultPtr = Tcl_NewObj(); 2184 resultPtr->bytes = string2; 2185 resultPtr->length = length2; 2186 Tcl_SetObjResult(interp, resultPtr); 2187 } 2188 } 2189 break; 2190 } 2191 case STR_REPLACE: { 2192 Tcl_UniChar *ustring1; 2193 int first, last; 2194 2195 if (objc < 5 || objc > 6) { 2196 Tcl_WrongNumArgs(interp, 2, objv, 2197 "string first last ?string?"); 2198 return TCL_ERROR; 2199 } 2200 2201 ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); 2202 length1--; 2203 2204 if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) 2205 || (TclGetIntForIndex(interp, objv[4], length1, 2206 &last) != TCL_OK)) { 2207 return TCL_ERROR; 2208 } 2209 2210 if ((last < first) || (last < 0) || (first > length1)) { 2211 Tcl_SetObjResult(interp, objv[2]); 2212 } else { 2213 if (first < 0) { 2214 first = 0; 2215 } 2216 2217 Tcl_SetUnicodeObj(resultPtr, ustring1, first); 2218 if (objc == 6) { 2219 Tcl_AppendObjToObj(resultPtr, objv[5]); 2220 } 2221 if (last < length1) { 2222 Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1, 2223 length1 - last); 2224 } 2225 } 2226 break; 2227 } 2228 case STR_TOLOWER: 2229 case STR_TOUPPER: 2230 case STR_TOTITLE: 2231 if (objc < 3 || objc > 5) { 2232 Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?"); 2233 return TCL_ERROR; 2234 } 2235 2236 string1 = Tcl_GetStringFromObj(objv[2], &length1); 2237 2238 if (objc == 3) { 2239 /* 2240 * Since the result object is not a shared object, it is 2241 * safe to copy the string into the result and do the 2242 * conversion in place. The conversion may change the length 2243 * of the string, so reset the length after conversion. 2244 */ 2245 2246 Tcl_SetStringObj(resultPtr, string1, length1); 2247 if ((enum options) index == STR_TOLOWER) { 2248 length1 = Tcl_UtfToLower(Tcl_GetString(resultPtr)); 2249 } else if ((enum options) index == STR_TOUPPER) { 2250 length1 = Tcl_UtfToUpper(Tcl_GetString(resultPtr)); 2251 } else { 2252 length1 = Tcl_UtfToTitle(Tcl_GetString(resultPtr)); 2253 } 2254 Tcl_SetObjLength(resultPtr, length1); 2255 } else { 2256 int first, last; 2257 CONST char *start, *end; 2258 2259 length1 = Tcl_NumUtfChars(string1, length1) - 1; 2260 if (TclGetIntForIndex(interp, objv[3], length1, 2261 &first) != TCL_OK) { 2262 return TCL_ERROR; 2263 } 2264 if (first < 0) { 2265 first = 0; 2266 } 2267 last = first; 2268 if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1, 2269 &last) != TCL_OK)) { 2270 return TCL_ERROR; 2271 } 2272 if (last >= length1) { 2273 last = length1; 2274 } 2275 if (last < first) { 2276 Tcl_SetObjResult(interp, objv[2]); 2277 break; 2278 } 2279 start = Tcl_UtfAtIndex(string1, first); 2280 end = Tcl_UtfAtIndex(start, last - first + 1); 2281 length2 = end-start; 2282 string2 = ckalloc((size_t) length2+1); 2283 memcpy(string2, start, (size_t) length2); 2284 string2[length2] = '\0'; 2285 if ((enum options) index == STR_TOLOWER) { 2286 length2 = Tcl_UtfToLower(string2); 2287 } else if ((enum options) index == STR_TOUPPER) { 2288 length2 = Tcl_UtfToUpper(string2); 2289 } else { 2290 length2 = Tcl_UtfToTitle(string2); 2291 } 2292 Tcl_SetStringObj(resultPtr, string1, start - string1); 2293 Tcl_AppendToObj(resultPtr, string2, length2); 2294 Tcl_AppendToObj(resultPtr, end, -1); 2295 ckfree(string2); 2296 } 2297 break; 2298 2299 case STR_TRIM: { 2300 Tcl_UniChar ch, trim; 2301 register CONST char *p, *end; 2302 char *check, *checkEnd; 2303 int offset; 2304 2305 left = 1; 2306 right = 1; 2307 2308 dotrim: 2309 if (objc == 4) { 2310 string2 = Tcl_GetStringFromObj(objv[3], &length2); 2311 } else if (objc == 3) { 2312 string2 = " \t\n\r"; 2313 length2 = strlen(string2); 2314 } else { 2315 Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?"); 2316 return TCL_ERROR; 2317 } 2318 string1 = Tcl_GetStringFromObj(objv[2], &length1); 2319 checkEnd = string2 + length2; 2320 2321 if (left) { 2322 end = string1 + length1; 2323 /* 2324 * The outer loop iterates over the string. The inner 2325 * loop iterates over the trim characters. The loops 2326 * terminate as soon as a non-trim character is discovered 2327 * and string1 is left pointing at the first non-trim 2328 * character. 2329 */ 2330 2331 for (p = string1; p < end; p += offset) { 2332 offset = TclUtfToUniChar(p, &ch); 2333 2334 for (check = string2; ; ) { 2335 if (check >= checkEnd) { 2336 p = end; 2337 break; 2338 } 2339 check += TclUtfToUniChar(check, &trim); 2340 if (ch == trim) { 2341 length1 -= offset; 2342 string1 += offset; 2343 break; 2344 } 2345 } 2346 } 2347 } 2348 if (right) { 2349 end = string1; 2350 2351 /* 2352 * The outer loop iterates over the string. The inner 2353 * loop iterates over the trim characters. The loops 2354 * terminate as soon as a non-trim character is discovered 2355 * and length1 marks the last non-trim character. 2356 */ 2357 2358 for (p = string1 + length1; p > end; ) { 2359 p = Tcl_UtfPrev(p, string1); 2360 offset = TclUtfToUniChar(p, &ch); 2361 for (check = string2; ; ) { 2362 if (check >= checkEnd) { 2363 p = end; 2364 break; 2365 } 2366 check += TclUtfToUniChar(check, &trim); 2367 if (ch == trim) { 2368 length1 -= offset; 2369 break; 2370 } 2371 } 2372 } 2373 } 2374 Tcl_SetStringObj(resultPtr, string1, length1); 2375 break; 2376 } 2377 case STR_TRIMLEFT: { 2378 left = 1; 2379 right = 0; 2380 goto dotrim; 2381 } 2382 case STR_TRIMRIGHT: { 2383 left = 0; 2384 right = 1; 2385 goto dotrim; 2386 } 2387 case STR_WORDEND: { 2388 int cur; 2389 Tcl_UniChar ch; 2390 CONST char *p, *end; 2391 int numChars; 2392 2393 if (objc != 4) { 2394 Tcl_WrongNumArgs(interp, 2, objv, "string index"); 2395 return TCL_ERROR; 2396 } 2397 2398 string1 = Tcl_GetStringFromObj(objv[2], &length1); 2399 numChars = Tcl_NumUtfChars(string1, length1); 2400 if (TclGetIntForIndex(interp, objv[3], numChars-1, 2401 &index) != TCL_OK) { 2402 return TCL_ERROR; 2403 } 2404 if (index < 0) { 2405 index = 0; 2406 } 2407 if (index < numChars) { 2408 p = Tcl_UtfAtIndex(string1, index); 2409 end = string1+length1; 2410 for (cur = index; p < end; cur++) { 2411 p += TclUtfToUniChar(p, &ch); 2412 if (!Tcl_UniCharIsWordChar(ch)) { 2413 break; 2414 } 2415 } 2416 if (cur == index) { 2417 cur++; 2418 } 2419 } else { 2420 cur = numChars; 2421 } 2422 Tcl_SetIntObj(resultPtr, cur); 2423 break; 2424 } 2425 case STR_WORDSTART: { 2426 int cur; 2427 Tcl_UniChar ch; 2428 CONST char *p; 2429 int numChars; 2430 2431 if (objc != 4) { 2432 Tcl_WrongNumArgs(interp, 2, objv, "string index"); 2433 return TCL_ERROR; 2434 } 2435 2436 string1 = Tcl_GetStringFromObj(objv[2], &length1); 2437 numChars = Tcl_NumUtfChars(string1, length1); 2438 if (TclGetIntForIndex(interp, objv[3], numChars-1, 2439 &index) != TCL_OK) { 2440 return TCL_ERROR; 2441 } 2442 if (index >= numChars) { 2443 index = numChars - 1; 2444 } 2445 cur = 0; 2446 if (index > 0) { 2447 p = Tcl_UtfAtIndex(string1, index); 2448 for (cur = index; cur >= 0; cur--) { 2449 TclUtfToUniChar(p, &ch); 2450 if (!Tcl_UniCharIsWordChar(ch)) { 2451 break; 2452 } 2453 p = Tcl_UtfPrev(p, string1); 2454 } 2455 if (cur != index) { 2456 cur += 1; 2457 } 2458 } 2459 Tcl_SetIntObj(resultPtr, cur); 2460 break; 2461 } 2462 } 2463 return TCL_OK; 2464} 2465 2466/* 2467 *---------------------------------------------------------------------- 2468 * 2469 * Tcl_SubstObjCmd -- 2470 * 2471 * This procedure is invoked to process the "subst" Tcl command. 2472 * See the user documentation for details on what it does. This 2473 * command relies on Tcl_SubstObj() for its implementation. 2474 * 2475 * Results: 2476 * A standard Tcl result. 2477 * 2478 * Side effects: 2479 * See the user documentation. 2480 * 2481 *---------------------------------------------------------------------- 2482 */ 2483 2484 /* ARGSUSED */ 2485int 2486Tcl_SubstObjCmd(dummy, interp, objc, objv) 2487 ClientData dummy; /* Not used. */ 2488 Tcl_Interp *interp; /* Current interpreter. */ 2489 int objc; /* Number of arguments. */ 2490 Tcl_Obj *CONST objv[]; /* Argument objects. */ 2491{ 2492 static CONST char *substOptions[] = { 2493 "-nobackslashes", "-nocommands", "-novariables", (char *) NULL 2494 }; 2495 enum substOptions { 2496 SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS 2497 }; 2498 Tcl_Obj *resultPtr; 2499 int optionIndex, flags, i; 2500 2501 /* 2502 * Parse command-line options. 2503 */ 2504 2505 flags = TCL_SUBST_ALL; 2506 for (i = 1; i < (objc-1); i++) { 2507 if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, 2508 "switch", 0, &optionIndex) != TCL_OK) { 2509 2510 return TCL_ERROR; 2511 } 2512 switch (optionIndex) { 2513 case SUBST_NOBACKSLASHES: { 2514 flags &= ~TCL_SUBST_BACKSLASHES; 2515 break; 2516 } 2517 case SUBST_NOCOMMANDS: { 2518 flags &= ~TCL_SUBST_COMMANDS; 2519 break; 2520 } 2521 case SUBST_NOVARS: { 2522 flags &= ~TCL_SUBST_VARIABLES; 2523 break; 2524 } 2525 default: { 2526 panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); 2527 } 2528 } 2529 } 2530 if (i != (objc-1)) { 2531 Tcl_WrongNumArgs(interp, 1, objv, 2532 "?-nobackslashes? ?-nocommands? ?-novariables? string"); 2533 return TCL_ERROR; 2534 } 2535 2536 /* 2537 * Perform the substitution. 2538 */ 2539 resultPtr = Tcl_SubstObj(interp, objv[i], flags); 2540 2541 if (resultPtr == NULL) { 2542 return TCL_ERROR; 2543 } 2544 Tcl_SetObjResult(interp, resultPtr); 2545 return TCL_OK; 2546} 2547 2548/* 2549 *---------------------------------------------------------------------- 2550 * 2551 * Tcl_SubstObj -- 2552 * 2553 * This function performs the substitutions specified on the 2554 * given string as described in the user documentation for the 2555 * "subst" Tcl command. This code is heavily based on an 2556 * implementation by Andrew Payne. Note that if a command 2557 * substitution returns TCL_CONTINUE or TCL_RETURN from its 2558 * evaluation and is not completely well-formed, the results are 2559 * not defined (or at least hard to characterise.) This fault 2560 * will be fixed at some point, but the cost of the only sane 2561 * fix (well-formedness check first) is such that you need to 2562 * "precompile and cache" to stop everyone from being hit with 2563 * the consequences every time through. Note that the current 2564 * behaviour is not a security hole; it just restarts parsing 2565 * the string following the substitution in a mildly surprising 2566 * place, and it is a very bad idea to count on this remaining 2567 * the same in future... 2568 * 2569 * Results: 2570 * A Tcl_Obj* containing the substituted string, or NULL to 2571 * indicate that an error occurred. 2572 * 2573 * Side effects: 2574 * See the user documentation. 2575 * 2576 *---------------------------------------------------------------------- 2577 */ 2578 2579Tcl_Obj * 2580Tcl_SubstObj(interp, objPtr, flags) 2581 Tcl_Interp *interp; 2582 Tcl_Obj *objPtr; 2583 int flags; 2584{ 2585 Tcl_Obj *resultObj; 2586 char *p, *old; 2587 int length; 2588 2589 old = p = Tcl_GetStringFromObj(objPtr, &length); 2590 resultObj = Tcl_NewStringObj("", 0); 2591 while (length) { 2592 switch (*p) { 2593 case '\\': 2594 if (flags & TCL_SUBST_BACKSLASHES) { 2595 char buf[TCL_UTF_MAX]; 2596 int count; 2597 2598 if (p != old) { 2599 Tcl_AppendToObj(resultObj, old, p-old); 2600 } 2601 Tcl_AppendToObj(resultObj, buf, 2602 Tcl_UtfBackslash(p, &count, buf)); 2603 p += count; length -= count; 2604 old = p; 2605 } else { 2606 p++; length--; 2607 } 2608 break; 2609 2610 case '$': 2611 if (flags & TCL_SUBST_VARIABLES) { 2612 Tcl_Parse parse; 2613 int code; 2614 2615 /* 2616 * Code is simpler overall if we (effectively) inline 2617 * Tcl_ParseVar, particularly as that allows us to use 2618 * a non-string interface when we come to appending 2619 * the variable contents to the result object. There 2620 * are a few other optimisations that doing this 2621 * enables (like being able to continue the run of 2622 * unsubstituted characters straight through if a '$' 2623 * does not precede a variable name.) 2624 */ 2625 if (Tcl_ParseVarName(interp, p, length, &parse, 0) != TCL_OK) { 2626 goto errorResult; 2627 } 2628 if (parse.numTokens == 1) { 2629 /* 2630 * There isn't a variable name after all: the $ is 2631 * just a $. 2632 */ 2633 p++; length--; 2634 break; 2635 } 2636 if (p != old) { 2637 Tcl_AppendToObj(resultObj, old, p-old); 2638 } 2639 p += parse.tokenPtr->size; 2640 length -= parse.tokenPtr->size; 2641 code = Tcl_EvalTokensStandard(interp, parse.tokenPtr, 2642 parse.numTokens); 2643 if (code == TCL_ERROR) { 2644 goto errorResult; 2645 } 2646 if (code == TCL_BREAK) { 2647 Tcl_ResetResult(interp); 2648 return resultObj; 2649 } 2650 if (code != TCL_CONTINUE) { 2651 Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp)); 2652 } 2653 Tcl_ResetResult(interp); 2654 old = p; 2655 } else { 2656 p++; length--; 2657 } 2658 break; 2659 2660 case '[': 2661 if (flags & TCL_SUBST_COMMANDS) { 2662 Interp *iPtr = (Interp *) interp; 2663 int code; 2664 2665 if (p != old) { 2666 Tcl_AppendToObj(resultObj, old, p-old); 2667 } 2668 iPtr->evalFlags = TCL_BRACKET_TERM; 2669 iPtr->numLevels++; 2670 code = TclInterpReady(interp); 2671 if (code == TCL_OK) { 2672 code = Tcl_EvalEx(interp, p+1, length-1, 0); 2673 } 2674 iPtr->numLevels--; 2675 switch (code) { 2676 case TCL_ERROR: 2677 goto errorResult; 2678 case TCL_BREAK: 2679 Tcl_ResetResult(interp); 2680 return resultObj; 2681 default: 2682 Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp)); 2683 case TCL_CONTINUE: 2684 Tcl_ResetResult(interp); 2685 old = p = (p+1 + iPtr->termOffset + 1); 2686 length -= (iPtr->termOffset + 2); 2687 } 2688 } else { 2689 p++; length--; 2690 } 2691 break; 2692 default: 2693 p++; length--; 2694 break; 2695 } 2696 } 2697 if (p != old) { 2698 Tcl_AppendToObj(resultObj, old, p-old); 2699 } 2700 return resultObj; 2701 2702 errorResult: 2703 Tcl_DecrRefCount(resultObj); 2704 return NULL; 2705} 2706 2707/* 2708 *---------------------------------------------------------------------- 2709 * 2710 * Tcl_SwitchObjCmd -- 2711 * 2712 * This object-based procedure is invoked to process the "switch" Tcl 2713 * command. See the user documentation for details on what it does. 2714 * 2715 * Results: 2716 * A standard Tcl object result. 2717 * 2718 * Side effects: 2719 * See the user documentation. 2720 * 2721 *---------------------------------------------------------------------- 2722 */ 2723 2724 /* ARGSUSED */ 2725int 2726Tcl_SwitchObjCmd(dummy, interp, objc, objv) 2727 ClientData dummy; /* Not used. */ 2728 Tcl_Interp *interp; /* Current interpreter. */ 2729 int objc; /* Number of arguments. */ 2730 Tcl_Obj *CONST objv[]; /* Argument objects. */ 2731{ 2732 int i, j, index, mode, matched, result, splitObjs; 2733 char *string, *pattern; 2734 Tcl_Obj *stringObj; 2735 Tcl_Obj *CONST *savedObjv = objv; 2736#ifdef TCL_TIP280 2737 Interp* iPtr = (Interp*) interp; 2738 int pc = 0; 2739 int bidx = 0; /* Index of body argument */ 2740 Tcl_Obj* blist = NULL; /* List obj which is the body */ 2741 CmdFrame ctx; /* Copy of the topmost cmdframe, 2742 * to allow us to mess with the 2743 * line information */ 2744#endif 2745 static CONST char *options[] = { 2746 "-exact", "-glob", "-regexp", "--", 2747 NULL 2748 }; 2749 enum options { 2750 OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST 2751 }; 2752 2753 mode = OPT_EXACT; 2754 for (i = 1; i < objc; i++) { 2755 string = Tcl_GetString(objv[i]); 2756 if (string[0] != '-') { 2757 break; 2758 } 2759 if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, 2760 &index) != TCL_OK) { 2761 return TCL_ERROR; 2762 } 2763 if (index == OPT_LAST) { 2764 i++; 2765 break; 2766 } 2767 mode = index; 2768 } 2769 2770 if (objc - i < 2) { 2771 Tcl_WrongNumArgs(interp, 1, objv, 2772 "?switches? string pattern body ... ?default body?"); 2773 return TCL_ERROR; 2774 } 2775 2776 stringObj = objv[i]; 2777 objc -= i + 1; 2778 objv += i + 1; 2779#ifdef TCL_TIP280 2780 bidx = i+1; /* First after the match string */ 2781#endif 2782 2783 /* 2784 * If all of the pattern/command pairs are lumped into a single 2785 * argument, split them out again. 2786 * 2787 * TIP #280: Determine the lines the words in the list start at, based on 2788 * the same data for the list word itself. The cmdFramePtr line information 2789 * is manipulated directly. 2790 */ 2791 2792 splitObjs = 0; 2793 if (objc == 1) { 2794 Tcl_Obj **listv; 2795#ifdef TCL_TIP280 2796 blist = objv[0]; 2797#endif 2798 if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { 2799 return TCL_ERROR; 2800 } 2801 2802 /* 2803 * Ensure that the list is non-empty. 2804 */ 2805 2806 if (objc < 1) { 2807 Tcl_WrongNumArgs(interp, 1, savedObjv, 2808 "?switches? string {pattern body ... ?default body?}"); 2809 return TCL_ERROR; 2810 } 2811 objv = listv; 2812 splitObjs = 1; 2813 } 2814 2815 /* 2816 * Complain if there is an odd number of words in the list of 2817 * patterns and bodies. 2818 */ 2819 2820 if (objc % 2) { 2821 Tcl_ResetResult(interp); 2822 Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); 2823 2824 /* 2825 * Check if this can be due to a badly placed comment 2826 * in the switch block. 2827 * 2828 * The following is an heuristic to detect the infamous 2829 * "comment in switch" error: just check if a pattern 2830 * begins with '#'. 2831 */ 2832 2833 if (splitObjs) { 2834 for (i=0 ; i<objc ; i+=2) { 2835 if (Tcl_GetString(objv[i])[0] == '#') { 2836 Tcl_AppendResult(interp, ", this may be due to a ", 2837 "comment incorrectly placed outside of a ", 2838 "switch body - see the \"switch\" ", 2839 "documentation", NULL); 2840 break; 2841 } 2842 } 2843 } 2844 2845 return TCL_ERROR; 2846 } 2847 2848 /* 2849 * Complain if the last body is a continuation. Note that this 2850 * check assumes that the list is non-empty! 2851 */ 2852 2853 if (strcmp(Tcl_GetString(objv[objc-1]), "-") == 0) { 2854 Tcl_ResetResult(interp); 2855 Tcl_AppendResult(interp, "no body specified for pattern \"", 2856 Tcl_GetString(objv[objc-2]), "\"", NULL); 2857 return TCL_ERROR; 2858 } 2859 2860 for (i = 0; i < objc; i += 2) { 2861 /* 2862 * See if the pattern matches the string. 2863 */ 2864 2865 pattern = Tcl_GetString(objv[i]); 2866 2867 matched = 0; 2868 if ((i == objc - 2) 2869 && (*pattern == 'd') 2870 && (strcmp(pattern, "default") == 0)) { 2871 matched = 1; 2872 } else { 2873 switch (mode) { 2874 case OPT_EXACT: 2875 matched = (strcmp(Tcl_GetString(stringObj), pattern) == 0); 2876 break; 2877 case OPT_GLOB: 2878 matched = Tcl_StringMatch(Tcl_GetString(stringObj), 2879 pattern); 2880 break; 2881 case OPT_REGEXP: 2882 matched = Tcl_RegExpMatchObj(interp, stringObj, objv[i]); 2883 if (matched < 0) { 2884 return TCL_ERROR; 2885 } 2886 break; 2887 } 2888 } 2889 if (matched == 0) { 2890 continue; 2891 } 2892 2893 /* 2894 * We've got a match. Find a body to execute, skipping bodies 2895 * that are "-". 2896 * 2897 * TIP#280: Now is also the time to determine a line number for the 2898 * single-word case. 2899 */ 2900 2901#ifdef TCL_TIP280 2902 ctx = *iPtr->cmdFramePtr; 2903 2904 if (splitObjs) { 2905 /* We have to perform the GetSrc and other type dependent handling 2906 * of the frame here because we are munging with the line numbers, 2907 * something the other commands like if, etc. are not doing. Them 2908 * are fine with simply passing the CmdFrame through and having 2909 * the special handling done in 'info frame', or the bc compiler 2910 */ 2911 2912 if (ctx.type == TCL_LOCATION_BC) { 2913 /* Note: Type BC => ctx.data.eval.path is not used. 2914 * ctx.data.tebc.codePtr is used instead. 2915 */ 2916 TclGetSrcInfoForPc (&ctx); 2917 pc = 1; 2918 /* The line information in the cmdFrame is now a copy we do 2919 * not own */ 2920 } 2921 2922 if (ctx.type == TCL_LOCATION_SOURCE) { 2923 int bline = ctx.line [bidx]; 2924 if (bline >= 0) { 2925 ctx.line = (int*) ckalloc (objc * sizeof(int)); 2926 ctx.nline = objc; 2927 2928 ListLines (blist, bline, objc, ctx.line, objv); 2929 } else { 2930 int k; 2931 /* Dynamic code word ... All elements are relative to themselves */ 2932 2933 ctx.line = (int*) ckalloc (objc * sizeof(int)); 2934 ctx.nline = objc; 2935 for (k=0; k < objc; k++) {ctx.line[k] = -1;} 2936 } 2937 } else { 2938 int k; 2939 /* Anything else ... No information, or dynamic ... */ 2940 2941 ctx.line = (int*) ckalloc (objc * sizeof(int)); 2942 ctx.nline = objc; 2943 for (k=0; k < objc; k++) {ctx.line[k] = -1;} 2944 } 2945 } 2946#endif 2947 2948 for (j = i + 1; ; j += 2) { 2949 if (j >= objc) { 2950 /* 2951 * This shouldn't happen since we've checked that the 2952 * last body is not a continuation... 2953 */ 2954 panic("fall-out when searching for body to match pattern"); 2955 } 2956 if (strcmp(Tcl_GetString(objv[j]), "-") != 0) { 2957 break; 2958 } 2959 } 2960#ifndef TCL_TIP280 2961 result = Tcl_EvalObjEx(interp, objv[j], 0); 2962#else 2963 /* TIP #280. Make invoking context available to switch branch */ 2964 result = TclEvalObjEx(interp, objv[j], 0, &ctx, splitObjs ? j : bidx+j); 2965 if (splitObjs) { 2966 ckfree ((char*) ctx.line); 2967 if (pc && (ctx.type == TCL_LOCATION_SOURCE)) { 2968 /* Death of SrcInfo reference */ 2969 Tcl_DecrRefCount (ctx.data.eval.path); 2970 } 2971 } 2972#endif 2973 if (result == TCL_ERROR) { 2974 char msg[100 + TCL_INTEGER_SPACE]; 2975 2976 sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern, 2977 interp->errorLine); 2978 Tcl_AddObjErrorInfo(interp, msg, -1); 2979 } 2980 return result; 2981 } 2982 return TCL_OK; 2983} 2984 2985/* 2986 *---------------------------------------------------------------------- 2987 * 2988 * Tcl_TimeObjCmd -- 2989 * 2990 * This object-based procedure is invoked to process the "time" Tcl 2991 * command. See the user documentation for details on what it does. 2992 * 2993 * Results: 2994 * A standard Tcl object result. 2995 * 2996 * Side effects: 2997 * See the user documentation. 2998 * 2999 *---------------------------------------------------------------------- 3000 */ 3001 3002 /* ARGSUSED */ 3003int 3004Tcl_TimeObjCmd(dummy, interp, objc, objv) 3005 ClientData dummy; /* Not used. */ 3006 Tcl_Interp *interp; /* Current interpreter. */ 3007 int objc; /* Number of arguments. */ 3008 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3009{ 3010 register Tcl_Obj *objPtr; 3011 Tcl_Obj *objs[4]; 3012 register int i, result; 3013 int count; 3014 double totalMicroSec; 3015 Tcl_Time start, stop; 3016 3017 if (objc == 2) { 3018 count = 1; 3019 } else if (objc == 3) { 3020 result = Tcl_GetIntFromObj(interp, objv[2], &count); 3021 if (result != TCL_OK) { 3022 return result; 3023 } 3024 } else { 3025 Tcl_WrongNumArgs(interp, 1, objv, "command ?count?"); 3026 return TCL_ERROR; 3027 } 3028 3029 objPtr = objv[1]; 3030 i = count; 3031 Tcl_GetTime(&start); 3032 while (i-- > 0) { 3033 result = Tcl_EvalObjEx(interp, objPtr, 0); 3034 if (result != TCL_OK) { 3035 return result; 3036 } 3037 } 3038 Tcl_GetTime(&stop); 3039 3040 totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6 3041 + ( stop.usec - start.usec ) ); 3042 if (count <= 1) { 3043 /* Use int obj since we know time is not fractional [Bug 1202178] */ 3044 objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec); 3045 } else { 3046 objs[0] = Tcl_NewDoubleObj(totalMicroSec/count); 3047 } 3048 objs[1] = Tcl_NewStringObj("microseconds", -1); 3049 objs[2] = Tcl_NewStringObj("per", -1); 3050 objs[3] = Tcl_NewStringObj("iteration", -1); 3051 Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs)); 3052 return TCL_OK; 3053} 3054 3055/* 3056 *---------------------------------------------------------------------- 3057 * 3058 * Tcl_TraceObjCmd -- 3059 * 3060 * This procedure is invoked to process the "trace" Tcl command. 3061 * See the user documentation for details on what it does. 3062 * 3063 * Standard syntax as of Tcl 8.4 is 3064 * 3065 * trace {add|info|remove} {command|variable} name ops cmd 3066 * 3067 * 3068 * Results: 3069 * A standard Tcl result. 3070 * 3071 * Side effects: 3072 * See the user documentation. 3073 *---------------------------------------------------------------------- 3074 */ 3075 3076 /* ARGSUSED */ 3077int 3078Tcl_TraceObjCmd(dummy, interp, objc, objv) 3079 ClientData dummy; /* Not used. */ 3080 Tcl_Interp *interp; /* Current interpreter. */ 3081 int objc; /* Number of arguments. */ 3082 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3083{ 3084 int optionIndex; 3085 char *name, *flagOps, *p; 3086 /* Main sub commands to 'trace' */ 3087 static CONST char *traceOptions[] = { 3088 "add", "info", "remove", 3089#ifndef TCL_REMOVE_OBSOLETE_TRACES 3090 "variable", "vdelete", "vinfo", 3091#endif 3092 (char *) NULL 3093 }; 3094 /* 'OLD' options are pre-Tcl-8.4 style */ 3095 enum traceOptions { 3096 TRACE_ADD, TRACE_INFO, TRACE_REMOVE, 3097#ifndef TCL_REMOVE_OBSOLETE_TRACES 3098 TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO 3099#endif 3100 }; 3101 3102 if (objc < 2) { 3103 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); 3104 return TCL_ERROR; 3105 } 3106 3107 if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, 3108 "option", 0, &optionIndex) != TCL_OK) { 3109 return TCL_ERROR; 3110 } 3111 switch ((enum traceOptions) optionIndex) { 3112 case TRACE_ADD: 3113 case TRACE_REMOVE: 3114 case TRACE_INFO: { 3115 /* 3116 * All sub commands of trace add/remove must take at least 3117 * one more argument. Beyond that we let the subcommand itself 3118 * control the argument structure. 3119 */ 3120 int typeIndex; 3121 if (objc < 3) { 3122 Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?"); 3123 return TCL_ERROR; 3124 } 3125 if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, 3126 "option", 0, &typeIndex) != TCL_OK) { 3127 return TCL_ERROR; 3128 } 3129 return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); 3130 } 3131#ifndef TCL_REMOVE_OBSOLETE_TRACES 3132 case TRACE_OLD_VARIABLE: 3133 case TRACE_OLD_VDELETE: { 3134 Tcl_Obj *copyObjv[6]; 3135 Tcl_Obj *opsList; 3136 int code, numFlags; 3137 3138 if (objc != 5) { 3139 Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); 3140 return TCL_ERROR; 3141 } 3142 3143 opsList = Tcl_NewObj(); 3144 Tcl_IncrRefCount(opsList); 3145 flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); 3146 if (numFlags == 0) { 3147 Tcl_DecrRefCount(opsList); 3148 goto badVarOps; 3149 } 3150 for (p = flagOps; *p != 0; p++) { 3151 if (*p == 'r') { 3152 Tcl_ListObjAppendElement(NULL, opsList, 3153 Tcl_NewStringObj("read", -1)); 3154 } else if (*p == 'w') { 3155 Tcl_ListObjAppendElement(NULL, opsList, 3156 Tcl_NewStringObj("write", -1)); 3157 } else if (*p == 'u') { 3158 Tcl_ListObjAppendElement(NULL, opsList, 3159 Tcl_NewStringObj("unset", -1)); 3160 } else if (*p == 'a') { 3161 Tcl_ListObjAppendElement(NULL, opsList, 3162 Tcl_NewStringObj("array", -1)); 3163 } else { 3164 Tcl_DecrRefCount(opsList); 3165 goto badVarOps; 3166 } 3167 } 3168 copyObjv[0] = NULL; 3169 memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *)); 3170 copyObjv[4] = opsList; 3171 if (optionIndex == TRACE_OLD_VARIABLE) { 3172 code = (traceSubCmds[2])(interp,TRACE_ADD,objc+1,copyObjv); 3173 } else { 3174 code = (traceSubCmds[2])(interp,TRACE_REMOVE,objc+1,copyObjv); 3175 } 3176 Tcl_DecrRefCount(opsList); 3177 return code; 3178 } 3179 case TRACE_OLD_VINFO: { 3180 ClientData clientData; 3181 char ops[5]; 3182 Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; 3183 3184 if (objc != 3) { 3185 Tcl_WrongNumArgs(interp, 2, objv, "name"); 3186 return TCL_ERROR; 3187 } 3188 resultListPtr = Tcl_GetObjResult(interp); 3189 clientData = 0; 3190 name = Tcl_GetString(objv[2]); 3191 while ((clientData = Tcl_VarTraceInfo(interp, name, 0, 3192 TraceVarProc, clientData)) != 0) { 3193 3194 TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; 3195 3196 pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 3197 p = ops; 3198 if (tvarPtr->flags & TCL_TRACE_READS) { 3199 *p = 'r'; 3200 p++; 3201 } 3202 if (tvarPtr->flags & TCL_TRACE_WRITES) { 3203 *p = 'w'; 3204 p++; 3205 } 3206 if (tvarPtr->flags & TCL_TRACE_UNSETS) { 3207 *p = 'u'; 3208 p++; 3209 } 3210 if (tvarPtr->flags & TCL_TRACE_ARRAY) { 3211 *p = 'a'; 3212 p++; 3213 } 3214 *p = '\0'; 3215 3216 /* 3217 * Build a pair (2-item list) with the ops string as 3218 * the first obj element and the tvarPtr->command string 3219 * as the second obj element. Append the pair (as an 3220 * element) to the end of the result object list. 3221 */ 3222 3223 elemObjPtr = Tcl_NewStringObj(ops, -1); 3224 Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); 3225 elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); 3226 Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); 3227 Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr); 3228 } 3229 Tcl_SetObjResult(interp, resultListPtr); 3230 break; 3231 } 3232#endif /* TCL_REMOVE_OBSOLETE_TRACES */ 3233 } 3234 return TCL_OK; 3235 3236 badVarOps: 3237 Tcl_AppendResult(interp, "bad operations \"", flagOps, 3238 "\": should be one or more of rwua", (char *) NULL); 3239 return TCL_ERROR; 3240} 3241 3242 3243/* 3244 *---------------------------------------------------------------------- 3245 * 3246 * TclTraceExecutionObjCmd -- 3247 * 3248 * Helper function for Tcl_TraceObjCmd; implements the 3249 * [trace {add|remove|info} execution ...] subcommands. 3250 * See the user documentation for details on what these do. 3251 * 3252 * Results: 3253 * Standard Tcl result. 3254 * 3255 * Side effects: 3256 * Depends on the operation (add, remove, or info) being performed; 3257 * may add or remove command traces on a command. 3258 * 3259 *---------------------------------------------------------------------- 3260 */ 3261 3262int 3263TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) 3264 Tcl_Interp *interp; /* Current interpreter. */ 3265 int optionIndex; /* Add, info or remove */ 3266 int objc; /* Number of arguments. */ 3267 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3268{ 3269 int commandLength, index; 3270 char *name, *command; 3271 size_t length; 3272 enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; 3273 static CONST char *opStrings[] = { "enter", "leave", 3274 "enterstep", "leavestep", (char *) NULL }; 3275 enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE, 3276 TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP }; 3277 3278 switch ((enum traceOptions) optionIndex) { 3279 case TRACE_ADD: 3280 case TRACE_REMOVE: { 3281 int flags = 0; 3282 int i, listLen, result; 3283 Tcl_Obj **elemPtrs; 3284 if (objc != 6) { 3285 Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); 3286 return TCL_ERROR; 3287 } 3288 /* 3289 * Make sure the ops argument is a list object; get its length and 3290 * a pointer to its array of element pointers. 3291 */ 3292 3293 result = Tcl_ListObjGetElements(interp, objv[4], &listLen, 3294 &elemPtrs); 3295 if (result != TCL_OK) { 3296 return result; 3297 } 3298 if (listLen == 0) { 3299 Tcl_SetResult(interp, "bad operation list \"\": must be " 3300 "one or more of enter, leave, enterstep, or leavestep", 3301 TCL_STATIC); 3302 return TCL_ERROR; 3303 } 3304 for (i = 0; i < listLen; i++) { 3305 if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, 3306 "operation", TCL_EXACT, &index) != TCL_OK) { 3307 return TCL_ERROR; 3308 } 3309 switch ((enum operations) index) { 3310 case TRACE_EXEC_ENTER: 3311 flags |= TCL_TRACE_ENTER_EXEC; 3312 break; 3313 case TRACE_EXEC_LEAVE: 3314 flags |= TCL_TRACE_LEAVE_EXEC; 3315 break; 3316 case TRACE_EXEC_ENTER_STEP: 3317 flags |= TCL_TRACE_ENTER_DURING_EXEC; 3318 break; 3319 case TRACE_EXEC_LEAVE_STEP: 3320 flags |= TCL_TRACE_LEAVE_DURING_EXEC; 3321 break; 3322 } 3323 } 3324 command = Tcl_GetStringFromObj(objv[5], &commandLength); 3325 length = (size_t) commandLength; 3326 if ((enum traceOptions) optionIndex == TRACE_ADD) { 3327 TraceCommandInfo *tcmdPtr; 3328 tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) 3329 (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) 3330 + length + 1)); 3331 tcmdPtr->flags = flags; 3332 tcmdPtr->stepTrace = NULL; 3333 tcmdPtr->startLevel = 0; 3334 tcmdPtr->startCmd = NULL; 3335 tcmdPtr->length = length; 3336 tcmdPtr->refCount = 1; 3337 flags |= TCL_TRACE_DELETE; 3338 if (flags & (TCL_TRACE_ENTER_DURING_EXEC | 3339 TCL_TRACE_LEAVE_DURING_EXEC)) { 3340 flags |= (TCL_TRACE_ENTER_EXEC | 3341 TCL_TRACE_LEAVE_EXEC); 3342 } 3343 strcpy(tcmdPtr->command, command); 3344 name = Tcl_GetString(objv[3]); 3345 if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, 3346 (ClientData) tcmdPtr) != TCL_OK) { 3347 ckfree((char *) tcmdPtr); 3348 return TCL_ERROR; 3349 } 3350 } else { 3351 /* 3352 * Search through all of our traces on this command to 3353 * see if there's one with the given command. If so, then 3354 * delete the first one that matches. 3355 */ 3356 3357 TraceCommandInfo *tcmdPtr; 3358 ClientData clientData = NULL; 3359 name = Tcl_GetString(objv[3]); 3360 3361 /* First ensure the name given is valid */ 3362 if (Tcl_FindCommand(interp, name, NULL, 3363 TCL_LEAVE_ERR_MSG) == NULL) { 3364 return TCL_ERROR; 3365 } 3366 3367 while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, 3368 TraceCommandProc, clientData)) != NULL) { 3369 tcmdPtr = (TraceCommandInfo *) clientData; 3370 /* 3371 * In checking the 'flags' field we must remove any 3372 * extraneous flags which may have been temporarily 3373 * added by various pieces of the trace mechanism. 3374 */ 3375 if ((tcmdPtr->length == length) 3376 && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | 3377 TCL_TRACE_RENAME | 3378 TCL_TRACE_DELETE)) == flags) 3379 && (strncmp(command, tcmdPtr->command, 3380 (size_t) length) == 0)) { 3381 flags |= TCL_TRACE_DELETE; 3382 if (flags & (TCL_TRACE_ENTER_DURING_EXEC | 3383 TCL_TRACE_LEAVE_DURING_EXEC)) { 3384 flags |= (TCL_TRACE_ENTER_EXEC | 3385 TCL_TRACE_LEAVE_EXEC); 3386 } 3387 Tcl_UntraceCommand(interp, name, 3388 flags, TraceCommandProc, clientData); 3389 if (tcmdPtr->stepTrace != NULL) { 3390 /* 3391 * We need to remove the interpreter-wide trace 3392 * which we created to allow 'step' traces. 3393 */ 3394 Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); 3395 tcmdPtr->stepTrace = NULL; 3396 if (tcmdPtr->startCmd != NULL) { 3397 ckfree((char *)tcmdPtr->startCmd); 3398 } 3399 } 3400 if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { 3401 /* Postpone deletion */ 3402 tcmdPtr->flags = 0; 3403 } 3404 tcmdPtr->refCount--; 3405 if (tcmdPtr->refCount < 0) { 3406 Tcl_Panic("TclTraceExecutionObjCmd: negative TraceCommandInfo refCount"); 3407 } 3408 if (tcmdPtr->refCount == 0) { 3409 ckfree((char*)tcmdPtr); 3410 } 3411 break; 3412 } 3413 } 3414 } 3415 break; 3416 } 3417 case TRACE_INFO: { 3418 ClientData clientData; 3419 Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; 3420 if (objc != 4) { 3421 Tcl_WrongNumArgs(interp, 3, objv, "name"); 3422 return TCL_ERROR; 3423 } 3424 3425 clientData = NULL; 3426 name = Tcl_GetString(objv[3]); 3427 3428 /* First ensure the name given is valid */ 3429 if (Tcl_FindCommand(interp, name, NULL, 3430 TCL_LEAVE_ERR_MSG) == NULL) { 3431 return TCL_ERROR; 3432 } 3433 3434 resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 3435 while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, 3436 TraceCommandProc, clientData)) != NULL) { 3437 int numOps = 0; 3438 3439 TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; 3440 3441 /* 3442 * Build a list with the ops list as the first obj 3443 * element and the tcmdPtr->command string as the 3444 * second obj element. Append this list (as an 3445 * element) to the end of the result object list. 3446 */ 3447 3448 elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 3449 Tcl_IncrRefCount(elemObjPtr); 3450 if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) { 3451 Tcl_ListObjAppendElement(NULL, elemObjPtr, 3452 Tcl_NewStringObj("enter",5)); 3453 } 3454 if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) { 3455 Tcl_ListObjAppendElement(NULL, elemObjPtr, 3456 Tcl_NewStringObj("leave",5)); 3457 } 3458 if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) { 3459 Tcl_ListObjAppendElement(NULL, elemObjPtr, 3460 Tcl_NewStringObj("enterstep",9)); 3461 } 3462 if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) { 3463 Tcl_ListObjAppendElement(NULL, elemObjPtr, 3464 Tcl_NewStringObj("leavestep",9)); 3465 } 3466 Tcl_ListObjLength(NULL, elemObjPtr, &numOps); 3467 if (0 == numOps) { 3468 Tcl_DecrRefCount(elemObjPtr); 3469 continue; 3470 } 3471 eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 3472 Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); 3473 Tcl_DecrRefCount(elemObjPtr); 3474 elemObjPtr = NULL; 3475 3476 Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, 3477 Tcl_NewStringObj(tcmdPtr->command, -1)); 3478 Tcl_ListObjAppendElement(interp, resultListPtr, 3479 eachTraceObjPtr); 3480 } 3481 Tcl_SetObjResult(interp, resultListPtr); 3482 break; 3483 } 3484 } 3485 return TCL_OK; 3486} 3487 3488 3489/* 3490 *---------------------------------------------------------------------- 3491 * 3492 * TclTraceCommandObjCmd -- 3493 * 3494 * Helper function for Tcl_TraceObjCmd; implements the 3495 * [trace {add|info|remove} command ...] subcommands. 3496 * See the user documentation for details on what these do. 3497 * 3498 * Results: 3499 * Standard Tcl result. 3500 * 3501 * Side effects: 3502 * Depends on the operation (add, remove, or info) being performed; 3503 * may add or remove command traces on a command. 3504 * 3505 *---------------------------------------------------------------------- 3506 */ 3507 3508int 3509TclTraceCommandObjCmd(interp, optionIndex, objc, objv) 3510 Tcl_Interp *interp; /* Current interpreter. */ 3511 int optionIndex; /* Add, info or remove */ 3512 int objc; /* Number of arguments. */ 3513 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3514{ 3515 int commandLength, index; 3516 char *name, *command; 3517 size_t length; 3518 enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; 3519 static CONST char *opStrings[] = { "delete", "rename", (char *) NULL }; 3520 enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; 3521 3522 switch ((enum traceOptions) optionIndex) { 3523 case TRACE_ADD: 3524 case TRACE_REMOVE: { 3525 int flags = 0; 3526 int i, listLen, result; 3527 Tcl_Obj **elemPtrs; 3528 if (objc != 6) { 3529 Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); 3530 return TCL_ERROR; 3531 } 3532 /* 3533 * Make sure the ops argument is a list object; get its length and 3534 * a pointer to its array of element pointers. 3535 */ 3536 3537 result = Tcl_ListObjGetElements(interp, objv[4], &listLen, 3538 &elemPtrs); 3539 if (result != TCL_OK) { 3540 return result; 3541 } 3542 if (listLen == 0) { 3543 Tcl_SetResult(interp, "bad operation list \"\": must be " 3544 "one or more of delete or rename", TCL_STATIC); 3545 return TCL_ERROR; 3546 } 3547 for (i = 0; i < listLen; i++) { 3548 if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, 3549 "operation", TCL_EXACT, &index) != TCL_OK) { 3550 return TCL_ERROR; 3551 } 3552 switch ((enum operations) index) { 3553 case TRACE_CMD_RENAME: 3554 flags |= TCL_TRACE_RENAME; 3555 break; 3556 case TRACE_CMD_DELETE: 3557 flags |= TCL_TRACE_DELETE; 3558 break; 3559 } 3560 } 3561 command = Tcl_GetStringFromObj(objv[5], &commandLength); 3562 length = (size_t) commandLength; 3563 if ((enum traceOptions) optionIndex == TRACE_ADD) { 3564 TraceCommandInfo *tcmdPtr; 3565 tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) 3566 (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) 3567 + length + 1)); 3568 tcmdPtr->flags = flags; 3569 tcmdPtr->stepTrace = NULL; 3570 tcmdPtr->startLevel = 0; 3571 tcmdPtr->startCmd = NULL; 3572 tcmdPtr->length = length; 3573 tcmdPtr->refCount = 1; 3574 flags |= TCL_TRACE_DELETE; 3575 strcpy(tcmdPtr->command, command); 3576 name = Tcl_GetString(objv[3]); 3577 if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, 3578 (ClientData) tcmdPtr) != TCL_OK) { 3579 ckfree((char *) tcmdPtr); 3580 return TCL_ERROR; 3581 } 3582 } else { 3583 /* 3584 * Search through all of our traces on this command to 3585 * see if there's one with the given command. If so, then 3586 * delete the first one that matches. 3587 */ 3588 3589 TraceCommandInfo *tcmdPtr; 3590 ClientData clientData = NULL; 3591 name = Tcl_GetString(objv[3]); 3592 3593 /* First ensure the name given is valid */ 3594 if (Tcl_FindCommand(interp, name, NULL, 3595 TCL_LEAVE_ERR_MSG) == NULL) { 3596 return TCL_ERROR; 3597 } 3598 3599 while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, 3600 TraceCommandProc, clientData)) != NULL) { 3601 tcmdPtr = (TraceCommandInfo *) clientData; 3602 if ((tcmdPtr->length == length) 3603 && (tcmdPtr->flags == flags) 3604 && (strncmp(command, tcmdPtr->command, 3605 (size_t) length) == 0)) { 3606 Tcl_UntraceCommand(interp, name, 3607 flags | TCL_TRACE_DELETE, 3608 TraceCommandProc, clientData); 3609 tcmdPtr->flags |= TCL_TRACE_DESTROYED; 3610 tcmdPtr->refCount--; 3611 if (tcmdPtr->refCount < 0) { 3612 Tcl_Panic("TclTraceCommandObjCmd: negative TraceCommandInfo refCount"); 3613 } 3614 if (tcmdPtr->refCount == 0) { 3615 ckfree((char *) tcmdPtr); 3616 } 3617 break; 3618 } 3619 } 3620 } 3621 break; 3622 } 3623 case TRACE_INFO: { 3624 ClientData clientData; 3625 Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; 3626 if (objc != 4) { 3627 Tcl_WrongNumArgs(interp, 3, objv, "name"); 3628 return TCL_ERROR; 3629 } 3630 3631 clientData = NULL; 3632 name = Tcl_GetString(objv[3]); 3633 3634 /* First ensure the name given is valid */ 3635 if (Tcl_FindCommand(interp, name, NULL, 3636 TCL_LEAVE_ERR_MSG) == NULL) { 3637 return TCL_ERROR; 3638 } 3639 3640 resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 3641 while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, 3642 TraceCommandProc, clientData)) != NULL) { 3643 int numOps = 0; 3644 3645 TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; 3646 3647 /* 3648 * Build a list with the ops list as 3649 * the first obj element and the tcmdPtr->command string 3650 * as the second obj element. Append this list (as an 3651 * element) to the end of the result object list. 3652 */ 3653 3654 elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 3655 Tcl_IncrRefCount(elemObjPtr); 3656 if (tcmdPtr->flags & TCL_TRACE_RENAME) { 3657 Tcl_ListObjAppendElement(NULL, elemObjPtr, 3658 Tcl_NewStringObj("rename",6)); 3659 } 3660 if (tcmdPtr->flags & TCL_TRACE_DELETE) { 3661 Tcl_ListObjAppendElement(NULL, elemObjPtr, 3662 Tcl_NewStringObj("delete",6)); 3663 } 3664 Tcl_ListObjLength(NULL, elemObjPtr, &numOps); 3665 if (0 == numOps) { 3666 Tcl_DecrRefCount(elemObjPtr); 3667 continue; 3668 } 3669 eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 3670 Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); 3671 Tcl_DecrRefCount(elemObjPtr); 3672 3673 elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); 3674 Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); 3675 Tcl_ListObjAppendElement(interp, resultListPtr, 3676 eachTraceObjPtr); 3677 } 3678 Tcl_SetObjResult(interp, resultListPtr); 3679 break; 3680 } 3681 } 3682 return TCL_OK; 3683} 3684 3685 3686/* 3687 *---------------------------------------------------------------------- 3688 * 3689 * TclTraceVariableObjCmd -- 3690 * 3691 * Helper function for Tcl_TraceObjCmd; implements the 3692 * [trace {add|info|remove} variable ...] subcommands. 3693 * See the user documentation for details on what these do. 3694 * 3695 * Results: 3696 * Standard Tcl result. 3697 * 3698 * Side effects: 3699 * Depends on the operation (add, remove, or info) being performed; 3700 * may add or remove variable traces on a variable. 3701 * 3702 *---------------------------------------------------------------------- 3703 */ 3704 3705int 3706TclTraceVariableObjCmd(interp, optionIndex, objc, objv) 3707 Tcl_Interp *interp; /* Current interpreter. */ 3708 int optionIndex; /* Add, info or remove */ 3709 int objc; /* Number of arguments. */ 3710 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3711{ 3712 int commandLength, index; 3713 char *name, *command; 3714 size_t length; 3715 enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; 3716 static CONST char *opStrings[] = { "array", "read", "unset", "write", 3717 (char *) NULL }; 3718 enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, 3719 TRACE_VAR_WRITE }; 3720 3721 switch ((enum traceOptions) optionIndex) { 3722 case TRACE_ADD: 3723 case TRACE_REMOVE: { 3724 int flags = 0; 3725 int i, listLen, result; 3726 Tcl_Obj **elemPtrs; 3727 if (objc != 6) { 3728 Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); 3729 return TCL_ERROR; 3730 } 3731 /* 3732 * Make sure the ops argument is a list object; get its length and 3733 * a pointer to its array of element pointers. 3734 */ 3735 3736 result = Tcl_ListObjGetElements(interp, objv[4], &listLen, 3737 &elemPtrs); 3738 if (result != TCL_OK) { 3739 return result; 3740 } 3741 if (listLen == 0) { 3742 Tcl_SetResult(interp, "bad operation list \"\": must be " 3743 "one or more of array, read, unset, or write", 3744 TCL_STATIC); 3745 return TCL_ERROR; 3746 } 3747 for (i = 0; i < listLen ; i++) { 3748 if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, 3749 "operation", TCL_EXACT, &index) != TCL_OK) { 3750 return TCL_ERROR; 3751 } 3752 switch ((enum operations) index) { 3753 case TRACE_VAR_ARRAY: 3754 flags |= TCL_TRACE_ARRAY; 3755 break; 3756 case TRACE_VAR_READ: 3757 flags |= TCL_TRACE_READS; 3758 break; 3759 case TRACE_VAR_UNSET: 3760 flags |= TCL_TRACE_UNSETS; 3761 break; 3762 case TRACE_VAR_WRITE: 3763 flags |= TCL_TRACE_WRITES; 3764 break; 3765 } 3766 } 3767 command = Tcl_GetStringFromObj(objv[5], &commandLength); 3768 length = (size_t) commandLength; 3769 if ((enum traceOptions) optionIndex == TRACE_ADD) { 3770 /* 3771 * This code essentially mallocs together the VarTrace and the 3772 * TraceVarInfo, then inlines the Tcl_TraceVar(). This is 3773 * necessary in order to have the TraceVarInfo to be freed 3774 * automatically when the VarTrace is freed [Bug 1348775] 3775 */ 3776 3777 CompoundVarTrace *compTracePtr; 3778 TraceVarInfo *tvarPtr; 3779 Var *varPtr, *arrayPtr; 3780 VarTrace *tracePtr; 3781 int flagMask; 3782 3783 compTracePtr = (CompoundVarTrace *) ckalloc((unsigned) 3784 (sizeof(CompoundVarTrace) - sizeof(tvarPtr->command) 3785 + length + 1)); 3786 tracePtr = &(compTracePtr->trace); 3787 tvarPtr = &(compTracePtr->tvar); 3788 tvarPtr->flags = flags; 3789 if (objv[0] == NULL) { 3790 tvarPtr->flags |= TCL_TRACE_OLD_STYLE; 3791 } 3792 tvarPtr->length = length; 3793 flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; 3794 strcpy(tvarPtr->command, command); 3795 name = Tcl_GetString(objv[3]); 3796 flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; 3797 varPtr = TclLookupVar(interp, name, NULL, 3798 (flags & flagMask) | TCL_LEAVE_ERR_MSG, "trace", 3799 /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); 3800 if (varPtr == NULL) { 3801 ckfree((char *) tracePtr); 3802 return TCL_ERROR; 3803 } 3804 flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES 3805 | TCL_TRACE_UNSETS | TCL_TRACE_ARRAY 3806 | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; 3807#ifndef TCL_REMOVE_OBSOLETE_TRACES 3808 flagMask |= TCL_TRACE_OLD_STYLE; 3809#endif 3810 tracePtr->traceProc = TraceVarProc; 3811 tracePtr->clientData = (ClientData) tvarPtr; 3812 tracePtr->flags = flags & flagMask; 3813 tracePtr->nextPtr = varPtr->tracePtr; 3814 varPtr->tracePtr = tracePtr; 3815 } else { 3816 /* 3817 * Search through all of our traces on this variable to 3818 * see if there's one with the given command. If so, then 3819 * delete the first one that matches. 3820 */ 3821 3822 TraceVarInfo *tvarPtr; 3823 ClientData clientData = 0; 3824 name = Tcl_GetString(objv[3]); 3825 while ((clientData = Tcl_VarTraceInfo(interp, name, 0, 3826 TraceVarProc, clientData)) != 0) { 3827 tvarPtr = (TraceVarInfo *) clientData; 3828 if ((tvarPtr->length == length) 3829 && ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags) 3830 && (strncmp(command, tvarPtr->command, 3831 (size_t) length) == 0)) { 3832 Tcl_UntraceVar2(interp, name, NULL, 3833 flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, 3834 TraceVarProc, clientData); 3835 break; 3836 } 3837 } 3838 } 3839 break; 3840 } 3841 case TRACE_INFO: { 3842 ClientData clientData; 3843 Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; 3844 if (objc != 4) { 3845 Tcl_WrongNumArgs(interp, 3, objv, "name"); 3846 return TCL_ERROR; 3847 } 3848 3849 resultListPtr = Tcl_GetObjResult(interp); 3850 clientData = 0; 3851 name = Tcl_GetString(objv[3]); 3852 while ((clientData = Tcl_VarTraceInfo(interp, name, 0, 3853 TraceVarProc, clientData)) != 0) { 3854 3855 TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; 3856 3857 /* 3858 * Build a list with the ops list as 3859 * the first obj element and the tcmdPtr->command string 3860 * as the second obj element. Append this list (as an 3861 * element) to the end of the result object list. 3862 */ 3863 3864 elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 3865 if (tvarPtr->flags & TCL_TRACE_ARRAY) { 3866 Tcl_ListObjAppendElement(NULL, elemObjPtr, 3867 Tcl_NewStringObj("array", 5)); 3868 } 3869 if (tvarPtr->flags & TCL_TRACE_READS) { 3870 Tcl_ListObjAppendElement(NULL, elemObjPtr, 3871 Tcl_NewStringObj("read", 4)); 3872 } 3873 if (tvarPtr->flags & TCL_TRACE_WRITES) { 3874 Tcl_ListObjAppendElement(NULL, elemObjPtr, 3875 Tcl_NewStringObj("write", 5)); 3876 } 3877 if (tvarPtr->flags & TCL_TRACE_UNSETS) { 3878 Tcl_ListObjAppendElement(NULL, elemObjPtr, 3879 Tcl_NewStringObj("unset", 5)); 3880 } 3881 eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 3882 Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); 3883 3884 elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); 3885 Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); 3886 Tcl_ListObjAppendElement(interp, resultListPtr, 3887 eachTraceObjPtr); 3888 } 3889 Tcl_SetObjResult(interp, resultListPtr); 3890 break; 3891 } 3892 } 3893 return TCL_OK; 3894} 3895 3896 3897/* 3898 *---------------------------------------------------------------------- 3899 * 3900 * Tcl_CommandTraceInfo -- 3901 * 3902 * Return the clientData value associated with a trace on a 3903 * command. This procedure can also be used to step through 3904 * all of the traces on a particular command that have the 3905 * same trace procedure. 3906 * 3907 * Results: 3908 * The return value is the clientData value associated with 3909 * a trace on the given command. Information will only be 3910 * returned for a trace with proc as trace procedure. If 3911 * the clientData argument is NULL then the first such trace is 3912 * returned; otherwise, the next relevant one after the one 3913 * given by clientData will be returned. If the command 3914 * doesn't exist then an error message is left in the interpreter 3915 * and NULL is returned. Also, if there are no (more) traces for 3916 * the given command, NULL is returned. 3917 * 3918 * Side effects: 3919 * None. 3920 * 3921 *---------------------------------------------------------------------- 3922 */ 3923 3924ClientData 3925Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData) 3926 Tcl_Interp *interp; /* Interpreter containing command. */ 3927 CONST char *cmdName; /* Name of command. */ 3928 int flags; /* OR-ed combo or TCL_GLOBAL_ONLY, 3929 * TCL_NAMESPACE_ONLY (can be 0). */ 3930 Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ 3931 ClientData prevClientData; /* If non-NULL, gives last value returned 3932 * by this procedure, so this call will 3933 * return the next trace after that one. 3934 * If NULL, this call will return the 3935 * first trace. */ 3936{ 3937 Command *cmdPtr; 3938 register CommandTrace *tracePtr; 3939 3940 cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, 3941 NULL, TCL_LEAVE_ERR_MSG); 3942 if (cmdPtr == NULL) { 3943 return NULL; 3944 } 3945 3946 /* 3947 * Find the relevant trace, if any, and return its clientData. 3948 */ 3949 3950 tracePtr = cmdPtr->tracePtr; 3951 if (prevClientData != NULL) { 3952 for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { 3953 if ((tracePtr->clientData == prevClientData) 3954 && (tracePtr->traceProc == proc)) { 3955 tracePtr = tracePtr->nextPtr; 3956 break; 3957 } 3958 } 3959 } 3960 for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { 3961 if (tracePtr->traceProc == proc) { 3962 return tracePtr->clientData; 3963 } 3964 } 3965 return NULL; 3966} 3967 3968/* 3969 *---------------------------------------------------------------------- 3970 * 3971 * Tcl_TraceCommand -- 3972 * 3973 * Arrange for rename/deletes to a command to cause a 3974 * procedure to be invoked, which can monitor the operations. 3975 * 3976 * Also optionally arrange for execution of that command 3977 * to cause a procedure to be invoked. 3978 * 3979 * Results: 3980 * A standard Tcl return value. 3981 * 3982 * Side effects: 3983 * A trace is set up on the command given by cmdName, such that 3984 * future changes to the command will be intermediated by 3985 * proc. See the manual entry for complete details on the calling 3986 * sequence for proc. 3987 * 3988 *---------------------------------------------------------------------- 3989 */ 3990 3991int 3992Tcl_TraceCommand(interp, cmdName, flags, proc, clientData) 3993 Tcl_Interp *interp; /* Interpreter in which command is 3994 * to be traced. */ 3995 CONST char *cmdName; /* Name of command. */ 3996 int flags; /* OR-ed collection of bits, including any 3997 * of TCL_TRACE_RENAME, TCL_TRACE_DELETE, 3998 * and any of the TRACE_*_EXEC flags */ 3999 Tcl_CommandTraceProc *proc; /* Procedure to call when specified ops are 4000 * invoked upon varName. */ 4001 ClientData clientData; /* Arbitrary argument to pass to proc. */ 4002{ 4003 Command *cmdPtr; 4004 register CommandTrace *tracePtr; 4005 4006 cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, 4007 NULL, TCL_LEAVE_ERR_MSG); 4008 if (cmdPtr == NULL) { 4009 return TCL_ERROR; 4010 } 4011 4012 /* 4013 * Set up trace information. 4014 */ 4015 4016 tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace)); 4017 tracePtr->traceProc = proc; 4018 tracePtr->clientData = clientData; 4019 tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE 4020 | TCL_TRACE_ANY_EXEC); 4021 tracePtr->nextPtr = cmdPtr->tracePtr; 4022 tracePtr->refCount = 1; 4023 cmdPtr->tracePtr = tracePtr; 4024 if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { 4025 cmdPtr->flags |= CMD_HAS_EXEC_TRACES; 4026 } 4027 return TCL_OK; 4028} 4029 4030/* 4031 *---------------------------------------------------------------------- 4032 * 4033 * Tcl_UntraceCommand -- 4034 * 4035 * Remove a previously-created trace for a command. 4036 * 4037 * Results: 4038 * None. 4039 * 4040 * Side effects: 4041 * If there exists a trace for the command given by cmdName 4042 * with the given flags, proc, and clientData, then that trace 4043 * is removed. 4044 * 4045 *---------------------------------------------------------------------- 4046 */ 4047 4048void 4049Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) 4050 Tcl_Interp *interp; /* Interpreter containing command. */ 4051 CONST char *cmdName; /* Name of command. */ 4052 int flags; /* OR-ed collection of bits, including any 4053 * of TCL_TRACE_RENAME, TCL_TRACE_DELETE, 4054 * and any of the TRACE_*_EXEC flags */ 4055 Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ 4056 ClientData clientData; /* Arbitrary argument to pass to proc. */ 4057{ 4058 register CommandTrace *tracePtr; 4059 CommandTrace *prevPtr; 4060 Command *cmdPtr; 4061 Interp *iPtr = (Interp *) interp; 4062 ActiveCommandTrace *activePtr; 4063 int hasExecTraces = 0; 4064 4065 cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, 4066 NULL, TCL_LEAVE_ERR_MSG); 4067 if (cmdPtr == NULL) { 4068 return; 4069 } 4070 4071 flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); 4072 4073 for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ; 4074 prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { 4075 if (tracePtr == NULL) { 4076 return; 4077 } 4078 if ((tracePtr->traceProc == proc) 4079 && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | 4080 TCL_TRACE_ANY_EXEC)) == flags) 4081 && (tracePtr->clientData == clientData)) { 4082 if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { 4083 hasExecTraces = 1; 4084 } 4085 break; 4086 } 4087 } 4088 4089 /* 4090 * The code below makes it possible to delete traces while traces 4091 * are active: it makes sure that the deleted trace won't be 4092 * processed by CallCommandTraces. 4093 */ 4094 4095 for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL; 4096 activePtr = activePtr->nextPtr) { 4097 if (activePtr->nextTracePtr == tracePtr) { 4098 if (activePtr->reverseScan) { 4099 activePtr->nextTracePtr = prevPtr; 4100 } else { 4101 activePtr->nextTracePtr = tracePtr->nextPtr; 4102 } 4103 } 4104 } 4105 if (prevPtr == NULL) { 4106 cmdPtr->tracePtr = tracePtr->nextPtr; 4107 } else { 4108 prevPtr->nextPtr = tracePtr->nextPtr; 4109 } 4110 tracePtr->flags = 0; 4111 4112 if ((--tracePtr->refCount) <= 0) { 4113 ckfree((char*)tracePtr); 4114 } 4115 4116 if (hasExecTraces) { 4117 for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ; 4118 prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { 4119 if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { 4120 return; 4121 } 4122 } 4123 /* 4124 * None of the remaining traces on this command are execution 4125 * traces. We therefore remove this flag: 4126 */ 4127 cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES; 4128 } 4129} 4130 4131/* 4132 *---------------------------------------------------------------------- 4133 * 4134 * TraceCommandProc -- 4135 * 4136 * This procedure is called to handle command changes that have 4137 * been traced using the "trace" command, when using the 4138 * 'rename' or 'delete' options. 4139 * 4140 * Results: 4141 * None. 4142 * 4143 * Side effects: 4144 * Depends on the command associated with the trace. 4145 * 4146 *---------------------------------------------------------------------- 4147 */ 4148 4149 /* ARGSUSED */ 4150static void 4151TraceCommandProc(clientData, interp, oldName, newName, flags) 4152 ClientData clientData; /* Information about the command trace. */ 4153 Tcl_Interp *interp; /* Interpreter containing command. */ 4154 CONST char *oldName; /* Name of command being changed. */ 4155 CONST char *newName; /* New name of command. Empty string 4156 * or NULL means command is being deleted 4157 * (renamed to ""). */ 4158 int flags; /* OR-ed bits giving operation and other 4159 * information. */ 4160{ 4161 Interp *iPtr = (Interp *) interp; 4162 int stateCode; 4163 Tcl_SavedResult state; 4164 TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; 4165 int code; 4166 Tcl_DString cmd; 4167 4168 tcmdPtr->refCount++; 4169 4170 if ((tcmdPtr->flags & flags) && !Tcl_InterpDeleted(interp)) { 4171 /* 4172 * Generate a command to execute by appending list elements 4173 * for the old and new command name and the operation. 4174 */ 4175 4176 Tcl_DStringInit(&cmd); 4177 Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); 4178 Tcl_DStringAppendElement(&cmd, oldName); 4179 Tcl_DStringAppendElement(&cmd, (newName ? newName : "")); 4180 if (flags & TCL_TRACE_RENAME) { 4181 Tcl_DStringAppend(&cmd, " rename", 7); 4182 } else if (flags & TCL_TRACE_DELETE) { 4183 Tcl_DStringAppend(&cmd, " delete", 7); 4184 } 4185 4186 /* 4187 * Execute the command. Save the interp's result used for the 4188 * command, including the value of iPtr->returnCode which may be 4189 * modified when Tcl_Eval is invoked. We discard any object 4190 * result the command returns. 4191 * 4192 * Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to 4193 * other areas that this will be destroyed by us, otherwise a 4194 * double-free might occur depending on what the eval does. 4195 */ 4196 4197 Tcl_SaveResult(interp, &state); 4198 stateCode = iPtr->returnCode; 4199 if (flags & TCL_TRACE_DESTROYED) { 4200 tcmdPtr->flags |= TCL_TRACE_DESTROYED; 4201 } 4202 4203 code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), 4204 Tcl_DStringLength(&cmd), 0); 4205 if (code != TCL_OK) { 4206 /* We ignore errors in these traced commands */ 4207 } 4208 4209 Tcl_RestoreResult(interp, &state); 4210 iPtr->returnCode = stateCode; 4211 4212 Tcl_DStringFree(&cmd); 4213 } 4214 /* 4215 * We delete when the trace was destroyed or if this is a delete trace, 4216 * because command deletes are unconditional, so the trace must go away. 4217 */ 4218 if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) { 4219 int untraceFlags = tcmdPtr->flags; 4220 4221 if (tcmdPtr->stepTrace != NULL) { 4222 Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); 4223 tcmdPtr->stepTrace = NULL; 4224 if (tcmdPtr->startCmd != NULL) { 4225 ckfree((char *)tcmdPtr->startCmd); 4226 } 4227 } 4228 if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { 4229 /* Postpone deletion, until exec trace returns */ 4230 tcmdPtr->flags = 0; 4231 } 4232 4233 /* 4234 * We need to construct the same flags for Tcl_UntraceCommand 4235 * as were passed to Tcl_TraceCommand. Reproduce the processing 4236 * of [trace add execution/command]. Be careful to keep this 4237 * code in sync with that. 4238 */ 4239 4240 if (untraceFlags & TCL_TRACE_ANY_EXEC) { 4241 untraceFlags |= TCL_TRACE_DELETE; 4242 if (untraceFlags & (TCL_TRACE_ENTER_DURING_EXEC 4243 | TCL_TRACE_LEAVE_DURING_EXEC)) { 4244 untraceFlags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); 4245 } 4246 } else if (untraceFlags & TCL_TRACE_RENAME) { 4247 untraceFlags |= TCL_TRACE_DELETE; 4248 } 4249 4250 /* 4251 * Remove the trace since TCL_TRACE_DESTROYED tells us to, or the 4252 * command we're tracing has just gone away. Then decrement the 4253 * clientData refCount that was set up by trace creation. 4254 * 4255 * Note that we save the (return) state of the interpreter to prevent 4256 * bizarre error messages. 4257 */ 4258 4259 Tcl_SaveResult(interp, &state); 4260 stateCode = iPtr->returnCode; 4261 Tcl_UntraceCommand(interp, oldName, untraceFlags, 4262 TraceCommandProc, clientData); 4263 Tcl_RestoreResult(interp, &state); 4264 iPtr->returnCode = stateCode; 4265 4266 tcmdPtr->refCount--; 4267 } 4268 tcmdPtr->refCount--; 4269 if (tcmdPtr->refCount < 0) { 4270 Tcl_Panic("TraceCommandProc: negative TraceCommandInfo refCount"); 4271 } 4272 if (tcmdPtr->refCount == 0) { 4273 ckfree((char*)tcmdPtr); 4274 } 4275 return; 4276} 4277 4278/* 4279 *---------------------------------------------------------------------- 4280 * 4281 * TclCheckExecutionTraces -- 4282 * 4283 * Checks on all current command execution traces, and invokes 4284 * procedures which have been registered. This procedure can be 4285 * used by other code which performs execution to unify the 4286 * tracing system, so that execution traces will function for that 4287 * other code. 4288 * 4289 * For instance extensions like [incr Tcl] which use their 4290 * own execution technique can make use of Tcl's tracing. 4291 * 4292 * This procedure is called by 'TclEvalObjvInternal' 4293 * 4294 * Results: 4295 * The return value is a standard Tcl completion code such as 4296 * TCL_OK or TCL_ERROR, etc. 4297 * 4298 * Side effects: 4299 * Those side effects made by any trace procedures called. 4300 * 4301 *---------------------------------------------------------------------- 4302 */ 4303int 4304TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, 4305 traceFlags, objc, objv) 4306 Tcl_Interp *interp; /* The current interpreter. */ 4307 CONST char *command; /* Pointer to beginning of the current 4308 * command string. */ 4309 int numChars; /* The number of characters in 'command' 4310 * which are part of the command string. */ 4311 Command *cmdPtr; /* Points to command's Command struct. */ 4312 int code; /* The current result code. */ 4313 int traceFlags; /* Current tracing situation. */ 4314 int objc; /* Number of arguments for the command. */ 4315 Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ 4316{ 4317 Interp *iPtr = (Interp *) interp; 4318 CommandTrace *tracePtr, *lastTracePtr; 4319 ActiveCommandTrace active; 4320 int curLevel; 4321 int traceCode = TCL_OK; 4322 TraceCommandInfo* tcmdPtr; 4323 4324 if (command == NULL || cmdPtr->tracePtr == NULL) { 4325 return traceCode; 4326 } 4327 4328 curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level); 4329 4330 active.nextPtr = iPtr->activeCmdTracePtr; 4331 iPtr->activeCmdTracePtr = &active; 4332 4333 active.cmdPtr = cmdPtr; 4334 lastTracePtr = NULL; 4335 for (tracePtr = cmdPtr->tracePtr; 4336 (traceCode == TCL_OK) && (tracePtr != NULL); 4337 tracePtr = active.nextTracePtr) { 4338 if (traceFlags & TCL_TRACE_LEAVE_EXEC) { 4339 /* execute the trace command in order of creation for "leave" */ 4340 active.reverseScan = 1; 4341 active.nextTracePtr = NULL; 4342 tracePtr = cmdPtr->tracePtr; 4343 while (tracePtr->nextPtr != lastTracePtr) { 4344 active.nextTracePtr = tracePtr; 4345 tracePtr = tracePtr->nextPtr; 4346 } 4347 } else { 4348 active.reverseScan = 0; 4349 active.nextTracePtr = tracePtr->nextPtr; 4350 } 4351 if (tracePtr->traceProc == TraceCommandProc) { 4352 tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; 4353 if (tcmdPtr->flags != 0) { 4354 tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; 4355 tcmdPtr->curCode = code; 4356 tcmdPtr->refCount++; 4357 traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, 4358 curLevel, command, (Tcl_Command)cmdPtr, objc, objv); 4359 tcmdPtr->refCount--; 4360 if (tcmdPtr->refCount < 0) { 4361 Tcl_Panic("TclCheckExecutionTraces: negative TraceCommandInfo refCount"); 4362 } 4363 if (tcmdPtr->refCount == 0) { 4364 ckfree((char*)tcmdPtr); 4365 } 4366 } 4367 } 4368 if (active.nextTracePtr) { 4369 lastTracePtr = active.nextTracePtr->nextPtr; 4370 } 4371 } 4372 iPtr->activeCmdTracePtr = active.nextPtr; 4373 return(traceCode); 4374} 4375 4376/* 4377 *---------------------------------------------------------------------- 4378 * 4379 * TclCheckInterpTraces -- 4380 * 4381 * Checks on all current traces, and invokes procedures which 4382 * have been registered. This procedure can be used by other 4383 * code which performs execution to unify the tracing system. 4384 * For instance extensions like [incr Tcl] which use their 4385 * own execution technique can make use of Tcl's tracing. 4386 * 4387 * This procedure is called by 'TclEvalObjvInternal' 4388 * 4389 * Results: 4390 * The return value is a standard Tcl completion code such as 4391 * TCL_OK or TCL_ERROR, etc. 4392 * 4393 * Side effects: 4394 * Those side effects made by any trace procedures called. 4395 * 4396 *---------------------------------------------------------------------- 4397 */ 4398int 4399TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, 4400 traceFlags, objc, objv) 4401 Tcl_Interp *interp; /* The current interpreter. */ 4402 CONST char *command; /* Pointer to beginning of the current 4403 * command string. */ 4404 int numChars; /* The number of characters in 'command' 4405 * which are part of the command string. */ 4406 Command *cmdPtr; /* Points to command's Command struct. */ 4407 int code; /* The current result code. */ 4408 int traceFlags; /* Current tracing situation. */ 4409 int objc; /* Number of arguments for the command. */ 4410 Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ 4411{ 4412 Interp *iPtr = (Interp *) interp; 4413 Trace *tracePtr, *lastTracePtr; 4414 ActiveInterpTrace active; 4415 int curLevel; 4416 int traceCode = TCL_OK; 4417 4418 if (command == NULL || iPtr->tracePtr == NULL || 4419 (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) { 4420 return(traceCode); 4421 } 4422 4423 curLevel = iPtr->numLevels; 4424 4425 active.nextPtr = iPtr->activeInterpTracePtr; 4426 iPtr->activeInterpTracePtr = &active; 4427 4428 lastTracePtr = NULL; 4429 for ( tracePtr = iPtr->tracePtr; 4430 (traceCode == TCL_OK) && (tracePtr != NULL); 4431 tracePtr = active.nextTracePtr) { 4432 if (traceFlags & TCL_TRACE_ENTER_EXEC) { 4433 /* 4434 * Execute the trace command in reverse order of creation 4435 * for "enterstep" operation. The order is changed for 4436 * "enterstep" instead of for "leavestep" as was done in 4437 * TclCheckExecutionTraces because for step traces, 4438 * Tcl_CreateObjTrace creates one more linked list of traces 4439 * which results in one more reversal of trace invocation. 4440 */ 4441 active.reverseScan = 1; 4442 active.nextTracePtr = NULL; 4443 tracePtr = iPtr->tracePtr; 4444 while (tracePtr->nextPtr != lastTracePtr) { 4445 active.nextTracePtr = tracePtr; 4446 tracePtr = tracePtr->nextPtr; 4447 } 4448 if (active.nextTracePtr) { 4449 lastTracePtr = active.nextTracePtr->nextPtr; 4450 } 4451 } else { 4452 active.reverseScan = 0; 4453 active.nextTracePtr = tracePtr->nextPtr; 4454 } 4455 if (tracePtr->level > 0 && curLevel > tracePtr->level) { 4456 continue; 4457 } 4458 if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) { 4459 /* 4460 * The proc invoked might delete the traced command which 4461 * which might try to free tracePtr. We want to use tracePtr 4462 * until the end of this if section, so we use 4463 * Tcl_Preserve() and Tcl_Release() to be sure it is not 4464 * freed while we still need it. 4465 */ 4466 Tcl_Preserve((ClientData) tracePtr); 4467 tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; 4468 4469 if (tracePtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) { 4470 /* New style trace */ 4471 if (tracePtr->flags & traceFlags) { 4472 if (tracePtr->proc == TraceExecutionProc) { 4473 TraceCommandInfo *tcmdPtr = 4474 (TraceCommandInfo *) tracePtr->clientData; 4475 tcmdPtr->curFlags = traceFlags; 4476 tcmdPtr->curCode = code; 4477 } 4478 traceCode = (tracePtr->proc)(tracePtr->clientData, 4479 interp, curLevel, command, (Tcl_Command)cmdPtr, 4480 objc, objv); 4481 } 4482 } else { 4483 /* Old-style trace */ 4484 4485 if (traceFlags & TCL_TRACE_ENTER_EXEC) { 4486 /* 4487 * Old-style interpreter-wide traces only trigger 4488 * before the command is executed. 4489 */ 4490 traceCode = CallTraceProcedure(interp, tracePtr, cmdPtr, 4491 command, numChars, objc, objv); 4492 } 4493 } 4494 tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; 4495 Tcl_Release((ClientData) tracePtr); 4496 } 4497 } 4498 iPtr->activeInterpTracePtr = active.nextPtr; 4499 return(traceCode); 4500} 4501 4502/* 4503 *---------------------------------------------------------------------- 4504 * 4505 * CallTraceProcedure -- 4506 * 4507 * Invokes a trace procedure registered with an interpreter. These 4508 * procedures trace command execution. Currently this trace procedure 4509 * is called with the address of the string-based Tcl_CmdProc for the 4510 * command, not the Tcl_ObjCmdProc. 4511 * 4512 * Results: 4513 * None. 4514 * 4515 * Side effects: 4516 * Those side effects made by the trace procedure. 4517 * 4518 *---------------------------------------------------------------------- 4519 */ 4520 4521static int 4522CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) 4523 Tcl_Interp *interp; /* The current interpreter. */ 4524 register Trace *tracePtr; /* Describes the trace procedure to call. */ 4525 Command *cmdPtr; /* Points to command's Command struct. */ 4526 CONST char *command; /* Points to the first character of the 4527 * command's source before substitutions. */ 4528 int numChars; /* The number of characters in the 4529 * command's source. */ 4530 register int objc; /* Number of arguments for the command. */ 4531 Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ 4532{ 4533 Interp *iPtr = (Interp *) interp; 4534 char *commandCopy; 4535 int traceCode; 4536 4537 /* 4538 * Copy the command characters into a new string. 4539 */ 4540 4541 commandCopy = (char *) ckalloc((unsigned) (numChars + 1)); 4542 memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars); 4543 commandCopy[numChars] = '\0'; 4544 4545 /* 4546 * Call the trace procedure then free allocated storage. 4547 */ 4548 4549 traceCode = (tracePtr->proc)( tracePtr->clientData, (Tcl_Interp*) iPtr, 4550 iPtr->numLevels, commandCopy, 4551 (Tcl_Command) cmdPtr, objc, objv ); 4552 4553 ckfree((char *) commandCopy); 4554 return(traceCode); 4555} 4556 4557/* 4558 *---------------------------------------------------------------------- 4559 * 4560 * CommandObjTraceDeleted -- 4561 * 4562 * Ensure the trace is correctly deleted by decrementing its 4563 * refCount and only deleting if no other references exist. 4564 * 4565 * Results: 4566 * None. 4567 * 4568 * Side effects: 4569 * May release memory. 4570 * 4571 *---------------------------------------------------------------------- 4572 */ 4573static void 4574CommandObjTraceDeleted(ClientData clientData) { 4575 TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; 4576 tcmdPtr->refCount--; 4577 if (tcmdPtr->refCount < 0) { 4578 Tcl_Panic("CommandObjTraceDeleted: negative TraceCommandInfo refCount"); 4579 } 4580 if (tcmdPtr->refCount == 0) { 4581 ckfree((char*)tcmdPtr); 4582 } 4583} 4584 4585/* 4586 *---------------------------------------------------------------------- 4587 * 4588 * TraceExecutionProc -- 4589 * 4590 * This procedure is invoked whenever code relevant to a 4591 * 'trace execution' command is executed. It is called in one 4592 * of two ways in Tcl's core: 4593 * 4594 * (i) by the TclCheckExecutionTraces, when an execution trace 4595 * has been triggered. 4596 * (ii) by TclCheckInterpTraces, when a prior execution trace has 4597 * created a trace of the internals of a procedure, passing in 4598 * this procedure as the one to be called. 4599 * 4600 * Results: 4601 * The return value is a standard Tcl completion code such as 4602 * TCL_OK or TCL_ERROR, etc. 4603 * 4604 * Side effects: 4605 * May invoke an arbitrary Tcl procedure, and may create or 4606 * delete an interpreter-wide trace. 4607 * 4608 *---------------------------------------------------------------------- 4609 */ 4610static int 4611TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, 4612 int level, CONST char* command, Tcl_Command cmdInfo, 4613 int objc, struct Tcl_Obj *CONST objv[]) { 4614 int call = 0; 4615 Interp *iPtr = (Interp *) interp; 4616 TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; 4617 int flags = tcmdPtr->curFlags; 4618 int code = tcmdPtr->curCode; 4619 int traceCode = TCL_OK; 4620 4621 if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { 4622 /* 4623 * Inside any kind of execution trace callback, we do 4624 * not allow any further execution trace callbacks to 4625 * be called for the same trace. 4626 */ 4627 return traceCode; 4628 } 4629 4630 if (!Tcl_InterpDeleted(interp)) { 4631 /* 4632 * Check whether the current call is going to eval arbitrary 4633 * Tcl code with a generated trace, or whether we are only 4634 * going to setup interpreter-wide traces to implement the 4635 * 'step' traces. This latter situation can happen if 4636 * we create a command trace without either before or after 4637 * operations, but with either of the step operations. 4638 */ 4639 if (flags & TCL_TRACE_EXEC_DIRECT) { 4640 call = flags & tcmdPtr->flags 4641 & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); 4642 } else { 4643 call = 1; 4644 } 4645 /* 4646 * First, if we have returned back to the level at which we 4647 * created an interpreter trace for enterstep and/or leavestep 4648 * execution traces, we remove it here. 4649 */ 4650 if (flags & TCL_TRACE_LEAVE_EXEC) { 4651 if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel) 4652 && (strcmp(command, tcmdPtr->startCmd) == 0)) { 4653 Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); 4654 tcmdPtr->stepTrace = NULL; 4655 if (tcmdPtr->startCmd != NULL) { 4656 ckfree((char *)tcmdPtr->startCmd); 4657 } 4658 } 4659 } 4660 4661 /* 4662 * Second, create the tcl callback, if required. 4663 */ 4664 if (call) { 4665 Tcl_SavedResult state; 4666 int stateCode, i, saveInterpFlags; 4667 Tcl_DString cmd; 4668 Tcl_DString sub; 4669 4670 Tcl_DStringInit(&cmd); 4671 Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length); 4672 /* Append command with arguments */ 4673 Tcl_DStringInit(&sub); 4674 for (i = 0; i < objc; i++) { 4675 char* str; 4676 int len; 4677 str = Tcl_GetStringFromObj(objv[i],&len); 4678 Tcl_DStringAppendElement(&sub, str); 4679 } 4680 Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub)); 4681 Tcl_DStringFree(&sub); 4682 4683 if (flags & TCL_TRACE_ENTER_EXEC) { 4684 /* Append trace operation */ 4685 if (flags & TCL_TRACE_EXEC_DIRECT) { 4686 Tcl_DStringAppendElement(&cmd, "enter"); 4687 } else { 4688 Tcl_DStringAppendElement(&cmd, "enterstep"); 4689 } 4690 } else if (flags & TCL_TRACE_LEAVE_EXEC) { 4691 Tcl_Obj* resultCode; 4692 char* resultCodeStr; 4693 4694 /* Append result code */ 4695 resultCode = Tcl_NewIntObj(code); 4696 resultCodeStr = Tcl_GetString(resultCode); 4697 Tcl_DStringAppendElement(&cmd, resultCodeStr); 4698 Tcl_DecrRefCount(resultCode); 4699 4700 /* Append result string */ 4701 Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp)); 4702 /* Append trace operation */ 4703 if (flags & TCL_TRACE_EXEC_DIRECT) { 4704 Tcl_DStringAppendElement(&cmd, "leave"); 4705 } else { 4706 Tcl_DStringAppendElement(&cmd, "leavestep"); 4707 } 4708 } else { 4709 panic("TraceExecutionProc: bad flag combination"); 4710 } 4711 4712 /* 4713 * Execute the command. Save the interp's result used for 4714 * the command, including the value of iPtr->returnCode which 4715 * may be modified when Tcl_Eval is invoked. We discard any 4716 * object result the command returns. 4717 */ 4718 4719 Tcl_SaveResult(interp, &state); 4720 stateCode = iPtr->returnCode; 4721 4722 saveInterpFlags = iPtr->flags; 4723 iPtr->flags |= INTERP_TRACE_IN_PROGRESS; 4724 tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; 4725 tcmdPtr->refCount++; 4726 /* 4727 * This line can have quite arbitrary side-effects, 4728 * including deleting the trace, the command being 4729 * traced, or even the interpreter. 4730 */ 4731 traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); 4732 tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; 4733 4734 /* 4735 * Restore the interp tracing flag to prevent cmd traces 4736 * from affecting interp traces 4737 */ 4738 iPtr->flags = saveInterpFlags;; 4739 if (tcmdPtr->flags == 0) { 4740 flags |= TCL_TRACE_DESTROYED; 4741 } 4742 4743 if (traceCode == TCL_OK) { 4744 /* Restore result if trace execution was successful */ 4745 Tcl_RestoreResult(interp, &state); 4746 iPtr->returnCode = stateCode; 4747 } else { 4748 Tcl_DiscardResult(&state); 4749 } 4750 4751 Tcl_DStringFree(&cmd); 4752 } 4753 4754 /* 4755 * Third, if there are any step execution traces for this proc, 4756 * we register an interpreter trace to invoke enterstep and/or 4757 * leavestep traces. 4758 * We also need to save the current stack level and the proc 4759 * string in startLevel and startCmd so that we can delete this 4760 * interpreter trace when it reaches the end of this proc. 4761 */ 4762 if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL) 4763 && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | 4764 TCL_TRACE_LEAVE_DURING_EXEC))) { 4765 tcmdPtr->startLevel = level; 4766 tcmdPtr->startCmd = 4767 (char *) ckalloc((unsigned) (strlen(command) + 1)); 4768 strcpy(tcmdPtr->startCmd, command); 4769 tcmdPtr->refCount++; 4770 tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, 4771 (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, 4772 TraceExecutionProc, (ClientData)tcmdPtr, 4773 CommandObjTraceDeleted); 4774 } 4775 } 4776 if (flags & TCL_TRACE_DESTROYED) { 4777 if (tcmdPtr->stepTrace != NULL) { 4778 Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); 4779 tcmdPtr->stepTrace = NULL; 4780 if (tcmdPtr->startCmd != NULL) { 4781 ckfree((char *)tcmdPtr->startCmd); 4782 } 4783 } 4784 } 4785 if (call) { 4786 tcmdPtr->refCount--; 4787 if (tcmdPtr->refCount < 0) { 4788 Tcl_Panic("TraceExecutionProc: negative TraceCommandInfo refCount"); 4789 } 4790 if (tcmdPtr->refCount == 0) { 4791 ckfree((char*)tcmdPtr); 4792 } 4793 } 4794 return traceCode; 4795} 4796 4797/* 4798 *---------------------------------------------------------------------- 4799 * 4800 * TraceVarProc -- 4801 * 4802 * This procedure is called to handle variable accesses that have 4803 * been traced using the "trace" command. 4804 * 4805 * Results: 4806 * Normally returns NULL. If the trace command returns an error, 4807 * then this procedure returns an error string. 4808 * 4809 * Side effects: 4810 * Depends on the command associated with the trace. 4811 * 4812 *---------------------------------------------------------------------- 4813 */ 4814 4815 /* ARGSUSED */ 4816static char * 4817TraceVarProc(clientData, interp, name1, name2, flags) 4818 ClientData clientData; /* Information about the variable trace. */ 4819 Tcl_Interp *interp; /* Interpreter containing variable. */ 4820 CONST char *name1; /* Name of variable or array. */ 4821 CONST char *name2; /* Name of element within array; NULL means 4822 * scalar variable is being referenced. */ 4823 int flags; /* OR-ed bits giving operation and other 4824 * information. */ 4825{ 4826 Tcl_SavedResult state; 4827 TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; 4828 char *result; 4829 int code, destroy = 0; 4830 Tcl_DString cmd; 4831 4832 /* 4833 * We might call Tcl_Eval() below, and that might evaluate [trace 4834 * vdelete] which might try to free tvarPtr. However we do not 4835 * need to protect anything here; it's done by our caller because 4836 * the TraceVarInfo is really part of a CompoundVarTrace. [Bug 1348775] 4837 */ 4838 4839 result = NULL; 4840 if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp)) { 4841 if (tvarPtr->length != (size_t) 0) { 4842 /* 4843 * Generate a command to execute by appending list elements 4844 * for the two variable names and the operation. 4845 */ 4846 4847 Tcl_DStringInit(&cmd); 4848 Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); 4849 Tcl_DStringAppendElement(&cmd, name1); 4850 Tcl_DStringAppendElement(&cmd, (name2 ? name2 : "")); 4851#ifndef TCL_REMOVE_OBSOLETE_TRACES 4852 if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) { 4853 if (flags & TCL_TRACE_ARRAY) { 4854 Tcl_DStringAppend(&cmd, " a", 2); 4855 } else if (flags & TCL_TRACE_READS) { 4856 Tcl_DStringAppend(&cmd, " r", 2); 4857 } else if (flags & TCL_TRACE_WRITES) { 4858 Tcl_DStringAppend(&cmd, " w", 2); 4859 } else if (flags & TCL_TRACE_UNSETS) { 4860 Tcl_DStringAppend(&cmd, " u", 2); 4861 } 4862 } else { 4863#endif 4864 if (flags & TCL_TRACE_ARRAY) { 4865 Tcl_DStringAppend(&cmd, " array", 6); 4866 } else if (flags & TCL_TRACE_READS) { 4867 Tcl_DStringAppend(&cmd, " read", 5); 4868 } else if (flags & TCL_TRACE_WRITES) { 4869 Tcl_DStringAppend(&cmd, " write", 6); 4870 } else if (flags & TCL_TRACE_UNSETS) { 4871 Tcl_DStringAppend(&cmd, " unset", 6); 4872 } 4873#ifndef TCL_REMOVE_OBSOLETE_TRACES 4874 } 4875#endif 4876 4877 /* 4878 * Execute the command. Save the interp's result used for 4879 * the command. We discard any object result the command returns. 4880 * 4881 * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to 4882 * other areas that this will be destroyed by us, otherwise a 4883 * double-free might occur depending on what the eval does. 4884 */ 4885 4886 Tcl_SaveResult(interp, &state); 4887 if ((flags & TCL_TRACE_DESTROYED) 4888 && !(tvarPtr->flags & TCL_TRACE_DESTROYED)) { 4889 destroy = 1; 4890 tvarPtr->flags |= TCL_TRACE_DESTROYED; 4891 } 4892 4893 code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), 4894 Tcl_DStringLength(&cmd), 0); 4895 if (code != TCL_OK) { /* copy error msg to result */ 4896 register Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); 4897 Tcl_IncrRefCount(errMsgObj); 4898 result = (char *) errMsgObj; 4899 } 4900 4901 Tcl_RestoreResult(interp, &state); 4902 4903 Tcl_DStringFree(&cmd); 4904 } 4905 } 4906 if (destroy) { 4907 if (result != NULL) { 4908 register Tcl_Obj *errMsgObj = (Tcl_Obj *) result; 4909 4910 Tcl_DecrRefCount(errMsgObj); 4911 result = NULL; 4912 } 4913 } 4914 return result; 4915} 4916 4917/* 4918 *---------------------------------------------------------------------- 4919 * 4920 * Tcl_WhileObjCmd -- 4921 * 4922 * This procedure is invoked to process the "while" Tcl command. 4923 * See the user documentation for details on what it does. 4924 * 4925 * With the bytecode compiler, this procedure is only called when 4926 * a command name is computed at runtime, and is "while" or the name 4927 * to which "while" was renamed: e.g., "set z while; $z {$i<100} {}" 4928 * 4929 * Results: 4930 * A standard Tcl result. 4931 * 4932 * Side effects: 4933 * See the user documentation. 4934 * 4935 *---------------------------------------------------------------------- 4936 */ 4937 4938 /* ARGSUSED */ 4939int 4940Tcl_WhileObjCmd(dummy, interp, objc, objv) 4941 ClientData dummy; /* Not used. */ 4942 Tcl_Interp *interp; /* Current interpreter. */ 4943 int objc; /* Number of arguments. */ 4944 Tcl_Obj *CONST objv[]; /* Argument objects. */ 4945{ 4946 int result, value; 4947#ifdef TCL_TIP280 4948 Interp* iPtr = (Interp*) interp; 4949#endif 4950 4951 if (objc != 3) { 4952 Tcl_WrongNumArgs(interp, 1, objv, "test command"); 4953 return TCL_ERROR; 4954 } 4955 4956 while (1) { 4957 result = Tcl_ExprBooleanObj(interp, objv[1], &value); 4958 if (result != TCL_OK) { 4959 return result; 4960 } 4961 if (!value) { 4962 break; 4963 } 4964#ifndef TCL_TIP280 4965 result = Tcl_EvalObjEx(interp, objv[2], 0); 4966#else 4967 /* TIP #280. */ 4968 result = TclEvalObjEx(interp, objv[2], 0, iPtr->cmdFramePtr,2); 4969#endif 4970 if ((result != TCL_OK) && (result != TCL_CONTINUE)) { 4971 if (result == TCL_ERROR) { 4972 char msg[32 + TCL_INTEGER_SPACE]; 4973 4974 sprintf(msg, "\n (\"while\" body line %d)", 4975 interp->errorLine); 4976 Tcl_AddErrorInfo(interp, msg); 4977 } 4978 break; 4979 } 4980 } 4981 if (result == TCL_BREAK) { 4982 result = TCL_OK; 4983 } 4984 if (result == TCL_OK) { 4985 Tcl_ResetResult(interp); 4986 } 4987 return result; 4988} 4989 4990#ifdef TCL_TIP280 4991static void 4992ListLines(listObj, line, n, lines, elems) 4993 Tcl_Obj* listObj; /* Pointer to obj holding a string with list structure. 4994 * Assumed to be valid. Assumed to contain n elements. 4995 */ 4996 int line; /* line the list as a whole starts on */ 4997 int n; /* #elements in lines */ 4998 int* lines; /* Array of line numbers, to fill */ 4999 Tcl_Obj* const* elems; /* The list elems as Tcl_Obj*, in need of derived 5000 * continuation data */ 5001{ 5002 int i; 5003 CONST char* listStr = Tcl_GetString (listObj); 5004 CONST char* listHead = listStr; 5005 int length = strlen( listStr); 5006 CONST char* element = NULL; 5007 CONST char* next = NULL; 5008 ContLineLoc* clLocPtr = TclContinuationsGet(listObj); 5009 int* clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL); 5010 5011 for (i = 0; i < n; i++) { 5012 TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL); 5013 5014 TclAdvanceLines (&line, listStr, element); /* Leading whitespace */ 5015 TclAdvanceContinuations (&line, &clNext, element - listHead); 5016 if (clNext) { 5017 TclContinuationsEnterDerived (elems[i], element - listHead, clNext); 5018 } 5019 5020 lines [i] = line; 5021 length -= (next - listStr); 5022 TclAdvanceLines (&line, element, next); /* Element */ 5023 listStr = next; 5024 5025 if (*element == 0) { 5026 /* ASSERT i == n */ 5027 break; 5028 } 5029 } 5030} 5031#endif 5032 5033/* 5034 * Local Variables: 5035 * mode: c 5036 * c-basic-offset: 4 5037 * fill-column: 78 5038 * End: 5039 */ 5040 5041