--- /dev/null
+/*
+ * 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$
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+#include "tclRegexp.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 */
+ 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+
+ 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ */
+
+ 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) ? 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.
+ */
+
+ Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
+ offset++;
+ } else {
+ offset += end;
+ }
+ 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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]);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 = Tcl_UtfToUniChar(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 {
+ 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 = Tcl_UtfToUniChar(string, &ch);
+ for (p = splitChars; p < splitEnd; p += splitLen) {
+ splitLen = Tcl_UtfToUniChar(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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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:
+ if (objPtr->typePtr == &tclBooleanType) {
+ if ((((enum isOptions) index == STR_IS_TRUE) &&
+ objPtr->internalRep.longValue == 0) ||
+ (((enum isOptions) index == STR_IS_FALSE) &&
+ objPtr->internalRep.longValue != 0)) {
+ result = 0;
+ }
+ } else 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;
+
+ if ((objPtr->typePtr == &tclIntType) ||
+ (Tcl_GetInt(NULL, string1, &i) == TCL_OK)) {
+ break;
+ }
+ /*
+ * Like STR_IS_DOUBLE, but we use strtoul.
+ * Since Tcl_GetInt already failed, we set result to 0.
+ */
+ result = 0;
+ 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 (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.
+ */
+ 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 = Tcl_UtfToUniChar(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;
+ Tcl_Obj **mapElemv;
+ 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;
+ }
+ objc--;
+
+ ustring1 = Tcl_GetUnicodeFromObj(objv[objc], &length1);
+ if (length1 == 0) {
+ /*
+ * Empty input string, just stop now
+ */
+ 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 == 0) {
+ 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]))) &&
+ ((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);
+ }
+ break;
+ }
+ case STR_MATCH: {
+ 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;
+ }
+ }
+
+ Tcl_SetBooleanObj(resultPtr,
+ Tcl_UniCharCaseMatch(Tcl_GetUnicode(objv[objc-1]),
+ Tcl_GetUnicode(objv[objc-2]), nocase));
+ break;
+ }
+ case STR_RANGE: {
+ int first, last;
+
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string first last");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the length in actual characters.
+ */
+ 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) {
+ 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.
+ */
+ length2 = length1 * count;
+ /*
+ * 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 = Tcl_UtfToUniChar(p, &ch);
+
+ for (check = string2; ; ) {
+ if (check >= checkEnd) {
+ p = end;
+ break;
+ }
+ check += Tcl_UtfToUniChar(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 = Tcl_UtfToUniChar(p, &ch);
+ for (check = string2; ; ) {
+ if (check >= checkEnd) {
+ p = end;
+ break;
+ }
+ check += Tcl_UtfToUniChar(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 += Tcl_UtfToUniChar(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--) {
+ Tcl_UtfToUniChar(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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+
+ old = p = Tcl_GetString(objPtr);
+ resultObj = Tcl_NewStringObj("", 0);
+ while (1) {
+ switch (*p) {
+ case 0:
+ if (p != old) {
+ Tcl_AppendToObj(resultObj, old, p-old);
+ }
+ return resultObj;
+
+ 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;
+ old = p;
+ } else {
+ p++;
+ }
+ 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++;
+ break;
+ }
+ if (p != old) {
+ Tcl_AppendToObj(resultObj, old, p-old);
+ }
+ p += 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++;
+ }
+ 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;
+ code = Tcl_EvalEx(interp, p+1, -1, 0);
+ 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);
+ }
+ } else {
+ p++;
+ }
+ break;
+ default:
+ p++;
+ break;
+ }
+ }
+
+ errorResult:
+ Tcl_DecrRefCount(resultObj);
+ return NULL;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 ; i+=2) {
+ if (Tcl_GetString(objv[i])[0] == '#') {
+ Tcl_AppendResult(interp, ", this may be due to a ",
+ "comment incorrectly placed outside of a ",
+ "switch body - see the \"switch\" ",
+ "documentation", NULL);
+ break;
+ }
+ }
+ }
+
+ return TCL_ERROR;
+ }
+
+ /*
+ * Complain if the last body is a continuation. Note that this
+ * check assumes that the list is non-empty!
+ */
+
+ if (strcmp(Tcl_GetString(objv[objc-1]), "-") == 0) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "no body specified for pattern \"",
+ Tcl_GetString(objv[objc-2]), "\"", NULL);
+ return TCL_ERROR;
+ }
+
+ for (i = 0; i < objc; i += 2) {
+ /*
+ * See if the pattern matches the string.
+ */
+
+ pattern = Tcl_GetString(objv[i]);
+
+ matched = 0;
+ if ((i == objc - 2)
+ && (*pattern == 'd')
+ && (strcmp(pattern, "default") == 0)) {
+ matched = 1;
+ } else {
+ switch (mode) {
+ case OPT_EXACT:
+ matched = (strcmp(Tcl_GetString(stringObj), pattern) == 0);
+ break;
+ case OPT_GLOB:
+ matched = Tcl_StringMatch(Tcl_GetString(stringObj),
+ pattern);
+ break;
+ case OPT_REGEXP:
+ matched = Tcl_RegExpMatchObj(interp, stringObj, objv[i]);
+ if (matched < 0) {
+ return TCL_ERROR;
+ }
+ break;
+ }
+ }
+ if (matched == 0) {
+ continue;
+ }
+
+ /*
+ * We've got a match. Find a body to execute, skipping bodies
+ * that are "-".
+ */
+
+ for (j = i + 1; ; j += 2) {
+ if (j >= 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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, commandLength;
+ char *name, *flagOps, *command, *p;
+ size_t length;
+ /* 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);
+ break;
+ }
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+ case TRACE_OLD_VARIABLE: {
+ int flags;
+ TraceVarInfo *tvarPtr;
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
+ return TCL_ERROR;
+ }
+
+ flags = 0;
+ flagOps = Tcl_GetString(objv[3]);
+ for (p = flagOps; *p != 0; p++) {
+ if (*p == 'r') {
+ flags |= TCL_TRACE_READS;
+ } else if (*p == 'w') {
+ flags |= TCL_TRACE_WRITES;
+ } else if (*p == 'u') {
+ flags |= TCL_TRACE_UNSETS;
+ } else if (*p == 'a') {
+ flags |= TCL_TRACE_ARRAY;
+ } else {
+ goto badVarOps;
+ }
+ }
+ if (flags == 0) {
+ goto badVarOps;
+ }
+ flags |= TCL_TRACE_OLD_STYLE;
+
+ command = Tcl_GetStringFromObj(objv[4], &commandLength);
+ length = (size_t) commandLength;
+ tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
+ (sizeof(TraceVarInfo) - sizeof(tvarPtr->command)
+ + length + 1));
+ tvarPtr->flags = flags;
+ tvarPtr->length = length;
+ flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
+ strcpy(tvarPtr->command, command);
+ name = Tcl_GetString(objv[2]);
+ if (Tcl_TraceVar(interp, name, flags, TraceVarProc,
+ (ClientData) tvarPtr) != TCL_OK) {
+ ckfree((char *) tvarPtr);
+ return TCL_ERROR;
+ }
+ break;
+ }
+ case TRACE_OLD_VDELETE: {
+ int flags;
+ TraceVarInfo *tvarPtr;
+ ClientData clientData;
+
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
+ return TCL_ERROR;
+ }
+
+ flags = 0;
+ flagOps = Tcl_GetString(objv[3]);
+ for (p = flagOps; *p != 0; p++) {
+ if (*p == 'r') {
+ flags |= TCL_TRACE_READS;
+ } else if (*p == 'w') {
+ flags |= TCL_TRACE_WRITES;
+ } else if (*p == 'u') {
+ flags |= TCL_TRACE_UNSETS;
+ } else if (*p == 'a') {
+ flags |= TCL_TRACE_ARRAY;
+ } else {
+ goto badVarOps;
+ }
+ }
+ if (flags == 0) {
+ goto badVarOps;
+ }
+ flags |= TCL_TRACE_OLD_STYLE;
+
+ /*
+ * 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.
+ */
+
+ command = Tcl_GetStringFromObj(objv[4], &commandLength);
+ length = (size_t) commandLength;
+ clientData = 0;
+ name = Tcl_GetString(objv[2]);
+ while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
+ TraceVarProc, clientData)) != 0) {
+ tvarPtr = (TraceVarInfo *) clientData;
+ if ((tvarPtr->length == length) && (tvarPtr->flags == 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_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;
+}
+
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 execution");
+ 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;
+ flags |= TCL_TRACE_DELETE;
+ if (flags & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) {
+ 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;
+ clientData = 0;
+ name = Tcl_GetString(objv[3]);
+ while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
+ TraceCommandProc, clientData)) != 0) {
+ 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 & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) {
+ 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);
+ }
+ }
+ /* Postpone deletion */
+ if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
+ tcmdPtr->flags = 0;
+ } else {
+ Tcl_EventuallyFree((ClientData) tcmdPtr, 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_CommandTraceInfo(interp, name, 0,
+ TraceCommandProc, clientData)) != 0) {
+
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
+
+ eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+
+ /*
+ * 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 (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) {
+ Tcl_ListObjAppendElement(NULL, elemObjPtr,
+ Tcl_NewStringObj("enter",6));
+ }
+ 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",10));
+ }
+ Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, 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;
+}
+
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ 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;
+ clientData = 0;
+ name = Tcl_GetString(objv[3]);
+ while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
+ TraceCommandProc, clientData)) != 0) {
+ 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);
+ 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;
+ }
+
+ resultListPtr = Tcl_GetObjResult(interp);
+ clientData = 0;
+ name = Tcl_GetString(objv[3]);
+ while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
+ TraceCommandProc, clientData)) != 0) {
+
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
+
+ eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+
+ /*
+ * 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 (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_ListObjAppendElement(NULL, eachTraceObjPtr, 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;
+}
+
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ 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 == 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;
+
+ eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ /*
+ * 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));
+ }
+ 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;
+}
+
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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, or if there are no (more) traces for it,
+ * then 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ cmdPtr->tracePtr = tracePtr;
+ if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
+ cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
+ }
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ Tcl_EventuallyFree((int*)tracePtr, TCL_DYNAMIC);
+
+ 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;
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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. */
+{
+ Tcl_SavedResult state;
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
+ int code;
+ Tcl_DString cmd;
+
+ Tcl_Preserve((ClientData) tcmdPtr);
+
+ 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. 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);
+ 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);
+
+ 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)) {
+ if (tcmdPtr->stepTrace != NULL) {
+ Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
+ tcmdPtr->stepTrace = NULL;
+ if (tcmdPtr->startCmd != NULL) {
+ ckfree((char *)tcmdPtr->startCmd);
+ }
+ }
+ /* Postpone deletion, until exec trace returns */
+ if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
+ tcmdPtr->flags = 0;
+ } else {
+ Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC);
+ }
+ }
+ Tcl_Release((ClientData) tcmdPtr);
+ return;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp,
+ curLevel, command, (Tcl_Command)cmdPtr, objc, objv);
+ }
+ lastTracePtr = tracePtr;
+ }
+ iPtr->activeCmdTracePtr = active.nextPtr;
+ return(traceCode);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ TraceCommandInfo* tcmdPtr;
+
+ if (command == NULL || iPtr->tracePtr == NULL ||
+ (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) {
+ return(traceCode);
+ }
+
+ curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level);
+
+ 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 sureit is not
+ * freed while we still need it.
+ */
+ Tcl_Preserve((ClientData) tracePtr);
+ tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
+ if ((tracePtr->flags != TCL_TRACE_EXEC_IN_PROGRESS) &&
+ ((tracePtr->flags & traceFlags) != 0)) {
+ tcmdPtr = (TraceCommandInfo*)tracePtr->clientData;
+ tcmdPtr->curFlags = traceFlags;
+ tcmdPtr->curCode = code;
+ traceCode = (tracePtr->proc)((ClientData)tcmdPtr,
+ (Tcl_Interp*)interp,
+ curLevel, command,
+ (Tcl_Command)cmdPtr,
+ objc, objv);
+ } else {
+ 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);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+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;
+ 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. We discard any object result the command returns.
+ */
+
+ Tcl_SaveResult(interp, &state);
+
+ tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
+ iPtr->flags |= INTERP_TRACE_IN_PROGRESS;
+ Tcl_Preserve((ClientData)tcmdPtr);
+ /*
+ * 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);
+ }
+
+ 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->stepTrace = Tcl_CreateObjTrace(interp, 0,
+ (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2,
+ TraceExecutionProc, (ClientData)tcmdPtr, NULL);
+ }
+ }
+ 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);
+ }
+ }
+ Tcl_EventuallyFree((ClientData)tcmdPtr, TCL_DYNAMIC);
+ }
+ if (call) {
+ Tcl_Release((ClientData)tcmdPtr);
+ }
+ return(traceCode);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+
OSDN Git Service
