/* * tclCmdMZ.c -- * * This file contains the top-level command routines for most of * the Tcl built-in commands whose names begin with the letters * M to Z. It contains only commands in the generic core (i.e. * those that don't depend much upon UNIX facilities). * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Scriptics Corporation. * Copyright (c) 2002 ActiveState Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.17 2005/05/11 00:48:01 hobbs Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclRegexp.h" #include "tclCompile.h" /* * Structure used to hold information about variable traces: */ typedef struct { int flags; /* Operations for which Tcl command is * to be invoked. */ size_t length; /* Number of non-NULL chars. in command. */ char command[4]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to * hold command. This field must be the * last in the structure, so that it can * be larger than 4 bytes. */ } TraceVarInfo; /* * Structure used to hold information about command traces: */ typedef struct { int flags; /* Operations for which Tcl command is * to be invoked. */ size_t length; /* Number of non-NULL chars. in command. */ Tcl_Trace stepTrace; /* Used for execution traces, when tracing * inside the given command */ int startLevel; /* Used for bookkeeping with step execution * traces, store the level at which the step * trace was invoked */ char *startCmd; /* Used for bookkeeping with step execution * traces, store the command name which invoked * step trace */ int curFlags; /* Trace flags for the current command */ int curCode; /* Return code for the current command */ int refCount; /* Used to ensure this structure is * not deleted too early. Keeps track * of how many pieces of code have * a pointer to this structure. */ char command[4]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to * hold command. This field must be the * last in the structure, so that it can * be larger than 4 bytes. */ } TraceCommandInfo; /* * Used by command execution traces. Note that we assume in the code * that the first two defines are exactly 4 times the * 'TCL_TRACE_ENTER_EXEC' and 'TCL_TRACE_LEAVE_EXEC' constants. * * TCL_TRACE_ENTER_DURING_EXEC - Trace each command inside the command * currently being traced, before execution. * TCL_TRACE_LEAVE_DURING_EXEC - Trace each command inside the command * currently being traced, after execution. * TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags. * TCL_TRACE_EXEC_IN_PROGRESS - The callback procedure on this trace * is currently executing. Therefore we * don't let further traces execute. * TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly * by the command being traced, not because * of an internal trace. * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also * be used in command execution traces. */ #define TCL_TRACE_ENTER_DURING_EXEC 4 #define TCL_TRACE_LEAVE_DURING_EXEC 8 #define TCL_TRACE_ANY_EXEC 15 #define TCL_TRACE_EXEC_IN_PROGRESS 0x10 #define TCL_TRACE_EXEC_DIRECT 0x20 /* * Forward declarations for procedures defined in this file: */ typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp, int optionIndex, int objc, Tcl_Obj *CONST objv[])); Tcl_TraceTypeObjCmd TclTraceVariableObjCmd; Tcl_TraceTypeObjCmd TclTraceCommandObjCmd; Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd; /* * Each subcommand has a number of 'types' to which it can apply. * Currently 'execution', 'command' and 'variable' are the only * types supported. These three arrays MUST be kept in sync! * In the future we may provide an API to add to the list of * supported trace types. */ static CONST char *traceTypeOptions[] = { "execution", "command", "variable", (char*) NULL }; static Tcl_TraceTypeObjCmd* traceSubCmds[] = { TclTraceExecutionObjCmd, TclTraceCommandObjCmd, TclTraceVariableObjCmd, }; /* * Declarations for local procedures to this file: */ static int CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp, Trace *tracePtr, Command *cmdPtr, CONST char *command, int numChars, int objc, Tcl_Obj *CONST objv[])); static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags)); static void TraceCommandProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, CONST char *oldName, CONST char *newName, int flags)); static Tcl_CmdObjTraceProc TraceExecutionProc; /* *---------------------------------------------------------------------- * * Tcl_PwdObjCmd -- * * This procedure is invoked to process the "pwd" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_PwdObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Obj *retVal; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } retVal = Tcl_FSGetCwd(interp); if (retVal == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, retVal); Tcl_DecrRefCount(retVal); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_RegexpObjCmd -- * * This procedure is invoked to process the "regexp" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_RegexpObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int i, indices, match, about, offset, all, doinline, numMatchesSaved; int cflags, eflags, stringLength; Tcl_RegExp regExpr; Tcl_Obj *objPtr, *resultPtr; Tcl_RegExpInfo info; static CONST char *options[] = { "-all", "-about", "-indices", "-inline", "-expanded", "-line", "-linestop", "-lineanchor", "-nocase", "-start", "--", (char *) NULL }; enum options { REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE, REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR, REGEXP_NOCASE, REGEXP_START, REGEXP_LAST }; indices = 0; about = 0; cflags = TCL_REG_ADVANCED; eflags = 0; offset = 0; all = 0; doinline = 0; for (i = 1; i < objc; i++) { char *name; int index; name = Tcl_GetString(objv[i]); if (name[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { case REGEXP_ALL: { all = 1; break; } case REGEXP_INDICES: { indices = 1; break; } case REGEXP_INLINE: { doinline = 1; break; } case REGEXP_NOCASE: { cflags |= TCL_REG_NOCASE; break; } case REGEXP_ABOUT: { about = 1; break; } case REGEXP_EXPANDED: { cflags |= TCL_REG_EXPANDED; break; } case REGEXP_LINE: { cflags |= TCL_REG_NEWLINE; break; } case REGEXP_LINESTOP: { cflags |= TCL_REG_NLSTOP; break; } case REGEXP_LINEANCHOR: { cflags |= TCL_REG_NLANCH; break; } case REGEXP_START: { if (++i >= objc) { goto endOfForLoop; } if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) { return TCL_ERROR; } if (offset < 0) { offset = 0; } break; } case REGEXP_LAST: { i++; goto endOfForLoop; } } } endOfForLoop: if ((objc - i) < (2 - about)) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); return TCL_ERROR; } objc -= i; objv += i; if (doinline && ((objc - 2) != 0)) { /* * User requested -inline, but specified match variables - a no-no. */ Tcl_AppendResult(interp, "regexp match variables not allowed", " when using -inline", (char *) NULL); return TCL_ERROR; } /* * Handle the odd about case separately. */ if (about) { regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) { return TCL_ERROR; } return TCL_OK; } /* * Get the length of the string that we are matching against so * we can do the termination test for -all matches. Do this before * getting the regexp to avoid shimmering problems. */ objPtr = objv[1]; stringLength = Tcl_GetCharLength(objPtr); regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if (regExpr == NULL) { return TCL_ERROR; } if (offset > 0) { /* * Add flag if using offset (string is part of a larger string), * so that "^" won't match. */ eflags |= TCL_REG_NOTBOL; } objc -= 2; objv += 2; resultPtr = Tcl_GetObjResult(interp); if (doinline) { /* * Save all the subexpressions, as we will return them as a list */ numMatchesSaved = -1; } else { /* * Save only enough subexpressions for matches we want to keep, * expect in the case of -all, where we need to keep at least * one to know where to move the offset. */ numMatchesSaved = (objc == 0) ? all : objc; } /* * The following loop is to handle multiple matches within the * same source string; each iteration handles one match. If "-all" * hasn't been specified then the loop body only gets executed once. * We terminate the loop when the starting offset is past the end of the * string. */ while (1) { match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset /* offset */, numMatchesSaved, eflags | ((offset > 0 && (Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n')) ? TCL_REG_NOTBOL : 0)); if (match < 0) { return TCL_ERROR; } if (match == 0) { /* * We want to set the value of the intepreter result only when * this is the first time through the loop. */ if (all <= 1) { /* * If inlining, set the interpreter's object result to an * empty list, otherwise set it to an integer object w/ * value 0. */ if (doinline) { Tcl_SetListObj(resultPtr, 0, NULL); } else { Tcl_SetIntObj(resultPtr, 0); } return TCL_OK; } break; } /* * If additional variable names have been specified, return * index information in those variables. */ Tcl_RegExpGetInfo(regExpr, &info); if (doinline) { /* * It's the number of substitutions, plus one for the matchVar * at index 0 */ objc = info.nsubs + 1; } for (i = 0; i < objc; i++) { Tcl_Obj *newPtr; if (indices) { int start, end; Tcl_Obj *objs[2]; /* * Only adjust the match area if there was a match for * that area. (Scriptics Bug 4391/SF Bug #219232) */ if (i <= info.nsubs && info.matches[i].start >= 0) { start = offset + info.matches[i].start; end = offset + info.matches[i].end; /* * Adjust index so it refers to the last character in the * match instead of the first character after the match. */ if (end >= offset) { end--; } } else { start = -1; end = -1; } objs[0] = Tcl_NewLongObj(start); objs[1] = Tcl_NewLongObj(end); newPtr = Tcl_NewListObj(2, objs); } else { if (i <= info.nsubs) { newPtr = Tcl_GetRange(objPtr, offset + info.matches[i].start, offset + info.matches[i].end - 1); } else { newPtr = Tcl_NewObj(); } } if (doinline) { if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr) != TCL_OK) { Tcl_DecrRefCount(newPtr); return TCL_ERROR; } } else { Tcl_Obj *valuePtr; valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); if (valuePtr == NULL) { Tcl_DecrRefCount(newPtr); Tcl_AppendResult(interp, "couldn't set variable \"", Tcl_GetString(objv[i]), "\"", (char *) NULL); return TCL_ERROR; } } } if (all == 0) { break; } /* * Adjust the offset to the character just after the last one * in the matchVar and increment all to count how many times * we are making a match. We always increment the offset by at least * one to prevent endless looping (as in the case: * regexp -all {a*} a). Otherwise, when we match the NULL string at * the end of the input string, we will loop indefinately (because the * length of the match is 0, so offset never changes). */ if (info.matches[0].end == 0) { offset++; } offset += info.matches[0].end; all++; eflags |= TCL_REG_NOTBOL; if (offset >= stringLength) { break; } } /* * Set the interpreter's object result to an integer object * with value 1 if -all wasn't specified, otherwise it's all-1 * (the number of times through the while - 1). * Get the resultPtr again as the Tcl_ObjSetVar2 above may have * cause the result to change. [Patch #558324] (watson). */ if (!doinline) { resultPtr = Tcl_GetObjResult(interp); Tcl_SetIntObj(resultPtr, (all ? all-1 : 1)); } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_RegsubObjCmd -- * * This procedure is invoked to process the "regsub" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_RegsubObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int idx, result, cflags, all, wlen, wsublen, numMatches, offset; int start, end, subStart, subEnd, match; Tcl_RegExp regExpr; Tcl_RegExpInfo info; Tcl_Obj *resultPtr, *subPtr, *objPtr; Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; static CONST char *options[] = { "-all", "-nocase", "-expanded", "-line", "-linestop", "-lineanchor", "-start", "--", NULL }; enum options { REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED, REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START, REGSUB_LAST }; cflags = TCL_REG_ADVANCED; all = 0; offset = 0; resultPtr = NULL; for (idx = 1; idx < objc; idx++) { char *name; int index; name = Tcl_GetString(objv[idx]); if (name[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { case REGSUB_ALL: { all = 1; break; } case REGSUB_NOCASE: { cflags |= TCL_REG_NOCASE; break; } case REGSUB_EXPANDED: { cflags |= TCL_REG_EXPANDED; break; } case REGSUB_LINE: { cflags |= TCL_REG_NEWLINE; break; } case REGSUB_LINESTOP: { cflags |= TCL_REG_NLSTOP; break; } case REGSUB_LINEANCHOR: { cflags |= TCL_REG_NLANCH; break; } case REGSUB_START: { if (++idx >= objc) { goto endOfForLoop; } if (Tcl_GetIntFromObj(interp, objv[idx], &offset) != TCL_OK) { return TCL_ERROR; } if (offset < 0) { offset = 0; } break; } case REGSUB_LAST: { idx++; goto endOfForLoop; } } } endOfForLoop: if (objc-idx < 3 || objc-idx > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string subSpec ?varName?"); return TCL_ERROR; } objc -= idx; objv += idx; if (all && (offset == 0) && (strpbrk(Tcl_GetString(objv[2]), "&\\") == NULL) && (strpbrk(Tcl_GetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { /* * This is a simple one pair string map situation. We make use of * a slightly modified version of the one pair STR_MAP code. */ int slen, nocase; int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar *, CONST Tcl_UniChar *, unsigned long)); Tcl_UniChar *p, wsrclc; numMatches = 0; nocase = (cflags & TCL_REG_NOCASE); strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen); wend = wstring + wlen - (slen ? slen - 1 : 0); result = TCL_OK; if (slen == 0) { /* * regsub behavior for "" matches between each character. * 'string map' skips the "" case. */ if (wstring < wend) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); for (; wstring < wend; wstring++) { Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); Tcl_AppendUnicodeToObj(resultPtr, wstring, 1); numMatches++; } wlen = 0; } } else { wsrclc = Tcl_UniCharToLower(*wsrc); for (p = wfirstChar = wstring; wstring < wend; wstring++) { if (((*wstring == *wsrc) || (nocase && (Tcl_UniCharToLower(*wstring) == wsrclc))) && ((slen == 1) || (strCmpFn(wstring, wsrc, (unsigned long) slen) == 0))) { if (numMatches == 0) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); } if (p != wstring) { Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p); p = wstring + slen; } else { p += slen; } wstring = p - 1; Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); numMatches++; } } if (numMatches) { wlen = wfirstChar + wlen - p; wstring = p; } } objPtr = NULL; subPtr = NULL; goto regsubDone; } regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if (regExpr == NULL) { return TCL_ERROR; } /* * Make sure to avoid problems where the objects are shared. This * can cause RegExpObj <> UnicodeObj shimmering that causes data * corruption. [Bug #461322] */ if (objv[1] == objv[0]) { objPtr = Tcl_DuplicateObj(objv[1]); } else { objPtr = objv[1]; } wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); if (objv[2] == objv[0]) { subPtr = Tcl_DuplicateObj(objv[2]); } else { subPtr = objv[2]; } wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); result = TCL_OK; /* * The following loop is to handle multiple matches within the * same source string; each iteration handles one match and its * corresponding substitution. If "-all" hasn't been specified * then the loop body only gets executed once. We must use * 'offset <= wlen' in particular for the case where the regexp * pattern can match the empty string - this is useful when * doing, say, 'regsub -- ^ $str ...' when $str might be empty. */ numMatches = 0; for ( ; offset <= wlen; ) { /* * The flags argument is set if string is part of a larger string, * so that "^" won't match. */ match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset, 10 /* matches */, ((offset > 0 && (wstring[offset-1] != (Tcl_UniChar)'\n')) ? TCL_REG_NOTBOL : 0)); if (match < 0) { result = TCL_ERROR; goto done; } if (match == 0) { break; } if (numMatches == 0) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); if (offset > 0) { /* * Copy the initial portion of the string in if an offset * was specified. */ Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); } } numMatches++; /* * Copy the portion of the source string before the match to the * result variable. */ Tcl_RegExpGetInfo(regExpr, &info); start = info.matches[0].start; end = info.matches[0].end; Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); /* * Append the subSpec argument to the variable, making appropriate * substitutions. This code is a bit hairy because of the backslash * conventions and because the code saves up ranges of characters in * subSpec to reduce the number of calls to Tcl_SetVar. */ wsrc = wfirstChar = wsubspec; wend = wsubspec + wsublen; for (ch = *wsrc; wsrc != wend; wsrc++, ch = *wsrc) { if (ch == '&') { idx = 0; } else if (ch == '\\') { ch = wsrc[1]; if ((ch >= '0') && (ch <= '9')) { idx = ch - '0'; } else if ((ch == '\\') || (ch == '&')) { *wsrc = ch; Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar + 1); *wsrc = '\\'; wfirstChar = wsrc + 2; wsrc++; continue; } else { continue; } } else { continue; } if (wfirstChar != wsrc) { Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (idx <= info.nsubs) { subStart = info.matches[idx].start; subEnd = info.matches[idx].end; if ((subStart >= 0) && (subEnd >= 0)) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset + subStart, subEnd - subStart); } } if (*wsrc == '\\') { wsrc++; } wfirstChar = wsrc + 1; } if (wfirstChar != wsrc) { Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (end == 0) { /* * Always consume at least one character of the input string * in order to prevent infinite loops. */ if (offset < wlen) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } else { offset += end; if (start == end) { /* * We matched an empty string, which means we must go * forward one more step so we don't match again at the * same spot. */ if (offset < wlen) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } } if (!all) { break; } } /* * Copy the portion of the source string after the last match to the * result variable. */ regsubDone: if (numMatches == 0) { /* * On zero matches, just ignore the offset, since it shouldn't * matter to us in this case, and the user may have skewed it. */ resultPtr = objv[1]; Tcl_IncrRefCount(resultPtr); } else if (offset < wlen) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (objc == 4) { if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", Tcl_GetString(objv[3]), "\"", (char *) NULL); result = TCL_ERROR; } else { /* * Set the interpreter's object result to an integer object * holding the number of matches. */ Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches); } } else { /* * No varname supplied, so just return the modified string. */ Tcl_SetObjResult(interp, resultPtr); } done: if (objPtr && (objv[1] == objv[0])) { Tcl_DecrRefCount(objPtr); } if (subPtr && (objv[2] == objv[0])) { Tcl_DecrRefCount(subPtr); } if (resultPtr) { Tcl_DecrRefCount(resultPtr); } return result; } /* *---------------------------------------------------------------------- * * Tcl_RenameObjCmd -- * * This procedure is invoked to process the "rename" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_RenameObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Arbitrary value passed to the command. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { char *oldName, *newName; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); return TCL_ERROR; } oldName = Tcl_GetString(objv[1]); newName = Tcl_GetString(objv[2]); return TclRenameCommand(interp, oldName, newName); } /* *---------------------------------------------------------------------- * * Tcl_ReturnObjCmd -- * * This object-based procedure is invoked to process the "return" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ReturnObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Interp *iPtr = (Interp *) interp; int optionLen, argLen, code, result; if (iPtr->errorInfo != NULL) { ckfree(iPtr->errorInfo); iPtr->errorInfo = NULL; } if (iPtr->errorCode != NULL) { ckfree(iPtr->errorCode); iPtr->errorCode = NULL; } code = TCL_OK; for (objv++, objc--; objc > 1; objv += 2, objc -= 2) { char *option = Tcl_GetStringFromObj(objv[0], &optionLen); char *arg = Tcl_GetStringFromObj(objv[1], &argLen); if (strcmp(option, "-code") == 0) { register int c = arg[0]; if ((c == 'o') && (strcmp(arg, "ok") == 0)) { code = TCL_OK; } else if ((c == 'e') && (strcmp(arg, "error") == 0)) { code = TCL_ERROR; } else if ((c == 'r') && (strcmp(arg, "return") == 0)) { code = TCL_RETURN; } else if ((c == 'b') && (strcmp(arg, "break") == 0)) { code = TCL_BREAK; } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) { code = TCL_CONTINUE; } else { result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1], &code); if (result != TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad completion code \"", Tcl_GetString(objv[1]), "\": must be ok, error, return, break, ", "continue, or an integer", (char *) NULL); return result; } } } else if (strcmp(option, "-errorinfo") == 0) { iPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(arg) + 1)); strcpy(iPtr->errorInfo, arg); } else if (strcmp(option, "-errorcode") == 0) { iPtr->errorCode = (char *) ckalloc((unsigned) (strlen(arg) + 1)); strcpy(iPtr->errorCode, arg); } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option \"", option, "\": must be -code, -errorcode, or -errorinfo", (char *) NULL); return TCL_ERROR; } } if (objc == 1) { /* * Set the interpreter's object result. An inline version of * Tcl_SetObjResult. */ Tcl_SetObjResult(interp, objv[0]); } iPtr->returnCode = code; return TCL_RETURN; } /* *---------------------------------------------------------------------- * * Tcl_SourceObjCmd -- * * This procedure is invoked to process the "source" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_SourceObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "fileName"); return TCL_ERROR; } return Tcl_FSEvalFile(interp, objv[1]); } /* *---------------------------------------------------------------------- * * Tcl_SplitObjCmd -- * * This procedure is invoked to process the "split" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_SplitObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_UniChar ch; int len; char *splitChars, *string, *end; int splitCharLen, stringLen; Tcl_Obj *listPtr, *objPtr; if (objc == 2) { splitChars = " \n\t\r"; splitCharLen = 4; } else if (objc == 3) { splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?"); return TCL_ERROR; } string = Tcl_GetStringFromObj(objv[1], &stringLen); end = string + stringLen; listPtr = Tcl_GetObjResult(interp); if (stringLen == 0) { /* * Do nothing. */ } else if (splitCharLen == 0) { Tcl_HashTable charReuseTable; Tcl_HashEntry *hPtr; int isNew; /* * Handle the special case of splitting on every character. * * Uses a hash table to ensure that each kind of character has * only one Tcl_Obj instance (multiply-referenced) in the * final list. This is a *major* win when splitting on a long * string (especially in the megabyte range!) - DKF */ Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); for ( ; string < end; string += len) { len = TclUtfToUniChar(string, &ch); /* Assume Tcl_UniChar is an integral type... */ hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew); if (isNew) { objPtr = Tcl_NewStringObj(string, len); /* Don't need to fiddle with refcount... */ Tcl_SetHashValue(hPtr, (ClientData) objPtr); } else { objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr); } Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } Tcl_DeleteHashTable(&charReuseTable); } else if (splitCharLen == 1) { char *p; /* * Handle the special case of splitting on a single character. * This is only true for the one-char ASCII case, as one unicode * char is > 1 byte in length. */ while (*string && (p = strchr(string, (int) *splitChars)) != NULL) { objPtr = Tcl_NewStringObj(string, p - string); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); string = p + 1; } objPtr = Tcl_NewStringObj(string, end - string); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } else { char *element, *p, *splitEnd; int splitLen; Tcl_UniChar splitChar; /* * Normal case: split on any of a given set of characters. * Discard instances of the split characters. */ splitEnd = splitChars + splitCharLen; for (element = string; string < end; string += len) { len = TclUtfToUniChar(string, &ch); for (p = splitChars; p < splitEnd; p += splitLen) { splitLen = TclUtfToUniChar(p, &splitChar); if (ch == splitChar) { objPtr = Tcl_NewStringObj(element, string - element); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); element = string + len; break; } } } objPtr = Tcl_NewStringObj(element, string - element); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_StringObjCmd -- * * This procedure is invoked to process the "string" Tcl command. * See the user documentation for details on what it does. Note * that this command only functions correctly on properly formed * Tcl UTF strings. * * Note that the primary methods here (equal, compare, match, ...) * have bytecode equivalents. You will find the code for those in * tclExecute.c. The code here will only be used in the non-bc * case (like in an 'eval'). * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_StringObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int index, left, right; Tcl_Obj *resultPtr; char *string1, *string2; int length1, length2; static CONST char *options[] = { "bytelength", "compare", "equal", "first", "index", "is", "last", "length", "map", "match", "range", "repeat", "replace", "tolower", "toupper", "totitle", "trim", "trimleft", "trimright", "wordend", "wordstart", (char *) NULL }; enum options { STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST, STR_INDEX, STR_IS, STR_LAST, STR_LENGTH, STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT, STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, STR_WORDEND, STR_WORDSTART }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } resultPtr = Tcl_GetObjResult(interp); switch ((enum options) index) { case STR_EQUAL: case STR_COMPARE: { /* * Remember to keep code here in some sync with the * byte-compiled versions in tclExecute.c (INST_STR_EQ, * INST_STR_NEQ and INST_STR_CMP as well as the expr string * comparison in INST_EQ/INST_NEQ/INST_LT/...). */ int i, match, length, nocase = 0, reqlength = -1; int (*strCmpFn)(); if (objc < 4 || objc > 7) { str_cmp_args: Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? ?-length int? string1 string2"); return TCL_ERROR; } for (i = 2; i < objc-2; i++) { string2 = Tcl_GetStringFromObj(objv[i], &length2); if ((length2 > 1) && strncmp(string2, "-nocase", (size_t)length2) == 0) { nocase = 1; } else if ((length2 > 1) && strncmp(string2, "-length", (size_t)length2) == 0) { if (i+1 >= objc-2) { goto str_cmp_args; } if (Tcl_GetIntFromObj(interp, objv[++i], &reqlength) != TCL_OK) { return TCL_ERROR; } } else { Tcl_AppendStringsToObj(resultPtr, "bad option \"", string2, "\": must be -nocase or -length", (char *) NULL); return TCL_ERROR; } } /* * From now on, we only access the two objects at the end * of the argument array. */ objv += objc-2; if ((reqlength == 0) || (objv[0] == objv[1])) { /* * Alway match at 0 chars of if it is the same obj. */ Tcl_SetBooleanObj(resultPtr, ((enum options) index == STR_EQUAL)); break; } else if (!nocase && objv[0]->typePtr == &tclByteArrayType && objv[1]->typePtr == &tclByteArrayType) { /* * Use binary versions of comparisons since that won't * cause undue type conversions and it is much faster. * Only do this if we're case-sensitive (which is all * that really makes sense with byte arrays anyway, and * we have no memcasecmp() for some reason... :^) */ string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1); string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2); strCmpFn = memcmp; } else if ((objv[0]->typePtr == &tclStringType) && (objv[1]->typePtr == &tclStringType)) { /* * Do a unicode-specific comparison if both of the args * are of String type. In benchmark testing this proved * the most efficient check between the unicode and * string comparison operations. */ string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1); string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2); strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; } else { /* * As a catch-all we will work with UTF-8. We cannot use * memcmp() as that is unsafe with any string containing * NULL (\xC0\x80 in Tcl's utf rep). We can use the more * efficient TclpUtfNcmp2 if we are case-sensitive and no * specific length was requested. */ string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1); string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2); if ((reqlength < 0) && !nocase) { strCmpFn = TclpUtfNcmp2; } else { length1 = Tcl_NumUtfChars(string1, length1); length2 = Tcl_NumUtfChars(string2, length2); strCmpFn = nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp; } } if (((enum options) index == STR_EQUAL) && (reqlength < 0) && (length1 != length2)) { match = 1; /* this will be reversed below */ } else { length = (length1 < length2) ? length1 : length2; if (reqlength > 0 && reqlength < length) { length = reqlength; } else if (reqlength < 0) { /* * The requested length is negative, so we ignore it by * setting it to length + 1 so we correct the match var. */ reqlength = length + 1; } match = strCmpFn(string1, string2, (unsigned) length); if ((match == 0) && (reqlength > length)) { match = length1 - length2; } } if ((enum options) index == STR_EQUAL) { Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1); } else { Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 : (match < 0) ? -1 : 0)); } break; } case STR_FIRST: { Tcl_UniChar *ustring1, *ustring2; int match, start; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "subString string ?startIndex?"); return TCL_ERROR; } /* * We are searching string2 for the sequence string1. */ match = -1; start = 0; length2 = -1; ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); if (objc == 5) { /* * If a startIndex is specified, we will need to fast * forward to that point in the string before we think * about a match */ if (TclGetIntForIndex(interp, objv[4], length2 - 1, &start) != TCL_OK) { return TCL_ERROR; } if (start >= length2) { goto str_first_done; } else if (start > 0) { ustring2 += start; length2 -= start; } else if (start < 0) { /* * Invalid start index mapped to string start; * Bug #423581 */ start = 0; } } if (length1 > 0) { register Tcl_UniChar *p, *end; end = ustring2 + length2 - length1 + 1; for (p = ustring2; p < end; p++) { /* * Scan forward to find the first character. */ if ((*p == *ustring1) && (TclUniCharNcmp(ustring1, p, (unsigned long) length1) == 0)) { match = p - ustring2; break; } } } /* * Compute the character index of the matching string by * counting the number of characters before the match. */ if ((match != -1) && (objc == 5)) { match += start; } str_first_done: Tcl_SetIntObj(resultPtr, match); break; } case STR_INDEX: { if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); return TCL_ERROR; } /* * If we have a ByteArray object, avoid indexing in the * Utf string since the byte array contains one byte per * character. Otherwise, use the Unicode string rep to * get the index'th char. */ if (objv[2]->typePtr == &tclByteArrayType) { string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1); if (TclGetIntForIndex(interp, objv[3], length1 - 1, &index) != TCL_OK) { return TCL_ERROR; } if ((index >= 0) && (index < length1)) { Tcl_SetByteArrayObj(resultPtr, (unsigned char *)(&string1[index]), 1); } } else { /* * Get Unicode char length to calulate what 'end' means. */ length1 = Tcl_GetCharLength(objv[2]); if (TclGetIntForIndex(interp, objv[3], length1 - 1, &index) != TCL_OK) { return TCL_ERROR; } if ((index >= 0) && (index < length1)) { char buf[TCL_UTF_MAX]; Tcl_UniChar ch; ch = Tcl_GetUniChar(objv[2], index); length1 = Tcl_UniCharToUtf(ch, buf); Tcl_SetStringObj(resultPtr, buf, length1); } } break; } case STR_IS: { char *end; Tcl_UniChar ch; /* * The UniChar comparison function */ int (*chcomp)_ANSI_ARGS_((int)) = NULL; int i, failat = 0, result = 1, strict = 0; Tcl_Obj *objPtr, *failVarObj = NULL; static CONST char *isOptions[] = { "alnum", "alpha", "ascii", "control", "boolean", "digit", "double", "false", "graph", "integer", "lower", "print", "punct", "space", "true", "upper", "wordchar", "xdigit", (char *) NULL }; enum isOptions { STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WORD, STR_IS_XDIGIT }; if (objc < 4 || objc > 7) { Tcl_WrongNumArgs(interp, 2, objv, "class ?-strict? ?-failindex var? str"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0, &index) != TCL_OK) { return TCL_ERROR; } if (objc != 4) { for (i = 3; i < objc-1; i++) { string2 = Tcl_GetStringFromObj(objv[i], &length2); if ((length2 > 1) && strncmp(string2, "-strict", (size_t) length2) == 0) { strict = 1; } else if ((length2 > 1) && strncmp(string2, "-failindex", (size_t) length2) == 0) { if (i+1 >= objc-1) { Tcl_WrongNumArgs(interp, 3, objv, "?-strict? ?-failindex var? str"); return TCL_ERROR; } failVarObj = objv[++i]; } else { Tcl_AppendStringsToObj(resultPtr, "bad option \"", string2, "\": must be -strict or -failindex", (char *) NULL); return TCL_ERROR; } } } /* * We get the objPtr so that we can short-cut for some classes * by checking the object type (int and double), but we need * the string otherwise, because we don't want any conversion * of type occuring (as, for example, Tcl_Get*FromObj would do */ objPtr = objv[objc-1]; string1 = Tcl_GetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { result = 0; } goto str_is_done; } end = string1 + length1; /* * When entering here, result == 1 and failat == 0 */ switch ((enum isOptions) index) { case STR_IS_ALNUM: chcomp = Tcl_UniCharIsAlnum; break; case STR_IS_ALPHA: chcomp = Tcl_UniCharIsAlpha; break; case STR_IS_ASCII: for (; string1 < end; string1++, failat++) { /* * This is a valid check in unicode, because all * bytes < 0xC0 are single byte chars (but isascii * limits that def'n to 0x80). */ if (*((unsigned char *)string1) >= 0x80) { result = 0; break; } } break; case STR_IS_BOOL: case STR_IS_TRUE: case STR_IS_FALSE: /* Optimizers, beware Bug 1187123 ! */ if ((Tcl_GetBoolean(NULL, string1, &i) == TCL_ERROR) || (((enum isOptions) index == STR_IS_TRUE) && i == 0) || (((enum isOptions) index == STR_IS_FALSE) && i != 0)) { result = 0; } break; case STR_IS_CONTROL: chcomp = Tcl_UniCharIsControl; break; case STR_IS_DIGIT: chcomp = Tcl_UniCharIsDigit; break; case STR_IS_DOUBLE: { char *stop; if ((objPtr->typePtr == &tclDoubleType) || (objPtr->typePtr == &tclIntType)) { break; } /* * This is adapted from Tcl_GetDouble * * The danger in this function is that * "12345678901234567890" is an acceptable 'double', * but will later be interp'd as an int by something * like [expr]. Therefore, we check to see if it looks * like an int, and if so we do a range check on it. * If strtoul gets to the end, we know we either * received an acceptable int, or over/underflow */ if (TclLooksLikeInt(string1, length1)) { errno = 0; #ifdef TCL_WIDE_INT_IS_LONG strtoul(string1, &stop, 0); /* INTL: Tcl source. */ #else strtoull(string1, &stop, 0); /* INTL: Tcl source. */ #endif if (stop == end) { if (errno == ERANGE) { result = 0; failat = -1; } break; } } errno = 0; strtod(string1, &stop); /* INTL: Tcl source. */ if (errno == ERANGE) { /* * if (errno == ERANGE), then it was an over/underflow * problem, but in this method, we only want to know * yes or no, so bad flow returns 0 (false) and sets * the failVarObj to the string length. */ result = 0; failat = -1; } else if (stop == string1) { /* * In this case, nothing like a number was found */ result = 0; failat = 0; } else { /* * Assume we sucked up one char per byte * and then we go onto SPACE, since we are * allowed trailing whitespace */ failat = stop - string1; string1 = stop; chcomp = Tcl_UniCharIsSpace; } break; } case STR_IS_GRAPH: chcomp = Tcl_UniCharIsGraph; break; case STR_IS_INT: { char *stop; long int l = 0; if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) { break; } /* * Like STR_IS_DOUBLE, but we use strtoul. * Since Tcl_GetIntFromObj already failed, * we set result to 0. */ result = 0; errno = 0; l = strtol(string1, &stop, 0); /* INTL: Tcl source. */ if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) { /* * if (errno == ERANGE), then it was an over/underflow * problem, but in this method, we only want to know * yes or no, so bad flow returns 0 (false) and sets * the failVarObj to the string length. */ failat = -1; } else if (stop == string1) { /* * In this case, nothing like a number was found */ failat = 0; } else { /* * Assume we sucked up one char per byte * and then we go onto SPACE, since we are * allowed trailing whitespace */ failat = stop - string1; string1 = stop; chcomp = Tcl_UniCharIsSpace; } break; } case STR_IS_LOWER: chcomp = Tcl_UniCharIsLower; break; case STR_IS_PRINT: chcomp = Tcl_UniCharIsPrint; break; case STR_IS_PUNCT: chcomp = Tcl_UniCharIsPunct; break; case STR_IS_SPACE: chcomp = Tcl_UniCharIsSpace; break; case STR_IS_UPPER: chcomp = Tcl_UniCharIsUpper; break; case STR_IS_WORD: chcomp = Tcl_UniCharIsWordChar; break; case STR_IS_XDIGIT: { for (; string1 < end; string1++, failat++) { /* INTL: We assume unicode is bad for this class */ if ((*((unsigned char *)string1) >= 0xC0) || !isxdigit(*(unsigned char *)string1)) { result = 0; break; } } break; } } if (chcomp != NULL) { for (; string1 < end; string1 += length2, failat++) { length2 = TclUtfToUniChar(string1, &ch); if (!chcomp(ch)) { result = 0; break; } } } str_is_done: /* * Only set the failVarObj when we will return 0 * and we have indicated a valid fail index (>= 0) */ if ((result == 0) && (failVarObj != NULL) && Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } Tcl_SetBooleanObj(resultPtr, result); break; } case STR_LAST: { Tcl_UniChar *ustring1, *ustring2, *p; int match, start; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "subString string ?startIndex?"); return TCL_ERROR; } /* * We are searching string2 for the sequence string1. */ match = -1; start = 0; length2 = -1; ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); if (objc == 5) { /* * If a startIndex is specified, we will need to restrict * the string range to that char index in the string */ if (TclGetIntForIndex(interp, objv[4], length2 - 1, &start) != TCL_OK) { return TCL_ERROR; } if (start < 0) { goto str_last_done; } else if (start < length2) { p = ustring2 + start + 1 - length1; } else { p = ustring2 + length2 - length1; } } else { p = ustring2 + length2 - length1; } if (length1 > 0) { for (; p >= ustring2; p--) { /* * Scan backwards to find the first character. */ if ((*p == *ustring1) && (memcmp((char *) ustring1, (char *) p, (size_t) (length1 * sizeof(Tcl_UniChar))) == 0)) { match = p - ustring2; break; } } } str_last_done: Tcl_SetIntObj(resultPtr, match); break; } case STR_BYTELENGTH: case STR_LENGTH: { if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; } if ((enum options) index == STR_BYTELENGTH) { (void) Tcl_GetStringFromObj(objv[2], &length1); } else { /* * If we have a ByteArray object, avoid recomputing the * string since the byte array contains one byte per * character. Otherwise, use the Unicode string rep to * calculate the length. */ if (objv[2]->typePtr == &tclByteArrayType) { (void) Tcl_GetByteArrayFromObj(objv[2], &length1); } else { length1 = Tcl_GetCharLength(objv[2]); } } Tcl_SetIntObj(resultPtr, length1); break; } case STR_MAP: { int mapElemc, nocase = 0, copySource = 0; Tcl_Obj **mapElemv, *sourceObj; Tcl_UniChar *ustring1, *ustring2, *p, *end; int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*, CONST Tcl_UniChar*, unsigned long)); if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string"); return TCL_ERROR; } if (objc == 5) { string2 = Tcl_GetStringFromObj(objv[2], &length2); if ((length2 > 1) && strncmp(string2, "-nocase", (size_t) length2) == 0) { nocase = 1; } else { Tcl_AppendStringsToObj(resultPtr, "bad option \"", string2, "\": must be -nocase", (char *) NULL); return TCL_ERROR; } } if (Tcl_ListObjGetElements(interp, objv[objc-2], &mapElemc, &mapElemv) != TCL_OK) { return TCL_ERROR; } if (mapElemc == 0) { /* * empty charMap, just return whatever string was given */ Tcl_SetObjResult(interp, objv[objc-1]); return TCL_OK; } else if (mapElemc & 1) { /* * The charMap must be an even number of key/value items */ Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1); return TCL_ERROR; } /* * Take a copy of the source string object if it is the * same as the map string to cut out nasty sharing * crashes. [Bug 1018562] */ if (objv[objc-2] == objv[objc-1]) { sourceObj = Tcl_DuplicateObj(objv[objc-1]); copySource = 1; } else { sourceObj = objv[objc-1]; } ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1); if (length1 == 0) { /* * Empty input string, just stop now */ if (copySource) { Tcl_DecrRefCount(sourceObj); } break; } end = ustring1 + length1; strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; /* * Force result to be Unicode */ Tcl_SetUnicodeObj(resultPtr, ustring1, 0); if (mapElemc == 2) { /* * Special case for one map pair which avoids the extra * for loop and extra calls to get Unicode data. The * algorithm is otherwise identical to the multi-pair case. * This will be >30% faster on larger strings. */ int mapLen; Tcl_UniChar *mapString, u2lc; ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); p = ustring1; if ((length2 > length1) || (length2 == 0)) { /* match string is either longer than input or empty */ ustring1 = end; } else { mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); for (; ustring1 < end; ustring1++) { if (((*ustring1 == *ustring2) || (nocase && (Tcl_UniCharToLower(*ustring1) == u2lc))) && ((length2 == 1) || strCmpFn(ustring1, ustring2, (unsigned long) length2) == 0)) { if (p != ustring1) { Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); } } } } else { Tcl_UniChar **mapStrings, *u2lc = NULL; int *mapLens; /* * Precompute pointers to the unicode string and length. * This saves us repeated function calls later, * significantly speeding up the algorithm. We only need * the lowercase first char in the nocase case. */ mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2) * sizeof(Tcl_UniChar *)); mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int)); if (nocase) { u2lc = (Tcl_UniChar *) ckalloc((mapElemc) * sizeof(Tcl_UniChar)); } for (index = 0; index < mapElemc; index++) { mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], &(mapLens[index])); if (nocase && ((index % 2) == 0)) { u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); } } for (p = ustring1; ustring1 < end; ustring1++) { for (index = 0; index < mapElemc; index += 2) { /* * Get the key string to match on. */ ustring2 = mapStrings[index]; length2 = mapLens[index]; if ((length2 > 0) && ((*ustring1 == *ustring2) || (nocase && (Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) && /* restrict max compare length */ ((end - ustring1) >= length2) && ((length2 == 1) || strCmpFn(ustring2, ustring1, (unsigned long) length2) == 0)) { if (p != ustring1) { /* * Put the skipped chars onto the result first */ Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); p = ustring1 + length2; } else { p += length2; } /* * Adjust len to be full length of matched string */ ustring1 = p - 1; /* * Append the map value to the unicode string */ Tcl_AppendUnicodeToObj(resultPtr, mapStrings[index+1], mapLens[index+1]); break; } } } ckfree((char *) mapStrings); ckfree((char *) mapLens); if (nocase) { ckfree((char *) u2lc); } } if (p != ustring1) { /* * Put the rest of the unmapped chars onto result */ Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); } if (copySource) { Tcl_DecrRefCount(sourceObj); } break; } case STR_MATCH: { Tcl_UniChar *ustring1, *ustring2; int nocase = 0; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string"); return TCL_ERROR; } if (objc == 5) { string2 = Tcl_GetStringFromObj(objv[2], &length2); if ((length2 > 1) && strncmp(string2, "-nocase", (size_t) length2) == 0) { nocase = 1; } else { Tcl_AppendStringsToObj(resultPtr, "bad option \"", string2, "\": must be -nocase", (char *) NULL); return TCL_ERROR; } } ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1); ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2); Tcl_SetBooleanObj(resultPtr, TclUniCharMatch(ustring1, length1, ustring2, length2, nocase)); break; } case STR_RANGE: { int first, last; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "string first last"); return TCL_ERROR; } /* * If we have a ByteArray object, avoid indexing in the * Utf string since the byte array contains one byte per * character. Otherwise, use the Unicode string rep to * get the range. */ if (objv[2]->typePtr == &tclByteArrayType) { string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1); length1--; } else { /* * Get the length in actual characters. */ string1 = NULL; length1 = Tcl_GetCharLength(objv[2]) - 1; } if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) || (TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK)) { return TCL_ERROR; } if (first < 0) { first = 0; } if (last >= length1) { last = length1; } if (last >= first) { if (string1 != NULL) { int numBytes = last - first + 1; resultPtr = Tcl_NewByteArrayObj( (unsigned char *) &string1[first], numBytes); Tcl_SetObjResult(interp, resultPtr); } else { Tcl_SetObjResult(interp, Tcl_GetRange(objv[2], first, last)); } } break; } case STR_REPEAT: { int count; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string count"); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) { return TCL_ERROR; } if (count == 1) { Tcl_SetObjResult(interp, objv[2]); } else if (count > 1) { string1 = Tcl_GetStringFromObj(objv[2], &length1); if (length1 > 0) { /* * Only build up a string that has data. Instead of * building it up with repeated appends, we just allocate * the necessary space once and copy the string value in. * Check for overflow with back-division. [Bug #714106] */ length2 = length1 * count; if ((length2 / count) != length1) { char buf[TCL_INTEGER_SPACE+1]; sprintf(buf, "%d", INT_MAX); Tcl_AppendStringsToObj(resultPtr, "string size overflow, must be less than ", buf, (char *) NULL); return TCL_ERROR; } /* * Include space for the NULL */ string2 = (char *) ckalloc((size_t) length2+1); for (index = 0; index < count; index++) { memcpy(string2 + (length1 * index), string1, (size_t) length1); } string2[length2] = '\0'; /* * We have to directly assign this instead of using * Tcl_SetStringObj (and indirectly TclInitStringRep) * because that makes another copy of the data. */ resultPtr = Tcl_NewObj(); resultPtr->bytes = string2; resultPtr->length = length2; Tcl_SetObjResult(interp, resultPtr); } } break; } case STR_REPLACE: { Tcl_UniChar *ustring1; int first, last; if (objc < 5 || objc > 6) { Tcl_WrongNumArgs(interp, 2, objv, "string first last ?string?"); return TCL_ERROR; } ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); length1--; if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) || (TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK)) { return TCL_ERROR; } if ((last < first) || (last < 0) || (first > length1)) { Tcl_SetObjResult(interp, objv[2]); } else { if (first < 0) { first = 0; } Tcl_SetUnicodeObj(resultPtr, ustring1, first); if (objc == 6) { Tcl_AppendObjToObj(resultPtr, objv[5]); } if (last < length1) { Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1, length1 - last); } } break; } case STR_TOLOWER: case STR_TOUPPER: case STR_TOTITLE: if (objc < 3 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?"); return TCL_ERROR; } string1 = Tcl_GetStringFromObj(objv[2], &length1); if (objc == 3) { /* * Since the result object is not a shared object, it is * safe to copy the string into the result and do the * conversion in place. The conversion may change the length * of the string, so reset the length after conversion. */ Tcl_SetStringObj(resultPtr, string1, length1); if ((enum options) index == STR_TOLOWER) { length1 = Tcl_UtfToLower(Tcl_GetString(resultPtr)); } else if ((enum options) index == STR_TOUPPER) { length1 = Tcl_UtfToUpper(Tcl_GetString(resultPtr)); } else { length1 = Tcl_UtfToTitle(Tcl_GetString(resultPtr)); } Tcl_SetObjLength(resultPtr, length1); } else { int first, last; CONST char *start, *end; length1 = Tcl_NumUtfChars(string1, length1) - 1; if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) { return TCL_ERROR; } if (first < 0) { first = 0; } last = first; if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK)) { return TCL_ERROR; } if (last >= length1) { last = length1; } if (last < first) { Tcl_SetObjResult(interp, objv[2]); break; } start = Tcl_UtfAtIndex(string1, first); end = Tcl_UtfAtIndex(start, last - first + 1); length2 = end-start; string2 = ckalloc((size_t) length2+1); memcpy(string2, start, (size_t) length2); string2[length2] = '\0'; if ((enum options) index == STR_TOLOWER) { length2 = Tcl_UtfToLower(string2); } else if ((enum options) index == STR_TOUPPER) { length2 = Tcl_UtfToUpper(string2); } else { length2 = Tcl_UtfToTitle(string2); } Tcl_SetStringObj(resultPtr, string1, start - string1); Tcl_AppendToObj(resultPtr, string2, length2); Tcl_AppendToObj(resultPtr, end, -1); ckfree(string2); } break; case STR_TRIM: { Tcl_UniChar ch, trim; register CONST char *p, *end; char *check, *checkEnd; int offset; left = 1; right = 1; dotrim: if (objc == 4) { string2 = Tcl_GetStringFromObj(objv[3], &length2); } else if (objc == 3) { string2 = " \t\n\r"; length2 = strlen(string2); } else { Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?"); return TCL_ERROR; } string1 = Tcl_GetStringFromObj(objv[2], &length1); checkEnd = string2 + length2; if (left) { end = string1 + length1; /* * The outer loop iterates over the string. The inner * loop iterates over the trim characters. The loops * terminate as soon as a non-trim character is discovered * and string1 is left pointing at the first non-trim * character. */ for (p = string1; p < end; p += offset) { offset = TclUtfToUniChar(p, &ch); for (check = string2; ; ) { if (check >= checkEnd) { p = end; break; } check += TclUtfToUniChar(check, &trim); if (ch == trim) { length1 -= offset; string1 += offset; break; } } } } if (right) { end = string1; /* * The outer loop iterates over the string. The inner * loop iterates over the trim characters. The loops * terminate as soon as a non-trim character is discovered * and length1 marks the last non-trim character. */ for (p = string1 + length1; p > end; ) { p = Tcl_UtfPrev(p, string1); offset = TclUtfToUniChar(p, &ch); for (check = string2; ; ) { if (check >= checkEnd) { p = end; break; } check += TclUtfToUniChar(check, &trim); if (ch == trim) { length1 -= offset; break; } } } } Tcl_SetStringObj(resultPtr, string1, length1); break; } case STR_TRIMLEFT: { left = 1; right = 0; goto dotrim; } case STR_TRIMRIGHT: { left = 0; right = 1; goto dotrim; } case STR_WORDEND: { int cur; Tcl_UniChar ch; CONST char *p, *end; int numChars; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string index"); return TCL_ERROR; } string1 = Tcl_GetStringFromObj(objv[2], &length1); numChars = Tcl_NumUtfChars(string1, length1); if (TclGetIntForIndex(interp, objv[3], numChars-1, &index) != TCL_OK) { return TCL_ERROR; } if (index < 0) { index = 0; } if (index < numChars) { p = Tcl_UtfAtIndex(string1, index); end = string1+length1; for (cur = index; p < end; cur++) { p += TclUtfToUniChar(p, &ch); if (!Tcl_UniCharIsWordChar(ch)) { break; } } if (cur == index) { cur++; } } else { cur = numChars; } Tcl_SetIntObj(resultPtr, cur); break; } case STR_WORDSTART: { int cur; Tcl_UniChar ch; CONST char *p; int numChars; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string index"); return TCL_ERROR; } string1 = Tcl_GetStringFromObj(objv[2], &length1); numChars = Tcl_NumUtfChars(string1, length1); if (TclGetIntForIndex(interp, objv[3], numChars-1, &index) != TCL_OK) { return TCL_ERROR; } if (index >= numChars) { index = numChars - 1; } cur = 0; if (index > 0) { p = Tcl_UtfAtIndex(string1, index); for (cur = index; cur >= 0; cur--) { TclUtfToUniChar(p, &ch); if (!Tcl_UniCharIsWordChar(ch)) { break; } p = Tcl_UtfPrev(p, string1); } if (cur != index) { cur += 1; } } Tcl_SetIntObj(resultPtr, cur); break; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SubstObjCmd -- * * This procedure is invoked to process the "subst" Tcl command. * See the user documentation for details on what it does. This * command relies on Tcl_SubstObj() for its implementation. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_SubstObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *substOptions[] = { "-nobackslashes", "-nocommands", "-novariables", (char *) NULL }; enum substOptions { SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS }; Tcl_Obj *resultPtr; int optionIndex, flags, i; /* * Parse command-line options. */ flags = TCL_SUBST_ALL; for (i = 1; i < (objc-1); i++) { if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch (optionIndex) { case SUBST_NOBACKSLASHES: { flags &= ~TCL_SUBST_BACKSLASHES; break; } case SUBST_NOCOMMANDS: { flags &= ~TCL_SUBST_COMMANDS; break; } case SUBST_NOVARS: { flags &= ~TCL_SUBST_VARIABLES; break; } default: { panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); } } } if (i != (objc-1)) { Tcl_WrongNumArgs(interp, 1, objv, "?-nobackslashes? ?-nocommands? ?-novariables? string"); return TCL_ERROR; } /* * Perform the substitution. */ resultPtr = Tcl_SubstObj(interp, objv[i], flags); if (resultPtr == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SubstObj -- * * This function performs the substitutions specified on the * given string as described in the user documentation for the * "subst" Tcl command. This code is heavily based on an * implementation by Andrew Payne. Note that if a command * substitution returns TCL_CONTINUE or TCL_RETURN from its * evaluation and is not completely well-formed, the results are * not defined (or at least hard to characterise.) This fault * will be fixed at some point, but the cost of the only sane * fix (well-formedness check first) is such that you need to * "precompile and cache" to stop everyone from being hit with * the consequences every time through. Note that the current * behaviour is not a security hole; it just restarts parsing * the string following the substitution in a mildly surprising * place, and it is a very bad idea to count on this remaining * the same in future... * * Results: * A Tcl_Obj* containing the substituted string, or NULL to * indicate that an error occurred. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_SubstObj(interp, objPtr, flags) Tcl_Interp *interp; Tcl_Obj *objPtr; int flags; { Tcl_Obj *resultObj; char *p, *old; int length; old = p = Tcl_GetStringFromObj(objPtr, &length); resultObj = Tcl_NewStringObj("", 0); while (length) { switch (*p) { case '\\': if (flags & TCL_SUBST_BACKSLASHES) { char buf[TCL_UTF_MAX]; int count; if (p != old) { Tcl_AppendToObj(resultObj, old, p-old); } Tcl_AppendToObj(resultObj, buf, Tcl_UtfBackslash(p, &count, buf)); p += count; length -= count; old = p; } else { p++; length--; } break; case '$': if (flags & TCL_SUBST_VARIABLES) { Tcl_Parse parse; int code; /* * Code is simpler overall if we (effectively) inline * Tcl_ParseVar, particularly as that allows us to use * a non-string interface when we come to appending * the variable contents to the result object. There * are a few other optimisations that doing this * enables (like being able to continue the run of * unsubstituted characters straight through if a '$' * does not precede a variable name.) */ if (Tcl_ParseVarName(interp, p, -1, &parse, 0) != TCL_OK) { goto errorResult; } if (parse.numTokens == 1) { /* * There isn't a variable name after all: the $ is * just a $. */ p++; length--; break; } if (p != old) { Tcl_AppendToObj(resultObj, old, p-old); } p += parse.tokenPtr->size; length -= parse.tokenPtr->size; code = Tcl_EvalTokensStandard(interp, parse.tokenPtr, parse.numTokens); if (code == TCL_ERROR) { goto errorResult; } if (code == TCL_BREAK) { Tcl_ResetResult(interp); return resultObj; } if (code != TCL_CONTINUE) { Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp)); } Tcl_ResetResult(interp); old = p; } else { p++; length--; } break; case '[': if (flags & TCL_SUBST_COMMANDS) { Interp *iPtr = (Interp *) interp; int code; if (p != old) { Tcl_AppendToObj(resultObj, old, p-old); } iPtr->evalFlags = TCL_BRACKET_TERM; iPtr->numLevels++; code = TclInterpReady(interp); if (code == TCL_OK) { code = Tcl_EvalEx(interp, p+1, -1, 0); } iPtr->numLevels--; switch (code) { case TCL_ERROR: goto errorResult; case TCL_BREAK: Tcl_ResetResult(interp); return resultObj; default: Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp)); case TCL_CONTINUE: Tcl_ResetResult(interp); old = p = (p+1 + iPtr->termOffset + 1); length -= (iPtr->termOffset + 2); } } else { p++; length--; } break; default: p++; length--; break; } } if (p != old) { Tcl_AppendToObj(resultObj, old, p-old); } return resultObj; errorResult: Tcl_DecrRefCount(resultObj); return NULL; } /* *---------------------------------------------------------------------- * * Tcl_SwitchObjCmd -- * * This object-based procedure is invoked to process the "switch" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_SwitchObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int i, j, index, mode, matched, result, splitObjs; char *string, *pattern; Tcl_Obj *stringObj; Tcl_Obj *CONST *savedObjv = objv; static CONST char *options[] = { "-exact", "-glob", "-regexp", "--", NULL }; enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST }; mode = OPT_EXACT; for (i = 1; i < objc; i++) { string = Tcl_GetString(objv[i]); if (string[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } if (index == OPT_LAST) { i++; break; } mode = index; } if (objc - i < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? string pattern body ... ?default body?"); return TCL_ERROR; } stringObj = objv[i]; objc -= i + 1; objv += i + 1; /* * If all of the pattern/command pairs are lumped into a single * argument, split them out again. */ splitObjs = 0; if (objc == 1) { Tcl_Obj **listv; if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { return TCL_ERROR; } /* * Ensure that the list is non-empty. */ if (objc < 1) { Tcl_WrongNumArgs(interp, 1, savedObjv, "?switches? string {pattern body ... ?default body?}"); return TCL_ERROR; } objv = listv; splitObjs = 1; } /* * Complain if there is an odd number of words in the list of * patterns and bodies. */ if (objc % 2) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); /* * Check if this can be due to a badly placed comment * in the switch block. * * The following is an heuristic to detect the infamous * "comment in switch" error: just check if a pattern * begins with '#'. */ if (splitObjs) { for (i=0 ; i= objc) { /* * This shouldn't happen since we've checked that the * last body is not a continuation... */ panic("fall-out when searching for body to match pattern"); } if (strcmp(Tcl_GetString(objv[j]), "-") != 0) { break; } } result = Tcl_EvalObjEx(interp, objv[j], 0); if (result == TCL_ERROR) { char msg[100 + TCL_INTEGER_SPACE]; sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern, interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); } return result; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_TimeObjCmd -- * * This object-based procedure is invoked to process the "time" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_TimeObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { register Tcl_Obj *objPtr; register int i, result; int count; double totalMicroSec; Tcl_Time start, stop; char buf[100]; if (objc == 2) { count = 1; } else if (objc == 3) { result = Tcl_GetIntFromObj(interp, objv[2], &count); if (result != TCL_OK) { return result; } } else { Tcl_WrongNumArgs(interp, 1, objv, "command ?count?"); return TCL_ERROR; } objPtr = objv[1]; i = count; Tcl_GetTime(&start); while (i-- > 0) { result = Tcl_EvalObjEx(interp, objPtr, 0); if (result != TCL_OK) { return result; } } Tcl_GetTime(&stop); totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6 + ( stop.usec - start.usec ) ); sprintf(buf, "%.0f microseconds per iteration", ((count <= 0) ? 0 : totalMicroSec/count)); Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_TraceObjCmd -- * * This procedure is invoked to process the "trace" Tcl command. * See the user documentation for details on what it does. * * Standard syntax as of Tcl 8.4 is * * trace {add|info|remove} {command|variable} name ops cmd * * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_TraceObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int optionIndex; char *name, *flagOps, *p; /* Main sub commands to 'trace' */ static CONST char *traceOptions[] = { "add", "info", "remove", #ifndef TCL_REMOVE_OBSOLETE_TRACES "variable", "vdelete", "vinfo", #endif (char *) NULL }; /* 'OLD' options are pre-Tcl-8.4 style */ enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE, #ifndef TCL_REMOVE_OBSOLETE_TRACES TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO #endif }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum traceOptions) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: case TRACE_INFO: { /* * All sub commands of trace add/remove must take at least * one more argument. Beyond that we let the subcommand itself * control the argument structure. */ int typeIndex; if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, "option", 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); } #ifndef TCL_REMOVE_OBSOLETE_TRACES case TRACE_OLD_VARIABLE: case TRACE_OLD_VDELETE: { Tcl_Obj *copyObjv[6]; Tcl_Obj *opsList; int code, numFlags; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); return TCL_ERROR; } opsList = Tcl_NewObj(); Tcl_IncrRefCount(opsList); flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); if (numFlags == 0) { Tcl_DecrRefCount(opsList); goto badVarOps; } for (p = flagOps; *p != 0; p++) { if (*p == 'r') { Tcl_ListObjAppendElement(NULL, opsList, Tcl_NewStringObj("read", -1)); } else if (*p == 'w') { Tcl_ListObjAppendElement(NULL, opsList, Tcl_NewStringObj("write", -1)); } else if (*p == 'u') { Tcl_ListObjAppendElement(NULL, opsList, Tcl_NewStringObj("unset", -1)); } else if (*p == 'a') { Tcl_ListObjAppendElement(NULL, opsList, Tcl_NewStringObj("array", -1)); } else { Tcl_DecrRefCount(opsList); goto badVarOps; } } copyObjv[0] = NULL; memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *)); copyObjv[4] = opsList; if (optionIndex == TRACE_OLD_VARIABLE) { code = (traceSubCmds[2])(interp,TRACE_ADD,objc+1,copyObjv); } else { code = (traceSubCmds[2])(interp,TRACE_REMOVE,objc+1,copyObjv); } Tcl_DecrRefCount(opsList); return code; } case TRACE_OLD_VINFO: { ClientData clientData; char ops[5]; Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "name"); return TCL_ERROR; } resultListPtr = Tcl_GetObjResult(interp); clientData = 0; name = Tcl_GetString(objv[2]); while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, clientData)) != 0) { TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); p = ops; if (tvarPtr->flags & TCL_TRACE_READS) { *p = 'r'; p++; } if (tvarPtr->flags & TCL_TRACE_WRITES) { *p = 'w'; p++; } if (tvarPtr->flags & TCL_TRACE_UNSETS) { *p = 'u'; p++; } if (tvarPtr->flags & TCL_TRACE_ARRAY) { *p = 'a'; p++; } *p = '\0'; /* * Build a pair (2-item list) with the ops string as * the first obj element and the tvarPtr->command string * as the second obj element. Append the pair (as an * element) to the end of the result object list. */ elemObjPtr = Tcl_NewStringObj(ops, -1); Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr); } Tcl_SetObjResult(interp, resultListPtr); break; } #endif /* TCL_REMOVE_OBSOLETE_TRACES */ } return TCL_OK; badVarOps: Tcl_AppendResult(interp, "bad operations \"", flagOps, "\": should be one or more of rwua", (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TclTraceExecutionObjCmd -- * * Helper function for Tcl_TraceObjCmd; implements the * [trace {add|remove|info} execution ...] subcommands. * See the user documentation for details on what these do. * * Results: * Standard Tcl result. * * Side effects: * Depends on the operation (add, remove, or info) being performed; * may add or remove command traces on a command. * *---------------------------------------------------------------------- */ int TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) Tcl_Interp *interp; /* Current interpreter. */ int optionIndex; /* Add, info or remove */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int commandLength, index; char *name, *command; size_t length; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; static CONST char *opStrings[] = { "enter", "leave", "enterstep", "leavestep", (char *) NULL }; enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE, TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP }; switch ((enum traceOptions) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { int flags = 0; int i, listLen, result; Tcl_Obj **elemPtrs; if (objc != 6) { Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); return TCL_ERROR; } /* * Make sure the ops argument is a list object; get its length and * a pointer to its array of element pointers. */ result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } if (listLen == 0) { Tcl_SetResult(interp, "bad operation list \"\": must be " "one or more of enter, leave, enterstep, or leavestep", TCL_STATIC); return TCL_ERROR; } for (i = 0; i < listLen; i++) { if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, "operation", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum operations) index) { case TRACE_EXEC_ENTER: flags |= TCL_TRACE_ENTER_EXEC; break; case TRACE_EXEC_LEAVE: flags |= TCL_TRACE_LEAVE_EXEC; break; case TRACE_EXEC_ENTER_STEP: flags |= TCL_TRACE_ENTER_DURING_EXEC; break; case TRACE_EXEC_LEAVE_STEP: flags |= TCL_TRACE_LEAVE_DURING_EXEC; break; } } command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr; tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) + length + 1)); tcmdPtr->flags = flags; tcmdPtr->stepTrace = NULL; tcmdPtr->startLevel = 0; tcmdPtr->startCmd = NULL; tcmdPtr->length = length; tcmdPtr->refCount = 1; flags |= TCL_TRACE_DELETE; if (flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC)) { flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); } strcpy(tcmdPtr->command, command); name = Tcl_GetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, (ClientData) tcmdPtr) != TCL_OK) { ckfree((char *) tcmdPtr); return TCL_ERROR; } } else { /* * Search through all of our traces on this command to * see if there's one with the given command. If so, then * delete the first one that matches. */ TraceCommandInfo *tcmdPtr; ClientData clientData = NULL; name = Tcl_GetString(objv[3]); /* First ensure the name given is valid */ if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, TraceCommandProc, clientData)) != NULL) { tcmdPtr = (TraceCommandInfo *) clientData; /* * In checking the 'flags' field we must remove any * extraneous flags which may have been temporarily * added by various pieces of the trace mechanism. */ if ((tcmdPtr->length == length) && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | TCL_TRACE_RENAME | TCL_TRACE_DELETE)) == flags) && (strncmp(command, tcmdPtr->command, (size_t) length) == 0)) { flags |= TCL_TRACE_DELETE; if (flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC)) { flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); } Tcl_UntraceCommand(interp, name, flags, TraceCommandProc, clientData); if (tcmdPtr->stepTrace != NULL) { /* * We need to remove the interpreter-wide trace * which we created to allow 'step' traces. */ Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { ckfree((char *)tcmdPtr->startCmd); } } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { /* Postpone deletion */ tcmdPtr->flags = 0; } tcmdPtr->refCount--; if (tcmdPtr->refCount < 0) { Tcl_Panic("TclTraceExecutionObjCmd: negative TraceCommandInfo refCount"); } if (tcmdPtr->refCount == 0) { ckfree((char*)tcmdPtr); } break; } } } break; } case TRACE_INFO: { ClientData clientData; Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "name"); return TCL_ERROR; } clientData = NULL; name = Tcl_GetString(objv[3]); /* First ensure the name given is valid */ if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, TraceCommandProc, clientData)) != NULL) { int numOps = 0; TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; /* * Build a list with the ops list as the first obj * element and the tcmdPtr->command string as the * second obj element. Append this list (as an * element) to the end of the result object list. */ elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_IncrRefCount(elemObjPtr); if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("enter",5)); } if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("leave",5)); } if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("enterstep",9)); } if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("leavestep",9)); } Tcl_ListObjLength(NULL, elemObjPtr, &numOps); if (0 == numOps) { Tcl_DecrRefCount(elemObjPtr); continue; } eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); Tcl_DecrRefCount(elemObjPtr); elemObjPtr = NULL; Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, Tcl_NewStringObj(tcmdPtr->command, -1)); Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); } Tcl_SetObjResult(interp, resultListPtr); break; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclTraceCommandObjCmd -- * * Helper function for Tcl_TraceObjCmd; implements the * [trace {add|info|remove} command ...] subcommands. * See the user documentation for details on what these do. * * Results: * Standard Tcl result. * * Side effects: * Depends on the operation (add, remove, or info) being performed; * may add or remove command traces on a command. * *---------------------------------------------------------------------- */ int TclTraceCommandObjCmd(interp, optionIndex, objc, objv) Tcl_Interp *interp; /* Current interpreter. */ int optionIndex; /* Add, info or remove */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int commandLength, index; char *name, *command; size_t length; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; static CONST char *opStrings[] = { "delete", "rename", (char *) NULL }; enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; switch ((enum traceOptions) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { int flags = 0; int i, listLen, result; Tcl_Obj **elemPtrs; if (objc != 6) { Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); return TCL_ERROR; } /* * Make sure the ops argument is a list object; get its length and * a pointer to its array of element pointers. */ result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } if (listLen == 0) { Tcl_SetResult(interp, "bad operation list \"\": must be " "one or more of delete or rename", TCL_STATIC); return TCL_ERROR; } for (i = 0; i < listLen; i++) { if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, "operation", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum operations) index) { case TRACE_CMD_RENAME: flags |= TCL_TRACE_RENAME; break; case TRACE_CMD_DELETE: flags |= TCL_TRACE_DELETE; break; } } command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr; tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) + length + 1)); tcmdPtr->flags = flags; tcmdPtr->stepTrace = NULL; tcmdPtr->startLevel = 0; tcmdPtr->startCmd = NULL; tcmdPtr->length = length; tcmdPtr->refCount = 1; flags |= TCL_TRACE_DELETE; strcpy(tcmdPtr->command, command); name = Tcl_GetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, (ClientData) tcmdPtr) != TCL_OK) { ckfree((char *) tcmdPtr); return TCL_ERROR; } } else { /* * Search through all of our traces on this command to * see if there's one with the given command. If so, then * delete the first one that matches. */ TraceCommandInfo *tcmdPtr; ClientData clientData = NULL; name = Tcl_GetString(objv[3]); /* First ensure the name given is valid */ if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, TraceCommandProc, clientData)) != NULL) { tcmdPtr = (TraceCommandInfo *) clientData; if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags) && (strncmp(command, tcmdPtr->command, (size_t) length) == 0)) { Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, TraceCommandProc, clientData); tcmdPtr->flags |= TCL_TRACE_DESTROYED; tcmdPtr->refCount--; if (tcmdPtr->refCount < 0) { Tcl_Panic("TclTraceCommandObjCmd: negative TraceCommandInfo refCount"); } if (tcmdPtr->refCount == 0) { ckfree((char *) tcmdPtr); } break; } } } break; } case TRACE_INFO: { ClientData clientData; Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "name"); return TCL_ERROR; } clientData = NULL; name = Tcl_GetString(objv[3]); /* First ensure the name given is valid */ if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, TraceCommandProc, clientData)) != NULL) { int numOps = 0; TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; /* * Build a list with the ops list as * the first obj element and the tcmdPtr->command string * as the second obj element. Append this list (as an * element) to the end of the result object list. */ elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_IncrRefCount(elemObjPtr); if (tcmdPtr->flags & TCL_TRACE_RENAME) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("rename",6)); } if (tcmdPtr->flags & TCL_TRACE_DELETE) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("delete",6)); } Tcl_ListObjLength(NULL, elemObjPtr, &numOps); if (0 == numOps) { Tcl_DecrRefCount(elemObjPtr); continue; } eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); Tcl_DecrRefCount(elemObjPtr); elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); } Tcl_SetObjResult(interp, resultListPtr); break; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclTraceVariableObjCmd -- * * Helper function for Tcl_TraceObjCmd; implements the * [trace {add|info|remove} variable ...] subcommands. * See the user documentation for details on what these do. * * Results: * Standard Tcl result. * * Side effects: * Depends on the operation (add, remove, or info) being performed; * may add or remove variable traces on a variable. * *---------------------------------------------------------------------- */ int TclTraceVariableObjCmd(interp, optionIndex, objc, objv) Tcl_Interp *interp; /* Current interpreter. */ int optionIndex; /* Add, info or remove */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int commandLength, index; char *name, *command; size_t length; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; static CONST char *opStrings[] = { "array", "read", "unset", "write", (char *) NULL }; enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, TRACE_VAR_WRITE }; switch ((enum traceOptions) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { int flags = 0; int i, listLen, result; Tcl_Obj **elemPtrs; if (objc != 6) { Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); return TCL_ERROR; } /* * Make sure the ops argument is a list object; get its length and * a pointer to its array of element pointers. */ result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } if (listLen == 0) { Tcl_SetResult(interp, "bad operation list \"\": must be " "one or more of array, read, unset, or write", TCL_STATIC); return TCL_ERROR; } for (i = 0; i < listLen ; i++) { if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, "operation", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum operations) index) { case TRACE_VAR_ARRAY: flags |= TCL_TRACE_ARRAY; break; case TRACE_VAR_READ: flags |= TCL_TRACE_READS; break; case TRACE_VAR_UNSET: flags |= TCL_TRACE_UNSETS; break; case TRACE_VAR_WRITE: flags |= TCL_TRACE_WRITES; break; } } command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceVarInfo *tvarPtr; tvarPtr = (TraceVarInfo *) ckalloc((unsigned) (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); tvarPtr->flags = flags; if (objv[0] == NULL) { tvarPtr->flags |= TCL_TRACE_OLD_STYLE; } tvarPtr->length = length; flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; strcpy(tvarPtr->command, command); name = Tcl_GetString(objv[3]); if (Tcl_TraceVar(interp, name, flags, TraceVarProc, (ClientData) tvarPtr) != TCL_OK) { ckfree((char *) tvarPtr); return TCL_ERROR; } } else { /* * Search through all of our traces on this variable to * see if there's one with the given command. If so, then * delete the first one that matches. */ TraceVarInfo *tvarPtr; ClientData clientData = 0; name = Tcl_GetString(objv[3]); while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, clientData)) != 0) { tvarPtr = (TraceVarInfo *) clientData; if ((tvarPtr->length == length) && ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags) && (strncmp(command, tvarPtr->command, (size_t) length) == 0)) { Tcl_UntraceVar2(interp, name, NULL, flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, TraceVarProc, clientData); Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); break; } } } break; } case TRACE_INFO: { ClientData clientData; Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "name"); return TCL_ERROR; } resultListPtr = Tcl_GetObjResult(interp); clientData = 0; name = Tcl_GetString(objv[3]); while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, clientData)) != 0) { TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; /* * Build a list with the ops list as * the first obj element and the tcmdPtr->command string * as the second obj element. Append this list (as an * element) to the end of the result object list. */ elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); if (tvarPtr->flags & TCL_TRACE_ARRAY) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("array", 5)); } if (tvarPtr->flags & TCL_TRACE_READS) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("read", 4)); } if (tvarPtr->flags & TCL_TRACE_WRITES) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("write", 5)); } if (tvarPtr->flags & TCL_TRACE_UNSETS) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("unset", 5)); } eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); } Tcl_SetObjResult(interp, resultListPtr); break; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_CommandTraceInfo -- * * Return the clientData value associated with a trace on a * command. This procedure can also be used to step through * all of the traces on a particular command that have the * same trace procedure. * * Results: * The return value is the clientData value associated with * a trace on the given command. Information will only be * returned for a trace with proc as trace procedure. If * the clientData argument is NULL then the first such trace is * returned; otherwise, the next relevant one after the one * given by clientData will be returned. If the command * doesn't exist then an error message is left in the interpreter * and NULL is returned. Also, if there are no (more) traces for * the given command, NULL is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ ClientData Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData) Tcl_Interp *interp; /* Interpreter containing command. */ CONST char *cmdName; /* Name of command. */ int flags; /* OR-ed combo or TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY (can be 0). */ Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ ClientData prevClientData; /* If non-NULL, gives last value returned * by this procedure, so this call will * return the next trace after that one. * If NULL, this call will return the * first trace. */ { Command *cmdPtr; register CommandTrace *tracePtr; cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return NULL; } /* * Find the relevant trace, if any, and return its clientData. */ tracePtr = cmdPtr->tracePtr; if (prevClientData != NULL) { for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { if ((tracePtr->clientData == prevClientData) && (tracePtr->traceProc == proc)) { tracePtr = tracePtr->nextPtr; break; } } } for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { if (tracePtr->traceProc == proc) { return tracePtr->clientData; } } return NULL; } /* *---------------------------------------------------------------------- * * Tcl_TraceCommand -- * * Arrange for rename/deletes to a command to cause a * procedure to be invoked, which can monitor the operations. * * Also optionally arrange for execution of that command * to cause a procedure to be invoked. * * Results: * A standard Tcl return value. * * Side effects: * A trace is set up on the command given by cmdName, such that * future changes to the command will be intermediated by * proc. See the manual entry for complete details on the calling * sequence for proc. * *---------------------------------------------------------------------- */ int Tcl_TraceCommand(interp, cmdName, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter in which command is * to be traced. */ CONST char *cmdName; /* Name of command. */ int flags; /* OR-ed collection of bits, including any * of TCL_TRACE_RENAME, TCL_TRACE_DELETE, * and any of the TRACE_*_EXEC flags */ Tcl_CommandTraceProc *proc; /* Procedure to call when specified ops are * invoked upon varName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { Command *cmdPtr; register CommandTrace *tracePtr; cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return TCL_ERROR; } /* * Set up trace information. */ tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); tracePtr->nextPtr = cmdPtr->tracePtr; tracePtr->refCount = 1; cmdPtr->tracePtr = tracePtr; if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { cmdPtr->flags |= CMD_HAS_EXEC_TRACES; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_UntraceCommand -- * * Remove a previously-created trace for a command. * * Results: * None. * * Side effects: * If there exists a trace for the command given by cmdName * with the given flags, proc, and clientData, then that trace * is removed. * *---------------------------------------------------------------------- */ void Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter containing command. */ CONST char *cmdName; /* Name of command. */ int flags; /* OR-ed collection of bits, including any * of TCL_TRACE_RENAME, TCL_TRACE_DELETE, * and any of the TRACE_*_EXEC flags */ Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { register CommandTrace *tracePtr; CommandTrace *prevPtr; Command *cmdPtr; Interp *iPtr = (Interp *) interp; ActiveCommandTrace *activePtr; int hasExecTraces = 0; cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return; } flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { return; } if ((tracePtr->traceProc == proc) && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC)) == flags) && (tracePtr->clientData == clientData)) { if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { hasExecTraces = 1; } break; } } /* * The code below makes it possible to delete traces while traces * are active: it makes sure that the deleted trace won't be * processed by CallCommandTraces. */ for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->nextTracePtr == tracePtr) { activePtr->nextTracePtr = tracePtr->nextPtr; } } if (prevPtr == NULL) { cmdPtr->tracePtr = tracePtr->nextPtr; } else { prevPtr->nextPtr = tracePtr->nextPtr; } tracePtr->flags = 0; if ((--tracePtr->refCount) <= 0) { ckfree((char*)tracePtr); } if (hasExecTraces) { for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { return; } } /* * None of the remaining traces on this command are execution * traces. We therefore remove this flag: */ cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES; } } /* *---------------------------------------------------------------------- * * TraceCommandProc -- * * This procedure is called to handle command changes that have * been traced using the "trace" command, when using the * 'rename' or 'delete' options. * * Results: * None. * * Side effects: * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void TraceCommandProc(clientData, interp, oldName, newName, flags) ClientData clientData; /* Information about the command trace. */ Tcl_Interp *interp; /* Interpreter containing command. */ CONST char *oldName; /* Name of command being changed. */ CONST char *newName; /* New name of command. Empty string * or NULL means command is being deleted * (renamed to ""). */ int flags; /* OR-ed bits giving operation and other * information. */ { Interp *iPtr = (Interp *) interp; int stateCode; Tcl_SavedResult state; TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; int code; Tcl_DString cmd; tcmdPtr->refCount++; if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { /* * Generate a command to execute by appending list elements * for the old and new command name and the operation. */ Tcl_DStringInit(&cmd); Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); Tcl_DStringAppendElement(&cmd, oldName); Tcl_DStringAppendElement(&cmd, (newName ? newName : "")); if (flags & TCL_TRACE_RENAME) { Tcl_DStringAppend(&cmd, " rename", 7); } else if (flags & TCL_TRACE_DELETE) { Tcl_DStringAppend(&cmd, " delete", 7); } /* * Execute the command. Save the interp's result used for the * command, including the value of iPtr->returnCode which may be * modified when Tcl_Eval is invoked. We discard any object * result the command returns. * * Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to * other areas that this will be destroyed by us, otherwise a * double-free might occur depending on what the eval does. */ Tcl_SaveResult(interp, &state); stateCode = iPtr->returnCode; if (flags & TCL_TRACE_DESTROYED) { tcmdPtr->flags |= TCL_TRACE_DESTROYED; } code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd), 0); if (code != TCL_OK) { /* We ignore errors in these traced commands */ } Tcl_RestoreResult(interp, &state); iPtr->returnCode = stateCode; Tcl_DStringFree(&cmd); } /* * We delete when the trace was destroyed or if this is a delete trace, * because command deletes are unconditional, so the trace must go away. */ if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) { int untraceFlags = tcmdPtr->flags; if (tcmdPtr->stepTrace != NULL) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { ckfree((char *)tcmdPtr->startCmd); } } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { /* Postpone deletion, until exec trace returns */ tcmdPtr->flags = 0; } /* * We need to construct the same flags for Tcl_UntraceCommand * as were passed to Tcl_TraceCommand. Reproduce the processing * of [trace add execution/command]. Be careful to keep this * code in sync with that. */ if (untraceFlags & TCL_TRACE_ANY_EXEC) { untraceFlags |= TCL_TRACE_DELETE; if (untraceFlags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC)) { untraceFlags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); } } else if (untraceFlags & TCL_TRACE_RENAME) { untraceFlags |= TCL_TRACE_DELETE; } /* * Remove the trace since TCL_TRACE_DESTROYED tells us to, or the * command we're tracing has just gone away. Then decrement the * clientData refCount that was set up by trace creation. */ Tcl_UntraceCommand(interp, oldName, untraceFlags, TraceCommandProc, clientData); tcmdPtr->refCount--; } tcmdPtr->refCount--; if (tcmdPtr->refCount < 0) { Tcl_Panic("TraceCommandProc: negative TraceCommandInfo refCount"); } if (tcmdPtr->refCount == 0) { ckfree((char*)tcmdPtr); } return; } /* *---------------------------------------------------------------------- * * TclCheckExecutionTraces -- * * Checks on all current command execution traces, and invokes * procedures which have been registered. This procedure can be * used by other code which performs execution to unify the * tracing system, so that execution traces will function for that * other code. * * For instance extensions like [incr Tcl] which use their * own execution technique can make use of Tcl's tracing. * * This procedure is called by 'TclEvalObjvInternal' * * Results: * The return value is a standard Tcl completion code such as * TCL_OK or TCL_ERROR, etc. * * Side effects: * Those side effects made by any trace procedures called. * *---------------------------------------------------------------------- */ int TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, objv) Tcl_Interp *interp; /* The current interpreter. */ CONST char *command; /* Pointer to beginning of the current * command string. */ int numChars; /* The number of characters in 'command' * which are part of the command string. */ Command *cmdPtr; /* Points to command's Command struct. */ int code; /* The current result code. */ int traceFlags; /* Current tracing situation. */ int objc; /* Number of arguments for the command. */ Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; CommandTrace *tracePtr, *lastTracePtr; ActiveCommandTrace active; int curLevel; int traceCode = TCL_OK; TraceCommandInfo* tcmdPtr; if (command == NULL || cmdPtr->tracePtr == NULL) { return traceCode; } curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level); active.nextPtr = iPtr->activeCmdTracePtr; iPtr->activeCmdTracePtr = &active; active.cmdPtr = cmdPtr; lastTracePtr = NULL; for (tracePtr = cmdPtr->tracePtr; (traceCode == TCL_OK) && (tracePtr != NULL); tracePtr = active.nextTracePtr) { if (traceFlags & TCL_TRACE_LEAVE_EXEC) { /* execute the trace command in order of creation for "leave" */ active.nextTracePtr = NULL; tracePtr = cmdPtr->tracePtr; while (tracePtr->nextPtr != lastTracePtr) { active.nextTracePtr = tracePtr; tracePtr = tracePtr->nextPtr; } } else { active.nextTracePtr = tracePtr->nextPtr; } tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; if (tcmdPtr->flags != 0) { tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; tcmdPtr->curCode = code; tcmdPtr->refCount++; traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, curLevel, command, (Tcl_Command)cmdPtr, objc, objv); tcmdPtr->refCount--; if (tcmdPtr->refCount < 0) { Tcl_Panic("TclCheckExecutionTraces: negative TraceCommandInfo refCount"); } if (tcmdPtr->refCount == 0) { ckfree((char*)tcmdPtr); } } lastTracePtr = tracePtr; } iPtr->activeCmdTracePtr = active.nextPtr; return(traceCode); } /* *---------------------------------------------------------------------- * * TclCheckInterpTraces -- * * Checks on all current traces, and invokes procedures which * have been registered. This procedure can be used by other * code which performs execution to unify the tracing system. * For instance extensions like [incr Tcl] which use their * own execution technique can make use of Tcl's tracing. * * This procedure is called by 'TclEvalObjvInternal' * * Results: * The return value is a standard Tcl completion code such as * TCL_OK or TCL_ERROR, etc. * * Side effects: * Those side effects made by any trace procedures called. * *---------------------------------------------------------------------- */ int TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, objv) Tcl_Interp *interp; /* The current interpreter. */ CONST char *command; /* Pointer to beginning of the current * command string. */ int numChars; /* The number of characters in 'command' * which are part of the command string. */ Command *cmdPtr; /* Points to command's Command struct. */ int code; /* The current result code. */ int traceFlags; /* Current tracing situation. */ int objc; /* Number of arguments for the command. */ Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; Trace *tracePtr, *lastTracePtr; ActiveInterpTrace active; int curLevel; int traceCode = TCL_OK; if (command == NULL || iPtr->tracePtr == NULL || (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) { return(traceCode); } curLevel = iPtr->numLevels; active.nextPtr = iPtr->activeInterpTracePtr; iPtr->activeInterpTracePtr = &active; lastTracePtr = NULL; for ( tracePtr = iPtr->tracePtr; (traceCode == TCL_OK) && (tracePtr != NULL); tracePtr = active.nextTracePtr) { if (traceFlags & TCL_TRACE_ENTER_EXEC) { /* * Execute the trace command in reverse order of creation * for "enterstep" operation. The order is changed for * "enterstep" instead of for "leavestep" as was done in * TclCheckExecutionTraces because for step traces, * Tcl_CreateObjTrace creates one more linked list of traces * which results in one more reversal of trace invocation. */ active.nextTracePtr = NULL; tracePtr = iPtr->tracePtr; while (tracePtr->nextPtr != lastTracePtr) { active.nextTracePtr = tracePtr; tracePtr = tracePtr->nextPtr; } } else { active.nextTracePtr = tracePtr->nextPtr; } if (tracePtr->level > 0 && curLevel > tracePtr->level) { continue; } if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) { /* * The proc invoked might delete the traced command which * which might try to free tracePtr. We want to use tracePtr * until the end of this if section, so we use * Tcl_Preserve() and Tcl_Release() to be sure it is not * freed while we still need it. */ Tcl_Preserve((ClientData) tracePtr); tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; if (tracePtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) { /* New style trace */ if (tracePtr->flags & traceFlags) { if (tracePtr->proc == TraceExecutionProc) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) tracePtr->clientData; tcmdPtr->curFlags = traceFlags; tcmdPtr->curCode = code; } traceCode = (tracePtr->proc)(tracePtr->clientData, interp, curLevel, command, (Tcl_Command)cmdPtr, objc, objv); } } else { /* Old-style trace */ if (traceFlags & TCL_TRACE_ENTER_EXEC) { /* * Old-style interpreter-wide traces only trigger * before the command is executed. */ traceCode = CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv); } } tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; Tcl_Release((ClientData) tracePtr); } lastTracePtr = tracePtr; } iPtr->activeInterpTracePtr = active.nextPtr; return(traceCode); } /* *---------------------------------------------------------------------- * * CallTraceProcedure -- * * Invokes a trace procedure registered with an interpreter. These * procedures trace command execution. Currently this trace procedure * is called with the address of the string-based Tcl_CmdProc for the * command, not the Tcl_ObjCmdProc. * * Results: * None. * * Side effects: * Those side effects made by the trace procedure. * *---------------------------------------------------------------------- */ static int CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) Tcl_Interp *interp; /* The current interpreter. */ register Trace *tracePtr; /* Describes the trace procedure to call. */ Command *cmdPtr; /* Points to command's Command struct. */ CONST char *command; /* Points to the first character of the * command's source before substitutions. */ int numChars; /* The number of characters in the * command's source. */ register int objc; /* Number of arguments for the command. */ Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; char *commandCopy; int traceCode; /* * Copy the command characters into a new string. */ commandCopy = (char *) ckalloc((unsigned) (numChars + 1)); memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars); commandCopy[numChars] = '\0'; /* * Call the trace procedure then free allocated storage. */ traceCode = (tracePtr->proc)( tracePtr->clientData, (Tcl_Interp*) iPtr, iPtr->numLevels, commandCopy, (Tcl_Command) cmdPtr, objc, objv ); ckfree((char *) commandCopy); return(traceCode); } /* *---------------------------------------------------------------------- * * CommandObjTraceDeleted -- * * Ensure the trace is correctly deleted by decrementing its * refCount and only deleting if no other references exist. * * Results: * None. * * Side effects: * May release memory. * *---------------------------------------------------------------------- */ static void CommandObjTraceDeleted(ClientData clientData) { TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; tcmdPtr->refCount--; if (tcmdPtr->refCount < 0) { Tcl_Panic("CommandObjTraceDeleted: negative TraceCommandInfo refCount"); } if (tcmdPtr->refCount == 0) { ckfree((char*)tcmdPtr); } } /* *---------------------------------------------------------------------- * * TraceExecutionProc -- * * This procedure is invoked whenever code relevant to a * 'trace execution' command is executed. It is called in one * of two ways in Tcl's core: * * (i) by the TclCheckExecutionTraces, when an execution trace * has been triggered. * (ii) by TclCheckInterpTraces, when a prior execution trace has * created a trace of the internals of a procedure, passing in * this procedure as the one to be called. * * Results: * The return value is a standard Tcl completion code such as * TCL_OK or TCL_ERROR, etc. * * Side effects: * May invoke an arbitrary Tcl procedure, and may create or * delete an interpreter-wide trace. * *---------------------------------------------------------------------- */ static int TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, int level, CONST char* command, Tcl_Command cmdInfo, int objc, struct Tcl_Obj *CONST objv[]) { int call = 0; Interp *iPtr = (Interp *) interp; TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; int flags = tcmdPtr->curFlags; int code = tcmdPtr->curCode; int traceCode = TCL_OK; if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { /* * Inside any kind of execution trace callback, we do * not allow any further execution trace callbacks to * be called for the same trace. */ return traceCode; } if (!(flags & TCL_INTERP_DESTROYED)) { /* * Check whether the current call is going to eval arbitrary * Tcl code with a generated trace, or whether we are only * going to setup interpreter-wide traces to implement the * 'step' traces. This latter situation can happen if * we create a command trace without either before or after * operations, but with either of the step operations. */ if (flags & TCL_TRACE_EXEC_DIRECT) { call = flags & tcmdPtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); } else { call = 1; } /* * First, if we have returned back to the level at which we * created an interpreter trace for enterstep and/or leavestep * execution traces, we remove it here. */ if (flags & TCL_TRACE_LEAVE_EXEC) { if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel) && (strcmp(command, tcmdPtr->startCmd) == 0)) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { ckfree((char *)tcmdPtr->startCmd); } } } /* * Second, create the tcl callback, if required. */ if (call) { Tcl_SavedResult state; int stateCode; Tcl_DString cmd; Tcl_DString sub; int i; Tcl_DStringInit(&cmd); Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length); /* Append command with arguments */ Tcl_DStringInit(&sub); for (i = 0; i < objc; i++) { char* str; int len; str = Tcl_GetStringFromObj(objv[i],&len); Tcl_DStringAppendElement(&sub, str); } Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub)); Tcl_DStringFree(&sub); if (flags & TCL_TRACE_ENTER_EXEC) { /* Append trace operation */ if (flags & TCL_TRACE_EXEC_DIRECT) { Tcl_DStringAppendElement(&cmd, "enter"); } else { Tcl_DStringAppendElement(&cmd, "enterstep"); } } else if (flags & TCL_TRACE_LEAVE_EXEC) { Tcl_Obj* resultCode; char* resultCodeStr; /* Append result code */ resultCode = Tcl_NewIntObj(code); resultCodeStr = Tcl_GetString(resultCode); Tcl_DStringAppendElement(&cmd, resultCodeStr); Tcl_DecrRefCount(resultCode); /* Append result string */ Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp)); /* Append trace operation */ if (flags & TCL_TRACE_EXEC_DIRECT) { Tcl_DStringAppendElement(&cmd, "leave"); } else { Tcl_DStringAppendElement(&cmd, "leavestep"); } } else { panic("TraceExecutionProc: bad flag combination"); } /* * Execute the command. Save the interp's result used for * the command, including the value of iPtr->returnCode which * may be modified when Tcl_Eval is invoked. We discard any * object result the command returns. */ Tcl_SaveResult(interp, &state); stateCode = iPtr->returnCode; tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; iPtr->flags |= INTERP_TRACE_IN_PROGRESS; tcmdPtr->refCount++; /* * This line can have quite arbitrary side-effects, * including deleting the trace, the command being * traced, or even the interpreter. */ traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; iPtr->flags &= ~INTERP_TRACE_IN_PROGRESS; if (tcmdPtr->flags == 0) { flags |= TCL_TRACE_DESTROYED; } if (traceCode == TCL_OK) { /* Restore result if trace execution was successful */ Tcl_RestoreResult(interp, &state); iPtr->returnCode = stateCode; } else { Tcl_DiscardResult(&state); } Tcl_DStringFree(&cmd); } /* * Third, if there are any step execution traces for this proc, * we register an interpreter trace to invoke enterstep and/or * leavestep traces. * We also need to save the current stack level and the proc * string in startLevel and startCmd so that we can delete this * interpreter trace when it reaches the end of this proc. */ if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL) && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC))) { tcmdPtr->startLevel = level; tcmdPtr->startCmd = (char *) ckalloc((unsigned) (strlen(command) + 1)); strcpy(tcmdPtr->startCmd, command); tcmdPtr->refCount++; tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, TraceExecutionProc, (ClientData)tcmdPtr, CommandObjTraceDeleted); } } if (flags & TCL_TRACE_DESTROYED) { if (tcmdPtr->stepTrace != NULL) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { ckfree((char *)tcmdPtr->startCmd); } } } if (call) { tcmdPtr->refCount--; if (tcmdPtr->refCount < 0) { Tcl_Panic("TraceExecutionProc: negative TraceCommandInfo refCount"); } if (tcmdPtr->refCount == 0) { ckfree((char*)tcmdPtr); } } return traceCode; } /* *---------------------------------------------------------------------- * * TraceVarProc -- * * This procedure is called to handle variable accesses that have * been traced using the "trace" command. * * Results: * Normally returns NULL. If the trace command returns an error, * then this procedure returns an error string. * * Side effects: * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static char * TraceVarProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Information about the variable trace. */ Tcl_Interp *interp; /* Interpreter containing variable. */ CONST char *name1; /* Name of variable or array. */ CONST char *name2; /* Name of element within array; NULL means * scalar variable is being referenced. */ int flags; /* OR-ed bits giving operation and other * information. */ { Tcl_SavedResult state; TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; char *result; int code; Tcl_DString cmd; /* * We might call Tcl_Eval() below, and that might evaluate * [trace vdelete] which might try to free tvarPtr. We want * to use tvarPtr until the end of this function, so we use * Tcl_Preserve() and Tcl_Release() to be sure it is not * freed while we still need it. */ Tcl_Preserve((ClientData) tvarPtr); result = NULL; if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { if (tvarPtr->length != (size_t) 0) { /* * Generate a command to execute by appending list elements * for the two variable names and the operation. */ Tcl_DStringInit(&cmd); Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); Tcl_DStringAppendElement(&cmd, name1); Tcl_DStringAppendElement(&cmd, (name2 ? name2 : "")); #ifndef TCL_REMOVE_OBSOLETE_TRACES if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) { if (flags & TCL_TRACE_ARRAY) { Tcl_DStringAppend(&cmd, " a", 2); } else if (flags & TCL_TRACE_READS) { Tcl_DStringAppend(&cmd, " r", 2); } else if (flags & TCL_TRACE_WRITES) { Tcl_DStringAppend(&cmd, " w", 2); } else if (flags & TCL_TRACE_UNSETS) { Tcl_DStringAppend(&cmd, " u", 2); } } else { #endif if (flags & TCL_TRACE_ARRAY) { Tcl_DStringAppend(&cmd, " array", 6); } else if (flags & TCL_TRACE_READS) { Tcl_DStringAppend(&cmd, " read", 5); } else if (flags & TCL_TRACE_WRITES) { Tcl_DStringAppend(&cmd, " write", 6); } else if (flags & TCL_TRACE_UNSETS) { Tcl_DStringAppend(&cmd, " unset", 6); } #ifndef TCL_REMOVE_OBSOLETE_TRACES } #endif /* * Execute the command. Save the interp's result used for * the command. We discard any object result the command returns. * * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to * other areas that this will be destroyed by us, otherwise a * double-free might occur depending on what the eval does. */ Tcl_SaveResult(interp, &state); if (flags & TCL_TRACE_DESTROYED) { tvarPtr->flags |= TCL_TRACE_DESTROYED; } code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd), 0); if (code != TCL_OK) { /* copy error msg to result */ register Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errMsgObj); result = (char *) errMsgObj; } Tcl_RestoreResult(interp, &state); Tcl_DStringFree(&cmd); } } if (flags & TCL_TRACE_DESTROYED) { if (result != NULL) { register Tcl_Obj *errMsgObj = (Tcl_Obj *) result; Tcl_DecrRefCount(errMsgObj); result = NULL; } Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); } Tcl_Release((ClientData) tvarPtr); return result; } /* *---------------------------------------------------------------------- * * Tcl_WhileObjCmd -- * * This procedure is invoked to process the "while" Tcl command. * See the user documentation for details on what it does. * * With the bytecode compiler, this procedure is only called when * a command name is computed at runtime, and is "while" or the name * to which "while" was renamed: e.g., "set z while; $z {$i<100} {}" * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_WhileObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result, value; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "test command"); return TCL_ERROR; } while (1) { result = Tcl_ExprBooleanObj(interp, objv[1], &value); if (result != TCL_OK) { return result; } if (!value) { break; } result = Tcl_EvalObjEx(interp, objv[2], 0); if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { char msg[32 + TCL_INTEGER_SPACE]; sprintf(msg, "\n (\"while\" body line %d)", interp->errorLine); Tcl_AddErrorInfo(interp, msg); } break; } } if (result == TCL_BREAK) { result = TCL_OK; } if (result == TCL_OK) { Tcl_ResetResult(interp); } return result; }