diff options
Diffstat (limited to 'generic/tclCmdMZ.c')
| -rw-r--r-- | generic/tclCmdMZ.c | 6448 |
1 files changed, 2735 insertions, 3713 deletions
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 27e4055..ab673d5 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1,153 +1,34 @@ -/* +/* * 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). + * 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. + * Copyright (c) 2003 Donal K. Fellows. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#include "tclPort.h" #include "tclRegexp.h" -#include "tclCompile.h" - -/* - * Structures 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; - -typedef struct { - VarTrace trace; - TraceVarInfo tvar; -} CompoundVarTrace; - -/* - * Structure used to hold information about command traces: - */ - -typedef struct { - int flags; /* Operations for which Tcl command is - * to be invoked. */ - size_t length; /* Number of non-NULL chars. in command. */ - Tcl_Trace stepTrace; /* Used for execution traces, when tracing - * inside the given command */ - int startLevel; /* Used for bookkeeping with step execution - * traces, store the level at which the step - * trace was invoked */ - char *startCmd; /* Used for bookkeeping with step execution - * traces, store the command name which invoked - * step trace */ - int curFlags; /* Trace flags for the current command */ - int curCode; /* Return code for the current command */ - int refCount; /* Used to ensure this structure is - * not deleted too early. Keeps track - * of how many pieces of code have - * a pointer to this structure. */ - char command[4]; /* Space for Tcl command to invoke. Actual - * size will be as large as necessary to - * hold command. This field must be the - * last in the structure, so that it can - * be larger than 4 bytes. */ -} TraceCommandInfo; - -/* - * Used by command execution traces. Note that we assume in the code - * that the first two defines are exactly 4 times the - * 'TCL_TRACE_ENTER_EXEC' and 'TCL_TRACE_LEAVE_EXEC' constants. - * - * TCL_TRACE_ENTER_DURING_EXEC - Trace each command inside the command - * currently being traced, before execution. - * TCL_TRACE_LEAVE_DURING_EXEC - Trace each command inside the command - * currently being traced, after execution. - * TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags. - * TCL_TRACE_EXEC_IN_PROGRESS - The callback procedure on this trace - * is currently executing. Therefore we - * don't let further traces execute. - * TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly - * by the command being traced, not because - * of an internal trace. - * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also - * be used in command execution traces. - */ -#define TCL_TRACE_ENTER_DURING_EXEC 4 -#define TCL_TRACE_LEAVE_DURING_EXEC 8 -#define TCL_TRACE_ANY_EXEC 15 -#define TCL_TRACE_EXEC_IN_PROGRESS 0x10 -#define TCL_TRACE_EXEC_DIRECT 0x20 - -/* - * Forward declarations for procedures defined in this file: - */ - -typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp, - int optionIndex, int objc, Tcl_Obj *CONST objv[])); - -Tcl_TraceTypeObjCmd TclTraceVariableObjCmd; -Tcl_TraceTypeObjCmd TclTraceCommandObjCmd; -Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd; -/* - * Each subcommand has a number of 'types' to which it can apply. - * Currently 'execution', 'command' and 'variable' are the only - * types supported. These three arrays MUST be kept in sync! - * In the future we may provide an API to add to the list of - * supported trace types. - */ -static CONST char *traceTypeOptions[] = { - "execution", "command", "variable", (char*) NULL -}; -static Tcl_TraceTypeObjCmd* traceSubCmds[] = { - TclTraceExecutionObjCmd, - TclTraceCommandObjCmd, - TclTraceVariableObjCmd, -}; - -/* - * Declarations for local procedures to this file: - */ -static int CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp, - Trace *tracePtr, Command *cmdPtr, - CONST char *command, int numChars, - int objc, Tcl_Obj *CONST objv[])); -static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, CONST char *name1, - CONST char *name2, int flags)); -static void TraceCommandProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, CONST char *oldName, - CONST char *newName, int flags)); -static Tcl_CmdObjTraceProc TraceExecutionProc; - -#ifdef TCL_TIP280 -static void ListLines _ANSI_ARGS_((Tcl_Obj* listObj, int line, - int n, int* lines, - Tcl_Obj* const* elems)); -#endif +static int UniCharIsAscii(int character); +static int UniCharIsHexDigit(int character); + /* *---------------------------------------------------------------------- * * Tcl_PwdObjCmd -- * - * This procedure is invoked to process the "pwd" Tcl command. - * See the user documentation for details on what it does. + * 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. @@ -158,13 +39,12 @@ static void ListLines _ANSI_ARGS_((Tcl_Obj* listObj, int line, *---------------------------------------------------------------------- */ - /* 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_PwdObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { Tcl_Obj *retVal; @@ -187,8 +67,8 @@ Tcl_PwdObjCmd(dummy, interp, objc, objv) * * Tcl_RegexpObjCmd -- * - * This procedure is invoked to process the "regexp" Tcl command. - * See the user documentation for details on what it does. + * 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. @@ -199,23 +79,22 @@ Tcl_PwdObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* 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. */ +Tcl_RegexpObjCmd( + 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; + int cflags, eflags, stringLength, matchLength; Tcl_RegExp regExpr; - Tcl_Obj *objPtr, *resultPtr; + Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL; Tcl_RegExpInfo info; static CONST char *options[] = { "-all", "-about", "-indices", "-inline", "-expanded", "-line", "-linestop", "-lineanchor", - "-nocase", "-start", "--", (char *) NULL + "-nocase", "-start", "--", NULL }; enum options { REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE, @@ -223,165 +102,177 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) REGEXP_NOCASE, REGEXP_START, REGEXP_LAST }; - indices = 0; - about = 0; - cflags = TCL_REG_ADVANCED; - eflags = 0; - offset = 0; - all = 0; - doinline = 0; - + 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]); + name = TclGetString(objv[i]); if (name[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; + goto optionError; } 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_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: { + int temp; + if (++i >= objc) { + goto endOfForLoop; } - case REGEXP_LINEANCHOR: { - cflags |= TCL_REG_NLANCH; - break; + if (TclGetIntForIndexM(interp, objv[i], 0, &temp) != TCL_OK) { + goto optionError; } - 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; + if (startIndex) { + Tcl_DecrRefCount(startIndex); } + startIndex = objv[i]; + Tcl_IncrRefCount(startIndex); + break; + } + case REGEXP_LAST: + i++; + goto endOfForLoop; } } - endOfForLoop: + endOfForLoop: if ((objc - i) < (2 - about)) { - Tcl_WrongNumArgs(interp, 1, objv, - "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, + "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); + goto optionError; } objc -= i; objv += i; + /* + * Check if the user requested -inline, but specified match variables; a + * no-no. + */ + 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; + Tcl_AppendResult(interp, "regexp match variables not allowed" + " when using -inline", NULL); + goto optionError; } /* * Handle the odd about case separately. */ + if (about) { regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) { + optionError: + if (startIndex) { + Tcl_DecrRefCount(startIndex); + } 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. + * 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); + if (startIndex) { + TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); + Tcl_DecrRefCount(startIndex); + if (offset < 0) { + offset = 0; + } + } + 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. + * 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. + * The following loop is to handle multiple matches within the same source + * string; each iteration handles one match. If "-all" hasn't been + * specified then the loop body only gets executed once. We terminate the + * loop when the starting offset is past the end of the string. */ while (1) { - match = Tcl_RegExpExecObj(interp, regExpr, objPtr, - offset /* offset */, numMatchesSaved, eflags - | ((offset > 0 && offset < stringLength && - (Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n')) - ? TCL_REG_NOTBOL : 0)); + /* + * Pass either 0 or TCL_REG_NOTBOL in the eflags. Passing + * TCL_REG_NOTBOL indicates that the character at offset should not be + * considered the start of the line. If for example the pattern {^} is + * passed and -start is positive, then the pattern will not match the + * start of the string unless the previous character is a newline. + */ + if ((offset == 0) || ((offset > 0) && (offset < stringLength) && + (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n'))) { + eflags = 0; + } else { + eflags = TCL_REG_NOTBOL; + } + + match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset, + numMatchesSaved, eflags); if (match < 0) { return TCL_ERROR; } @@ -391,16 +282,16 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) * 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 inlining, the interpreter's object result remains 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); + + if (!doinline) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } return TCL_OK; } @@ -408,17 +299,21 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) } /* - * If additional variable names have been specified, return - * index information in those variables. + * 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 + * It's the number of substitutions, plus one for the matchVar at + * index 0 */ + objc = info.nsubs + 1; + if (all <= 1) { + resultPtr = Tcl_NewObj(); + } } for (i = 0; i < objc; i++) { Tcl_Obj *newPtr; @@ -428,12 +323,13 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) Tcl_Obj *objs[2]; /* - * Only adjust the match area if there was a match for - * that area. (Scriptics Bug 4391/SF Bug #219232) + * 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; + end = offset + info.matches[i].end; /* * Adjust index so it refers to the last character in the @@ -445,7 +341,7 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) } } else { start = -1; - end = -1; + end = -1; } objs[0] = Tcl_NewLongObj(start); @@ -465,6 +361,7 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr) != TCL_OK) { Tcl_DecrRefCount(newPtr); + Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } } else { @@ -472,8 +369,7 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); if (valuePtr == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", - Tcl_GetString(objv[i]), "\"", (char *) NULL); - Tcl_DecrRefCount(newPtr); + TclGetString(objv[i]), "\"", NULL); return TCL_ERROR; } } @@ -482,37 +378,44 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) 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). + * 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) { + + matchLength = info.matches[0].end - info.matches[0].start; + offset += info.matches[0].end; + + /* + * A match of length zero could happen for {^} {$} or {.*} and in + * these cases we always want to bump the index up one. + */ + + if (matchLength == 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). + * 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). */ - if (!doinline) { - resultPtr = Tcl_GetObjResult(interp); - Tcl_SetIntObj(resultPtr, (all ? all-1 : 1)); + if (doinline) { + Tcl_SetObjResult(interp, resultPtr); + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1)); } return TCL_OK; } @@ -522,8 +425,8 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) * * Tcl_RegsubObjCmd -- * - * This procedure is invoked to process the "regsub" Tcl command. - * See the user documentation for details on what it does. + * 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. @@ -534,19 +437,18 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* 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. */ +Tcl_RegsubObjCmd( + 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_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL; Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; static CONST char *options[] = { @@ -568,95 +470,107 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) for (idx = 1; idx < objc; idx++) { char *name; int index; - - name = Tcl_GetString(objv[idx]); + + name = TclGetString(objv[idx]); if (name[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; + goto optionError; } 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_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: { + int temp; + if (++idx >= objc) { + goto endOfForLoop; } - 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; + if (TclGetIntForIndexM(interp, objv[idx], 0, &temp) != TCL_OK) { + goto optionError; } - case REGSUB_LAST: { - idx++; - goto endOfForLoop; + if (startIndex) { + Tcl_DecrRefCount(startIndex); } + startIndex = objv[idx]; + Tcl_IncrRefCount(startIndex); + break; + } + case REGSUB_LAST: + idx++; + goto endOfForLoop; } } - endOfForLoop: + + endOfForLoop: if (objc-idx < 3 || objc-idx > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string subSpec ?varName?"); + optionError: + if (startIndex) { + Tcl_DecrRefCount(startIndex); + } return TCL_ERROR; } objc -= idx; objv += idx; + if (startIndex) { + int stringLength = Tcl_GetCharLength(objv[1]); + + TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); + Tcl_DecrRefCount(startIndex); + if (offset < 0) { + offset = 0; + } + } + if (all && (offset == 0) - && (strpbrk(Tcl_GetString(objv[2]), "&\\") == NULL) - && (strpbrk(Tcl_GetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { + && (strpbrk(TclGetString(objv[2]), "&\\") == NULL) + && (strpbrk(TclGetString(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. + * 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)); + int (*strCmpFn)(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; + nocase = (cflags & TCL_REG_NOCASE); + strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; - wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); - wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); + 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; + 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. + * regsub behavior for "" matches between each character. 'string + * map' skips the "" case. */ + if (wstring < wend) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); @@ -670,10 +584,9 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) } 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, + 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); @@ -707,9 +620,9 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) } /* - * Make sure to avoid problems where the objects are shared. This - * can cause RegExpObj <> UnicodeObj shimmering that causes data - * corruption. [Bug #461322] + * 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]) { @@ -728,27 +641,27 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) result = TCL_OK; /* - * The following loop is to handle multiple matches within the - * same source string; each iteration handles one match and its - * corresponding substitution. If "-all" hasn't been specified - * then the loop body only gets executed once. We must use - * 'offset <= wlen' in particular for the case where the regexp - * pattern can match the empty string - this is useful when - * doing, say, 'regsub -- ^ $str ...' when $str might be empty. + * The following loop is to handle multiple matches within the same source + * string; each iteration handles one match and its corresponding + * substitution. If "-all" hasn't been specified then the loop body only + * gets executed once. We must use 'offset <= wlen' in particular for the + * case where the regexp pattern can match the empty string - this is + * useful when doing, say, 'regsub -- ^ $str ...' when $str might be + * empty. */ numMatches = 0; for ( ; offset <= wlen; ) { /* - * The flags argument is set if string is part of a larger string, - * so that "^" won't match. + * The flags argument is set if string is part of a larger string, so + * that "^" won't match. */ match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset, 10 /* matches */, ((offset > 0 && - (wstring[offset-1] != (Tcl_UniChar)'\n')) - ? TCL_REG_NOTBOL : 0)); + (wstring[offset-1] != (Tcl_UniChar)'\n')) + ? TCL_REG_NOTBOL : 0)); if (match < 0) { result = TCL_ERROR; @@ -762,9 +675,10 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) Tcl_IncrRefCount(resultPtr); if (offset > 0) { /* - * Copy the initial portion of the string in if an offset - * was specified. + * Copy the initial portion of the string in if an offset was + * specified. */ + Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); } } @@ -782,7 +696,7 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) /* * Append the subSpec argument to the variable, making appropriate - * substitutions. This code is a bit hairy because of the backslash + * 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. */ @@ -810,10 +724,12 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) } 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; @@ -822,18 +738,21 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) 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. + * Always consume at least one character of the input string in + * order to prevent infinite loops. */ if (offset < wlen) { @@ -844,10 +763,10 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) offset += end; if (start == end) { /* - * We matched an empty string, which means we must go - * forward one more step so we don't match again at the - * same spot. + * We matched an empty string, which means we must go forward + * one more step so we don't match again at the same spot. */ + if (offset < wlen) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } @@ -863,12 +782,14 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) * Copy the portion of the source string after the last match to the * result variable. */ - regsubDone: + + 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. + * 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) { @@ -877,27 +798,34 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) 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); + TclGetString(objv[3]), "\"", NULL); result = TCL_ERROR; } else { /* * Set the interpreter's object result to an integer object - * holding the number of matches. + * holding the number of matches. */ - Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches); + Tcl_SetObjResult(interp, Tcl_NewIntObj(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); } + 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; } @@ -906,8 +834,8 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) * * Tcl_RenameObjCmd -- * - * This procedure is invoked to process the "rename" Tcl command. - * See the user documentation for details on what it does. + * 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. @@ -918,23 +846,22 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* 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. */ +Tcl_RenameObjCmd( + 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]); + oldName = TclGetString(objv[1]); + newName = TclGetString(objv[2]); return TclRenameCommand(interp, oldName, newName); } @@ -955,83 +882,34 @@ Tcl_RenameObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* 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. */ +Tcl_ReturnObjCmd( + 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; - } + int code, level; + Tcl_Obj *returnOpts; + + /* + * General syntax: [return ?-option value ...? ?result?] + * An even number of words means an explicit result argument is present. + */ + + int explicitResult = (0 == (objc % 2)); + int numOptionWords = objc - 1 - explicitResult; + + if (TCL_ERROR == TclMergeReturnOptions(interp, numOptionWords, objv+1, + &returnOpts, &code, &level)) { + return TCL_ERROR; } - - if (objc == 1) { - /* - * Set the interpreter's object result. An inline version of - * Tcl_SetObjResult. - */ - Tcl_SetObjResult(interp, objv[0]); + code = TclProcessReturn(interp, code, level, returnOpts); + if (explicitResult) { + Tcl_SetObjResult(interp, objv[objc-1]); } - iPtr->returnCode = code; - return TCL_RETURN; + return code; } /* @@ -1039,8 +917,8 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv) * * Tcl_SourceObjCmd -- * - * This procedure is invoked to process the "source" Tcl command. - * See the user documentation for details on what it does. + * 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. @@ -1051,20 +929,37 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* 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. */ +Tcl_SourceObjCmd( + 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"); + CONST char *encodingName = NULL; + Tcl_Obj *fileName; + + if (objc != 2 && objc !=4) { + Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName"); return TCL_ERROR; } - return Tcl_FSEvalFile(interp, objv[1]); + fileName = objv[objc-1]; + + if (objc == 4) { + static CONST char *options[] = { + "-encoding", NULL + }; + int index; + + if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], options, + "option", TCL_EXACT, &index)) { + return TCL_ERROR; + } + encodingName = TclGetString(objv[2]); + } + + return Tcl_FSEvalFileEx(interp, fileName, encodingName); } /* @@ -1072,8 +967,8 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv) * * Tcl_SplitObjCmd -- * - * This procedure is invoked to process the "split" Tcl command. - * See the user documentation for details on what it does. + * 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. @@ -1084,17 +979,16 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* 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_SplitObjCmd( + 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; + char *splitChars, *stringPtr, *end; int splitCharLen, stringLen; Tcl_Obj *listPtr, *objPtr; @@ -1102,16 +996,16 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) splitChars = " \n\t\r"; splitCharLen = 4; } else if (objc == 3) { - splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen); + splitChars = TclGetStringFromObj(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); - + stringPtr = TclGetStringFromObj(objv[1], &stringLen); + end = stringPtr + stringLen; + listPtr = Tcl_NewObj(); + if (stringLen == 0) { /* * Do nothing. @@ -1124,87 +1018,92 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) /* * 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 + * Uses a hash table to ensure that each kind of character has only + * one Tcl_Obj instance (multiply-referenced) in the final list. This + * is a *major* win when splitting on a long string (especially in the + * megabyte range!) - DKF */ Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); - for ( ; string < end; string += len) { - len = TclUtfToUniChar(string, &ch); - /* Assume Tcl_UniChar is an integral type... */ - hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew); + + for ( ; stringPtr < end; stringPtr += len) { + len = TclUtfToUniChar(stringPtr, &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... */ + TclNewStringObj(objPtr, stringPtr, len); + + /* + * Don't need to fiddle with refcount... + */ + Tcl_SetHashValue(hPtr, (ClientData) objPtr); } else { - objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr); + objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); } Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } Tcl_DeleteHashTable(&charReuseTable); + } else if (splitCharLen == 1) { char *p; /* - * Handle the special case of splitting on a single character. - * This is only true for the one-char ASCII case, as one unicode - * char is > 1 byte in length. + * Handle the special case of splitting on a single character. This is + * only true for the one-char ASCII case, as one unicode char is > 1 + * byte in length. */ - while (*string && (p = strchr(string, (int) *splitChars)) != NULL) { - objPtr = Tcl_NewStringObj(string, p - string); + while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) { + objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); - string = p + 1; + stringPtr = p + 1; } - objPtr = Tcl_NewStringObj(string, end - string); + TclNewStringObj(objPtr, stringPtr, end - stringPtr); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } else { char *element, *p, *splitEnd; int splitLen; Tcl_UniChar splitChar; - + /* - * Normal case: split on any of a given set of characters. - * Discard instances of the split characters. + * Normal case: split on any of a given set of characters. Discard + * instances of the split characters. */ splitEnd = splitChars + splitCharLen; - for (element = string; string < end; string += len) { - len = TclUtfToUniChar(string, &ch); + for (element = stringPtr; stringPtr < end; stringPtr += len) { + len = TclUtfToUniChar(stringPtr, &ch); for (p = splitChars; p < splitEnd; p += splitLen) { splitLen = TclUtfToUniChar(p, &splitChar); if (ch == splitChar) { - objPtr = Tcl_NewStringObj(element, string - element); + TclNewStringObj(objPtr, element, stringPtr - element); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); - element = string + len; + element = stringPtr + len; break; } } } - objPtr = Tcl_NewStringObj(element, string - element); + + TclNewStringObj(objPtr, element, stringPtr - element); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } + Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_StringObjCmd -- - * - * This procedure is invoked to process the "string" Tcl command. - * See the user documentation for details on what it does. Note - * that this command only functions correctly on properly formed - * Tcl UTF strings. + * StringFirstCmd -- * - * 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'). + * This procedure is invoked to process the "string first" Tcl command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -1215,1248 +1114,882 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* 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. */ +static int +StringFirstCmd( + 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) { + Tcl_UniChar *ustring1, *ustring2; + int match, start, length1, length2; + + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "needleString haystackString ?startIndex?"); 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; - } - } + /* + * We are searching string2 for the sequence string1. + */ - /* - * From now on, we only access the two objects at the end - * of the argument array. - */ - objv += objc-2; + match = -1; + start = 0; + length2 = -1; - if ((reqlength == 0) || (objv[0] == objv[1])) { - /* - * Alway match at 0 chars of if it is the same obj. - */ + ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); - 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 (objc == 4) { + /* + * If a startIndex is specified, we will need to fast forward to that + * point in the string before we think about a match. + */ - if ((enum options) index == STR_EQUAL) { - Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1); - } else { - Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 : - (match < 0) ? -1 : 0)); - } - break; + if (TclGetIntForIndexM(interp, objv[3], length2-1, &start) != TCL_OK){ + return TCL_ERROR; } - 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; - } + /* + * Reread to prevent shimmering problems. + */ + + ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); + if (start >= length2) { + goto str_first_done; + } else if (start > 0) { + ustring2 += start; + length2 -= start; + } else if (start < 0) { /* - * We are searching string2 for the sequence string1. + * Invalid start index mapped to string start; Bug #423581 */ - 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 the length of the needle is more than the length of the haystack, it + * cannot be contained in there so we can avoid searching. [Bug 2960021] + */ - if (length1 > 0) { - register Tcl_UniChar *p, *end; + if (length1 > 0 && length1 <= length2) { + 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; - } - } - } + end = ustring2 + length2 - length1 + 1; + for (p = ustring2; p < end; p++) { /* - * Compute the character index of the matching string by - * counting the number of characters before the match. + * Scan forward to find the first character. */ - 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 ((*p == *ustring1) && (TclUniCharNcmp(ustring1, p, + (unsigned long) length1) == 0)) { + match = p - ustring2; + break; } + } + } - /* - * 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. - */ + /* + * Compute the character index of the matching string by counting the + * number of characters before the match. + */ - if (objv[2]->typePtr == &tclByteArrayType) { - string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1); + if ((match != -1) && (objc == 4)) { + match += start; + } - 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]); + str_first_done: + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringLastCmd -- + * + * This procedure is invoked to process the "string last" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - 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; +static int +StringLastCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_UniChar *ustring1, *ustring2, *p; + int match, start, length1, length2; - 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; + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "needleString haystackString ?startIndex?"); + return TCL_ERROR; + } - /* - * The UniChar comparison function - */ + /* + * We are searching string2 for the sequence string1. + */ - 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; - } - } - } + match = -1; + start = 0; + length2 = -1; - /* - * 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; + ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); - /* - * When entering here, result == 1 and failat == 0 - */ - switch ((enum isOptions) index) { - case STR_IS_ALNUM: - chcomp = Tcl_UniCharIsAlnum; - break; - case STR_IS_ALPHA: - chcomp = Tcl_UniCharIsAlpha; - break; - case STR_IS_ASCII: - for (; string1 < end; string1++, failat++) { - /* - * This is a valid check in unicode, because all - * bytes < 0xC0 are single byte chars (but isascii - * limits that def'n to 0x80). - */ - if (*((unsigned char *)string1) >= 0x80) { - result = 0; - break; - } - } - break; - case STR_IS_BOOL: - case STR_IS_TRUE: - case STR_IS_FALSE: - /* Optimizers, beware Bug 1187123 ! */ - if ((Tcl_GetBoolean(NULL, string1, &i) - == TCL_ERROR) || - (((enum isOptions) index == STR_IS_TRUE) && - i == 0) || - (((enum isOptions) index == STR_IS_FALSE) && - i != 0)) { - result = 0; - } - break; - case STR_IS_CONTROL: - chcomp = Tcl_UniCharIsControl; - break; - case STR_IS_DIGIT: - chcomp = Tcl_UniCharIsDigit; - break; - case STR_IS_DOUBLE: { - char *stop; + if (objc == 4) { + /* + * If a startIndex is specified, we will need to restrict the string + * range to that char index in the string + */ - if ((objPtr->typePtr == &tclDoubleType) || - (objPtr->typePtr == &tclIntType)) { - break; - } - /* - * This is adapted from Tcl_GetDouble - * - * The danger in this function is that - * "12345678901234567890" is an acceptable 'double', - * but will later be interp'd as an int by something - * like [expr]. Therefore, we check to see if it looks - * like an int, and if so we do a range check on it. - * If strtoul gets to the end, we know we either - * received an acceptable int, or over/underflow - */ - if (TclLooksLikeInt(string1, length1)) { - errno = 0; -#ifdef TCL_WIDE_INT_IS_LONG - strtoul(string1, &stop, 0); /* INTL: Tcl source. */ -#else - strtoull(string1, &stop, 0); /* INTL: Tcl source. */ -#endif - if (stop == end) { - if (errno == ERANGE) { - result = 0; - failat = -1; - } - break; - } - } - errno = 0; - strtod(string1, &stop); /* INTL: Tcl source. */ - if (errno == ERANGE) { - /* - * if (errno == ERANGE), then it was an over/underflow - * problem, but in this method, we only want to know - * yes or no, so bad flow returns 0 (false) and sets - * the failVarObj to the string length. - */ - result = 0; - failat = -1; - } else if (stop == string1) { - /* - * In this case, nothing like a number was found - */ - result = 0; - failat = 0; - } else { - /* - * Assume we sucked up one char per byte - * and then we go onto SPACE, since we are - * allowed trailing whitespace - */ - failat = stop - string1; - string1 = stop; - chcomp = Tcl_UniCharIsSpace; - } - break; - } - case STR_IS_GRAPH: - chcomp = Tcl_UniCharIsGraph; - break; - case STR_IS_INT: { - char *stop; - long int l = 0; + if (TclGetIntForIndexM(interp, objv[3], length2-1, &start) != TCL_OK){ + return TCL_ERROR; + } - if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) { - break; - } - /* - * Like STR_IS_DOUBLE, but we use strtoul. - * Since Tcl_GetIntFromObj already failed, - * we set result to 0. - */ - result = 0; - errno = 0; - l = strtol(string1, &stop, 0); /* INTL: Tcl source. */ - if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) { - /* - * if (errno == ERANGE), then it was an over/underflow - * problem, but in this method, we only want to know - * yes or no, so bad flow returns 0 (false) and sets - * the failVarObj to the string length. - */ - failat = -1; + /* + * Reread to prevent shimmering problems. + */ - } else if (stop == string1) { - /* - * In this case, nothing like a number was found - */ - failat = 0; - } else { - /* - * Assume we sucked up one char per byte - * and then we go onto SPACE, since we are - * allowed trailing whitespace - */ - failat = stop - string1; - string1 = stop; - chcomp = Tcl_UniCharIsSpace; - } - break; - } - case STR_IS_LOWER: - chcomp = Tcl_UniCharIsLower; - break; - case STR_IS_PRINT: - chcomp = Tcl_UniCharIsPrint; - break; - case STR_IS_PUNCT: - chcomp = Tcl_UniCharIsPunct; - break; - case STR_IS_SPACE: - chcomp = Tcl_UniCharIsSpace; - break; - case STR_IS_UPPER: - chcomp = Tcl_UniCharIsUpper; - break; - case STR_IS_WORD: - chcomp = Tcl_UniCharIsWordChar; - break; - case STR_IS_XDIGIT: { - for (; string1 < end; string1++, failat++) { - /* INTL: We assume unicode is bad for this class */ - if ((*((unsigned char *)string1) >= 0xC0) || - !isxdigit(*(unsigned char *)string1)) { - result = 0; - break; - } - } - break; - } - } - if (chcomp != NULL) { - for (; string1 < end; string1 += length2, failat++) { - length2 = TclUtfToUniChar(string1, &ch); - if (!chcomp(ch)) { - result = 0; - break; - } - } - } - str_is_done: - /* - * Only set the failVarObj when we will return 0 - * and we have indicated a valid fail index (>= 0) - */ - if ((result == 0) && (failVarObj != NULL)) { - Tcl_Obj *resPtr, *tmpPtr = Tcl_NewIntObj(failat); - - Tcl_IncrRefCount(tmpPtr); - resPtr = Tcl_ObjSetVar2(interp, failVarObj, NULL, tmpPtr, - TCL_LEAVE_ERR_MSG); - Tcl_DecrRefCount(tmpPtr); - if (resPtr == NULL) { - return TCL_ERROR; - } - } - Tcl_SetBooleanObj(resultPtr, result); - break; + ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); + + if (start < 0) { + goto str_last_done; + } else if (start < length2) { + p = ustring2 + start + 1 - length1; + } else { + p = ustring2 + length2 - length1; } - case STR_LAST: { - Tcl_UniChar *ustring1, *ustring2, *p; - int match, start; + } else { + p = ustring2 + length2 - length1; + } - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, - "subString string ?startIndex?"); - return TCL_ERROR; - } + /* + * If the length of the needle is more than the length of the haystack, it + * cannot be contained in there so we can avoid searching. [Bug 2960021] + */ + if (length1 > 0 && length1 <= length2) { + for (; p >= ustring2; p--) { /* - * We are searching string2 for the sequence string1. + * Scan backwards to find the first character. */ - match = -1; - start = 0; - length2 = -1; + if ((*p == *ustring1) && !memcmp(ustring1, p, + sizeof(Tcl_UniChar) * (size_t)length1)) { + match = p - ustring2; + break; + } + } + } - ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); - ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); + str_last_done: + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringIndexCmd -- + * + * This procedure is invoked to process the "string index" 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. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - 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; - } +static int +StringIndexCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int length, index; - 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; - } - } - } + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "string charIndex"); + return TCL_ERROR; + } - str_last_done: - Tcl_SetIntObj(resultPtr, match); - break; + /* + * 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[1]->typePtr == &tclByteArrayType) { + const unsigned char *string = + Tcl_GetByteArrayFromObj(objv[1], &length); + + if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK){ + return TCL_ERROR; } - case STR_BYTELENGTH: - case STR_LENGTH: { - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "string"); - return TCL_ERROR; - } + string = Tcl_GetByteArrayFromObj(objv[1], &length); + if ((index >= 0) && (index < length)) { + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(string + index, 1)); + } + } else { + /* + * Get Unicode char length to calulate what 'end' means. + */ - 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. - */ + length = Tcl_GetCharLength(objv[1]); - if (objv[2]->typePtr == &tclByteArrayType) { - (void) Tcl_GetByteArrayFromObj(objv[2], &length1); - } else { - length1 = Tcl_GetCharLength(objv[2]); - } - } - Tcl_SetIntObj(resultPtr, length1); - break; + if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK){ + return TCL_ERROR; } - case STR_MAP: { - int mapElemc, nocase = 0, copySource = 0; - Tcl_Obj **mapElemv, *sourceObj; - Tcl_UniChar *ustring1, *ustring2, *p, *end; - int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*, - CONST Tcl_UniChar*, unsigned long)); - - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string"); - return TCL_ERROR; - } + if ((index >= 0) && (index < length)) { + char buf[TCL_UTF_MAX]; + Tcl_UniChar ch; - 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; - } - } + ch = Tcl_GetUniChar(objv[1], index); + length = Tcl_UniCharToUtf(ch, buf); + Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length)); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringIsCmd -- + * + * This procedure is invoked to process the "string is" 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. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - 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; - } +static int +StringIsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *string1, *end, *stop; + Tcl_UniChar ch; + int (*chcomp)(int) = NULL; /* The UniChar comparison function. */ + int i, failat = 0, result = 1, strict = 0, index, length1, length2; + Tcl_Obj *objPtr, *failVarObj = NULL; + Tcl_WideInt w; + + static const char *isClasses[] = { + "alnum", "alpha", "ascii", "control", + "boolean", "digit", "double", "false", + "graph", "integer", "list", "lower", + "print", "punct", "space", "true", + "upper", "wideinteger", "wordchar", "xdigit", + NULL + }; + enum isClasses { + 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_LIST, STR_IS_LOWER, + STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, + STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT + }; + static const char *isOptions[] = { + "-strict", "-failindex", NULL + }; + enum isOptions { + OPT_STRICT, OPT_FAILIDX + }; - /* - * Take a copy of the source string object if it is the - * same as the map string to cut out nasty sharing - * crashes. [Bug 1018562] - */ - if (objv[objc-2] == objv[objc-1]) { - sourceObj = Tcl_DuplicateObj(objv[objc-1]); - copySource = 1; - } else { - sourceObj = objv[objc-1]; + if (objc < 3 || objc > 6) { + Tcl_WrongNumArgs(interp, 1, objv, + "class ?-strict? ?-failindex var? str"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], isClasses, "class", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + if (objc != 3) { + for (i = 2; i < objc-1; i++) { + int idx2; + + if (Tcl_GetIndexFromObj(interp, objv[i], isOptions, "option", 0, + &idx2) != TCL_OK) { + return TCL_ERROR; } - ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1); - if (length1 == 0) { - /* - * Empty input string, just stop now - */ - if (copySource) { - Tcl_DecrRefCount(sourceObj); + switch ((enum isOptions) idx2) { + case OPT_STRICT: + strict = 1; + break; + case OPT_FAILIDX: + if (i+1 >= objc-1) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-strict? ?-failindex var? str"); + return TCL_ERROR; } + failVarObj = objv[++i]; break; } - end = ustring1 + length1; + } + } + + /* + * 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). + */ - strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; + objPtr = objv[objc-1]; - /* - * Force result to be Unicode - */ - Tcl_SetUnicodeObj(resultPtr, ustring1, 0); + /* + * When entering here, result == 1 and failat == 0. + */ - if (mapElemc == 2) { - /* - * Special case for one map pair which avoids the extra - * for loop and extra calls to get Unicode data. The - * algorithm is otherwise identical to the multi-pair case. - * This will be >30% faster on larger strings. - */ - int mapLen; - Tcl_UniChar *mapString, u2lc; - - ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); - p = ustring1; - if ((length2 > length1) || (length2 == 0)) { - /* match string is either longer than input or empty */ - ustring1 = end; - } else { - mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); - u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); - for (; ustring1 < end; ustring1++) { - if (((*ustring1 == *ustring2) || - (nocase && (Tcl_UniCharToLower(*ustring1) == - u2lc))) && - ((length2 == 1) || strCmpFn(ustring1, ustring2, - (unsigned long) length2) == 0)) { - if (p != ustring1) { - Tcl_AppendUnicodeToObj(resultPtr, p, - ustring1 - p); - p = ustring1 + length2; - } else { - p += length2; - } - ustring1 = p - 1; - - Tcl_AppendUnicodeToObj(resultPtr, mapString, - mapLen); - } - } - } + switch ((enum isClasses) index) { + case STR_IS_ALNUM: + chcomp = Tcl_UniCharIsAlnum; + break; + case STR_IS_ALPHA: + chcomp = Tcl_UniCharIsAlpha; + break; + case STR_IS_ASCII: + chcomp = UniCharIsAscii; + break; + case STR_IS_BOOL: + case STR_IS_TRUE: + case STR_IS_FALSE: + if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, &tclBooleanType)) { + if (strict) { + result = 0; } else { - Tcl_UniChar **mapStrings, *u2lc = NULL; - int *mapLens; - /* - * Precompute pointers to the unicode string and length. - * This saves us repeated function calls later, - * significantly speeding up the algorithm. We only need - * the lowercase first char in the nocase case. - */ - mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2) - * sizeof(Tcl_UniChar *)); - mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int)); - if (nocase) { - u2lc = (Tcl_UniChar *) - ckalloc((mapElemc) * sizeof(Tcl_UniChar)); - } - for (index = 0; index < mapElemc; index++) { - mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], - &(mapLens[index])); - if (nocase && ((index % 2) == 0)) { - u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); - } - } - for (p = ustring1; ustring1 < end; ustring1++) { - for (index = 0; index < mapElemc; index += 2) { - /* - * Get the key string to match on. - */ - ustring2 = mapStrings[index]; - length2 = mapLens[index]; - if ((length2 > 0) && ((*ustring1 == *ustring2) || - (nocase && (Tcl_UniCharToLower(*ustring1) == - u2lc[index/2]))) && - /* restrict max compare length */ - ((end - ustring1) >= length2) && - ((length2 == 1) || strCmpFn(ustring2, ustring1, - (unsigned long) length2) == 0)) { - if (p != ustring1) { - /* - * Put the skipped chars onto the result first - */ - Tcl_AppendUnicodeToObj(resultPtr, p, - ustring1 - p); - p = ustring1 + length2; - } else { - p += length2; - } - /* - * Adjust len to be full length of matched string - */ - ustring1 = p - 1; - - /* - * Append the map value to the unicode string - */ - Tcl_AppendUnicodeToObj(resultPtr, - mapStrings[index+1], mapLens[index+1]); - break; - } - } - } - ckfree((char *) mapStrings); - ckfree((char *) mapLens); - if (nocase) { - ckfree((char *) u2lc); - } - } - if (p != ustring1) { - /* - * Put the rest of the unmapped chars onto result - */ - Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); - } - if (copySource) { - Tcl_DecrRefCount(sourceObj); - } + string1 = TclGetStringFromObj(objPtr, &length1); + result = length1 == 0; + } + } else if (((index == STR_IS_TRUE) && + objPtr->internalRep.longValue == 0) + || ((index == STR_IS_FALSE) && + objPtr->internalRep.longValue != 0)) { + result = 0; + } + break; + case STR_IS_CONTROL: + chcomp = Tcl_UniCharIsControl; + break; + case STR_IS_DIGIT: + chcomp = Tcl_UniCharIsDigit; + break; + case STR_IS_DOUBLE: { + /* TODO */ + if ((objPtr->typePtr == &tclDoubleType) || + (objPtr->typePtr == &tclIntType) || +#ifndef NO_WIDE_TYPE + (objPtr->typePtr == &tclWideIntType) || +#endif + (objPtr->typePtr == &tclBignumType)) { break; } - case STR_MATCH: { - Tcl_UniChar *ustring1, *ustring2; - int nocase = 0; - - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string"); - return TCL_ERROR; + string1 = TclGetStringFromObj(objPtr, &length1); + if (length1 == 0) { + if (strict) { + result = 0; } - - 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; - } + goto str_is_done; + } + end = string1 + length1; + if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, + (const char **) &stop, 0) != TCL_OK) { + result = 0; + failat = 0; + } else { + failat = stop - string1; + if (stop < end) { + result = 0; + TclFreeIntRep(objPtr); + objPtr->typePtr = NULL; } - ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1); - ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2); - Tcl_SetBooleanObj(resultPtr, TclUniCharMatch(ustring1, length1, - ustring2, length2, nocase)); + } + break; + } + case STR_IS_GRAPH: + chcomp = Tcl_UniCharIsGraph; + break; + case STR_IS_INT: + if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) { + break; + } + goto failedIntParse; + case STR_IS_WIDE: + if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) { break; } - case STR_RANGE: { - int first, last; - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "string first last"); - return TCL_ERROR; + failedIntParse: + string1 = TclGetStringFromObj(objPtr, &length1); + if (length1 == 0) { + if (strict) { + result = 0; } - + goto str_is_done; + } + result = 0; + if (failVarObj == NULL) { /* - * If we have a ByteArray object, avoid indexing in the - * Utf string since the byte array contains one byte per - * character. Otherwise, use the Unicode string rep to - * get the range. + * Don't bother computing the failure point if we're not going to + * return it. */ - if (objv[2]->typePtr == &tclByteArrayType) { - string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1); - length1--; + break; + } + end = string1 + length1; + if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, + (const char **) &stop, TCL_PARSE_INTEGER_ONLY) == TCL_OK) { + if (stop == end) { + /* + * Entire string parses as an integer, but rejected by + * Tcl_Get(Wide)IntFromObj() so we must have overflowed the + * target type, and our convention is to return failure at + * index -1 in that situation. + */ + + failat = -1; } else { /* - * Get the length in actual characters. + * Some prefix parsed as an integer, but not the whole string, + * so return failure index as the point where parsing stopped. + * Clear out the internal rep, since keeping it would leave + * *objPtr in an inconsistent state. */ - string1 = NULL; - length1 = Tcl_GetCharLength(objv[2]) - 1; - } - if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) - || (TclGetIntForIndex(interp, objv[4], length1, - &last) != TCL_OK)) { - return TCL_ERROR; + failat = stop - string1; + TclFreeIntRep(objPtr); + objPtr->typePtr = NULL; } + } else { + /* + * No prefix is a valid integer. Fail at beginning. + */ - if (first < 0) { - first = 0; - } - if (last >= length1) { - last = length1; - } - if (last >= first) { - if (string1 != NULL) { - int numBytes = last - first + 1; - resultPtr = Tcl_NewByteArrayObj( - (unsigned char *) &string1[first], numBytes); - Tcl_SetObjResult(interp, resultPtr); - } else { - Tcl_SetObjResult(interp, - Tcl_GetRange(objv[2], first, last)); - } - } + failat = 0; + } + break; + case STR_IS_LIST: + /* + * We ignore the strictness here, since empty strings are always + * well-formed lists. + */ + + if (TCL_OK == TclListObjLength(NULL, objPtr, &length2)) { break; } - case STR_REPEAT: { - int count; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "string count"); - return TCL_ERROR; - } + if (failVarObj != NULL) { + /* + * Need to figure out where the list parsing failed, which is + * fairly expensive. This is adapted from the core of + * SetListFromAny(). + */ - if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) { - return TCL_ERROR; - } + const char *elemStart, *nextElem; + int lenRemain, elemSize; + register const char *p; + + string1 = TclGetStringFromObj(objPtr, &length1); + end = string1 + length1; + failat = -1; + for (p=string1, lenRemain=length1; lenRemain > 0; + p=nextElem, lenRemain=end-nextElem) { + if (TCL_ERROR == TclFindElement(NULL, p, lenRemain, + &elemStart, &nextElem, &elemSize, NULL)) { + Tcl_Obj *tmpStr; - if (count == 1) { - Tcl_SetObjResult(interp, objv[2]); - } else if (count > 1) { - string1 = Tcl_GetStringFromObj(objv[2], &length1); - if (length1 > 0) { - /* - * Only build up a string that has data. Instead of - * building it up with repeated appends, we just allocate - * the necessary space once and copy the string value in. - * Check for overflow with back-division. [Bug #714106] - */ - length2 = length1 * count; - if ((length2 / count) != length1) { - char buf[TCL_INTEGER_SPACE+1]; - sprintf(buf, "%d", INT_MAX); - Tcl_AppendStringsToObj(resultPtr, - "string size overflow, must be less than ", - buf, (char *) NULL); - return TCL_ERROR; - } /* - * Include space for the NULL + * This is the simplest way of getting the number of + * characters parsed. Note that this is not the same as + * the number of bytes when parsing strings with non-ASCII + * characters in them. + * + * Skip leading spaces first. This is only really an issue + * if it is the first "element" that has the failure. */ - string2 = (char *) ckalloc((size_t) length2+1); - for (index = 0; index < count; index++) { - memcpy(string2 + (length1 * index), string1, - (size_t) length1); + + while (TclIsSpaceProc(*p)) { + p++; } - 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); + TclNewStringObj(tmpStr, string1, p-string1); + failat = Tcl_GetCharLength(tmpStr); + TclDecrRefCount(tmpStr); + break; } } - 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; + result = 0; + 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: + chcomp = UniCharIsHexDigit; + break; + } + + if (chcomp != NULL) { + string1 = TclGetStringFromObj(objPtr, &length1); + if (length1 == 0) { + if (strict) { + result = 0; + } + goto str_is_done; + } + end = string1 + length1; + for (; string1 < end; string1 += length2, failat++) { + length2 = TclUtfToUniChar(string1, &ch); + if (!chcomp(ch)) { + result = 0; + break; } + } + } - ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); - length1--; + /* + * Only set the failVarObj when we will return 0 and we have indicated a + * valid fail index (>= 0). + */ - if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) - || (TclGetIntForIndex(interp, objv[4], length1, - &last) != TCL_OK)) { - return TCL_ERROR; - } + str_is_done: + if ((result == 0) && (failVarObj != NULL) && + Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} - if ((last < first) || (last < 0) || (first > length1)) { - Tcl_SetObjResult(interp, objv[2]); - } else { - if (first < 0) { - first = 0; - } +static int +UniCharIsAscii( + int character) +{ + return (character >= 0) && (character < 0x80); +} - 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; - } +static int +UniCharIsHexDigit( + int character) +{ + return (character >= 0) && (character < 0x80) && isxdigit(character); +} + +/* + *---------------------------------------------------------------------- + * + * StringMapCmd -- + * + * This procedure is invoked to process the "string map" 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. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - string1 = Tcl_GetStringFromObj(objv[2], &length1); +static int +StringMapCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int length1, length2, mapElemc, index; + int nocase = 0, mapWithDict = 0, copySource = 0; + Tcl_Obj **mapElemv, *sourceObj, *resultPtr; + Tcl_UniChar *ustring1, *ustring2, *p, *end; + int (*strCmpFn)(const Tcl_UniChar*, const Tcl_UniChar*, unsigned long); + + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string"); + return TCL_ERROR; + } - 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. - */ + if (objc == 4) { + const char *string = TclGetStringFromObj(objv[1], &length2); - 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; + if ((length2 > 1) && + strncmp(string, "-nocase", (size_t) length2) == 0) { + nocase = 1; + } else { + Tcl_AppendResult(interp, "bad option \"", string, + "\": must be -nocase", NULL); + return TCL_ERROR; + } + } - 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; + /* + * This test is tricky, but has to be that way or you get other strange + * inconsistencies (see test string-10.20 for illustration why!) + */ - 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 (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){ + int i, done; + Tcl_DictSearch search; - 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. - */ + /* + * We know the type exactly, so all dict operations will succeed for + * sure. This shortens this code quite a bit. + */ - for (p = string1; p < end; p += offset) { - offset = TclUtfToUniChar(p, &ch); - - for (check = string2; ; ) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - string1 += offset; - break; - } - } - } - } - if (right) { - end = string1; + Tcl_DictObjSize(interp, objv[objc-2], &mapElemc); + if (mapElemc == 0) { + /* + * Empty charMap, just return whatever string was given. + */ - /* - * 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. - */ + Tcl_SetObjResult(interp, objv[objc-1]); + return TCL_OK; + } - for (p = string1 + length1; p > end; ) { - p = Tcl_UtfPrev(p, string1); - offset = TclUtfToUniChar(p, &ch); - for (check = string2; ; ) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - break; - } - } - } - } - Tcl_SetStringObj(resultPtr, string1, length1); - break; + mapElemc *= 2; + mapWithDict = 1; + + /* + * Copy the dictionary out into an array; that's the easiest way to + * adapt this code... + */ + + mapElemv = (Tcl_Obj **) + TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc); + Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0, + mapElemv+1, &done); + for (i=2 ; i<mapElemc ; i+=2) { + Tcl_DictObjNext(&search, mapElemv+i, mapElemv+i+1, &done); } - case STR_TRIMLEFT: { - left = 1; - right = 0; - goto dotrim; + Tcl_DictObjDone(&search); + } else { + if (TclListObjGetElements(interp, objv[objc-2], &mapElemc, + &mapElemv) != TCL_OK) { + return TCL_ERROR; } - case STR_TRIMRIGHT: { - left = 0; - right = 1; - goto dotrim; + 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_SetObjResult(interp, + Tcl_NewStringObj("char map list unbalanced", -1)); + return TCL_ERROR; } - case STR_WORDEND: { - int cur; - Tcl_UniChar ch; - CONST char *p, *end; - int numChars; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "string index"); - return TCL_ERROR; - } + } - string1 = Tcl_GetStringFromObj(objv[2], &length1); - numChars = Tcl_NumUtfChars(string1, length1); - if (TclGetIntForIndex(interp, objv[3], numChars-1, - &index) != TCL_OK) { - return TCL_ERROR; - } - if (index < 0) { - index = 0; - } - if (index < numChars) { - p = Tcl_UtfAtIndex(string1, index); - end = string1+length1; - for (cur = index; p < end; cur++) { - p += TclUtfToUniChar(p, &ch); - if (!Tcl_UniCharIsWordChar(ch)) { - break; + /* + * Take a copy of the source string object if it is the same as the map + * string to cut out nasty sharing crashes. [Bug 1018562] + */ + + if (objv[objc-2] == objv[objc-1]) { + sourceObj = Tcl_DuplicateObj(objv[objc-1]); + copySource = 1; + } else { + sourceObj = objv[objc-1]; + } + ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1); + if (length1 == 0) { + /* + * Empty input string, just stop now. + */ + + goto done; + } + end = ustring1 + length1; + + strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); + + /* + * Force result to be Unicode + */ + + resultPtr = Tcl_NewUnicodeObj(ustring1, 0); + + if (mapElemc == 2) { + /* + * Special case for one map pair which avoids the extra for loop and + * extra calls to get Unicode data. The algorithm is otherwise + * identical to the multi-pair case. This will be >30% faster on + * larger strings. + */ + + int mapLen; + Tcl_UniChar *mapString, u2lc; + + ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); + p = ustring1; + if ((length2 > length1) || (length2 == 0)) { + /* + * Match string is either longer than input or empty. + */ + + ustring1 = end; + } else { + mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); + u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); + for (; ustring1 < end; ustring1++) { + if (((*ustring1 == *ustring2) || + (nocase&&Tcl_UniCharToLower(*ustring1)==u2lc)) && + (length2==1 || strCmpFn(ustring1, ustring2, + (unsigned long) length2) == 0)) { + if (p != ustring1) { + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); + p = ustring1 + length2; + } else { + p += length2; } + ustring1 = p - 1; + + Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); } - 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; - } + } else { + Tcl_UniChar **mapStrings, *u2lc = NULL; + int *mapLens; - 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; + /* + * 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 **) TclStackAlloc(interp, + mapElemc * 2 * sizeof(Tcl_UniChar *)); + mapLens = (int *) TclStackAlloc(interp, mapElemc * 2 * sizeof(int)); + if (nocase) { + u2lc = (Tcl_UniChar *) TclStackAlloc(interp, + 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]); } - cur = 0; - if (index > 0) { - p = Tcl_UtfAtIndex(string1, index); - for (cur = index; cur >= 0; cur--) { - TclUtfToUniChar(p, &ch); - if (!Tcl_UniCharIsWordChar(ch)) { - break; + } + for (p = ustring1; ustring1 < end; ustring1++) { + for (index = 0; index < mapElemc; index += 2) { + /* + * Get the key string to match on. + */ + + ustring2 = mapStrings[index]; + length2 = mapLens[index]; + if ((length2 > 0) && ((*ustring1 == *ustring2) || (nocase && + (Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) && + /* Restrict max compare length. */ + (end-ustring1 >= length2) && ((length2 == 1) || + !strCmpFn(ustring2, ustring1, (unsigned) length2))) { + if (p != ustring1) { + /* + * Put the skipped chars onto the result first. + */ + + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); + p = ustring1 + length2; + } else { + p += length2; } - p = Tcl_UtfPrev(p, string1); - } - if (cur != index) { - cur += 1; + + /* + * 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; } } - Tcl_SetIntObj(resultPtr, cur); - break; } + if (nocase) { + TclStackFree(interp, u2lc); + } + TclStackFree(interp, mapLens); + TclStackFree(interp, mapStrings); + } + if (p != ustring1) { + /* + * Put the rest of the unmapped chars onto result. + */ + + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); + } + Tcl_SetObjResult(interp, resultPtr); + done: + if (mapWithDict) { + TclStackFree(interp, mapElemv); + } + if (copySource) { + Tcl_DecrRefCount(sourceObj); } return TCL_OK; } @@ -2464,11 +1997,11 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_SubstObjCmd -- + * StringMatchCmd -- * - * 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. + * This procedure is invoked to process the "string match" 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. * * Results: * A standard Tcl result. @@ -2479,94 +2012,49 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* 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 int +StringMatchCmd( + 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; + int nocase = 0; - /* - * 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"); + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string"); return TCL_ERROR; } - /* - * Perform the substitution. - */ - resultPtr = Tcl_SubstObj(interp, objv[i], flags); + if (objc == 4) { + int length; + const char *string = TclGetStringFromObj(objv[1], &length); - if (resultPtr == NULL) { - return TCL_ERROR; + if ((length > 1) && + strncmp(string, "-nocase", (size_t) length) == 0) { + nocase = TCL_MATCH_NOCASE; + } else { + Tcl_AppendResult(interp, "bad option \"", string, + "\": must be -nocase", NULL); + return TCL_ERROR; + } } - Tcl_SetObjResult(interp, resultPtr); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + TclStringMatchObj(objv[objc-1], objv[objc-2], nocase))); return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_SubstObj -- - * - * This function performs the substitutions specified on the - * given string as described in the user documentation for the - * "subst" Tcl command. This code is heavily based on an - * implementation by Andrew Payne. Note that if a command - * substitution returns TCL_CONTINUE or TCL_RETURN from its - * evaluation and is not completely well-formed, the results are - * not defined (or at least hard to characterise.) This fault - * will be fixed at some point, but the cost of the only sane - * fix (well-formedness check first) is such that you need to - * "precompile and cache" to stop everyone from being hit with - * the consequences every time through. Note that the current - * behaviour is not a security hole; it just restarts parsing - * the string following the substitution in a mildly surprising - * place, and it is a very bad idea to count on this remaining - * the same in future... + * StringRangeCmd -- + * + * This procedure is invoked to process the "string range" 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. * * Results: - * A Tcl_Obj* containing the substituted string, or NULL to - * indicate that an error occurred. + * A standard Tcl result. * * Side effects: * See the user documentation. @@ -2574,144 +2062,77 @@ Tcl_SubstObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ -Tcl_Obj * -Tcl_SubstObj(interp, objPtr, flags) - Tcl_Interp *interp; - Tcl_Obj *objPtr; - int flags; +static int +StringRangeCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *resultObj; - char *p, *old; - int length; + const unsigned char *string; + int length, first, last; - old = p = Tcl_GetStringFromObj(objPtr, &length); - resultObj = Tcl_NewStringObj("", 0); - while (length) { - switch (*p) { - case '\\': - if (flags & TCL_SUBST_BACKSLASHES) { - char buf[TCL_UTF_MAX]; - int count; - - if (p != old) { - Tcl_AppendToObj(resultObj, old, p-old); - } - Tcl_AppendToObj(resultObj, buf, - TclParseBackslash(p, length, &count, buf)); - p += count; length -= count; - old = p; - } else { - p++; length--; - } - break; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "string first last"); + return TCL_ERROR; + } - case '$': - if (flags & TCL_SUBST_VARIABLES) { - Tcl_Parse parse; - int code; + /* + * If we have a ByteArray object, avoid indexing in the Utf string since + * the byte array contains one byte per character. Otherwise, use the + * Unicode string rep to get the range. + */ - /* - * 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, length, &parse, 0) != TCL_OK) { - goto errorResult; - } - if (parse.numTokens == 1) { - /* - * There isn't a variable name after all: the $ is - * just a $. - */ - p++; length--; - break; - } - if (p != old) { - Tcl_AppendToObj(resultObj, old, p-old); - } - p += parse.tokenPtr->size; - length -= parse.tokenPtr->size; - code = Tcl_EvalTokensStandard(interp, parse.tokenPtr, - parse.numTokens); - if (code == TCL_ERROR) { - goto errorResult; - } - if (code == TCL_BREAK) { - Tcl_ResetResult(interp); - return resultObj; - } - if (code != TCL_CONTINUE) { - Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp)); - } - Tcl_ResetResult(interp); - old = p; - } else { - p++; length--; - } - break; + if (objv[1]->typePtr == &tclByteArrayType) { + string = Tcl_GetByteArrayFromObj(objv[1], &length); + length--; + } else { + /* + * Get the length in actual characters. + */ - case '[': - if (flags & TCL_SUBST_COMMANDS) { - Interp *iPtr = (Interp *) interp; - int code; + string = NULL; + length = Tcl_GetCharLength(objv[1]) - 1; + } - if (p != old) { - Tcl_AppendToObj(resultObj, old, p-old); - } - iPtr->evalFlags = TCL_BRACKET_TERM; - iPtr->numLevels++; - code = TclInterpReady(interp); - if (code == TCL_OK) { - code = Tcl_EvalEx(interp, p+1, length-1, 0); - } - iPtr->numLevels--; - switch (code) { - case TCL_ERROR: - goto errorResult; - case TCL_BREAK: - Tcl_ResetResult(interp); - return resultObj; - default: - Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp)); - case TCL_CONTINUE: - Tcl_ResetResult(interp); - old = p = (p+1 + iPtr->termOffset + 1); - length -= (iPtr->termOffset + 2); - } - } else { - p++; length--; - } - break; - default: - p++; length--; - break; - } + if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || + TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK) { + return TCL_ERROR; + } + + if (first < 0) { + first = 0; } - if (p != old) { - Tcl_AppendToObj(resultObj, old, p-old); + if (last >= length) { + last = length; } - return resultObj; + if (last >= first) { + if (string != NULL) { + /* + * Reread the string to prevent shimmering nasties. + */ - errorResult: - Tcl_DecrRefCount(resultObj); - return NULL; + string = Tcl_GetByteArrayFromObj(objv[1], &length); + Tcl_SetObjResult(interp, + Tcl_NewByteArrayObj(string+first, last - first + 1)); + } else { + Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); + } + } + return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_SwitchObjCmd -- + * StringReptCmd -- * - * This object-based procedure is invoked to process the "switch" Tcl - * command. See the user documentation for details on what it does. + * This procedure is invoked to process the "string repeat" 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. * * Results: - * A standard Tcl object result. + * A standard Tcl result. * * Side effects: * See the user documentation. @@ -2719,263 +2140,159 @@ Tcl_SubstObj(interp, objPtr, flags) *---------------------------------------------------------------------- */ - /* 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. */ +static int +StringReptCmd( + 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; -#ifdef TCL_TIP280 - Interp* iPtr = (Interp*) interp; - int pc = 0; - int bidx = 0; /* Index of body argument */ - Tcl_Obj* blist = NULL; /* List obj which is the body */ - CmdFrame ctx; /* Copy of the topmost cmdframe, - * to allow us to mess with the - * line information */ -#endif - static CONST char *options[] = { - "-exact", "-glob", "-regexp", "--", - NULL - }; - enum options { - OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST - }; + const char *string1; + char *string2; + int count, index, length1, length2; + Tcl_Obj *resultPtr; - 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 != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "string count"); + return TCL_ERROR; } - if (objc - i < 2) { - Tcl_WrongNumArgs(interp, 1, objv, - "?switches? string pattern body ... ?default body?"); + if (TclGetIntFromObj(interp, objv[2], &count) != TCL_OK) { return TCL_ERROR; } - stringObj = objv[i]; - objc -= i + 1; - objv += i + 1; -#ifdef TCL_TIP280 - bidx = i+1; /* First after the match string */ -#endif - /* - * If all of the pattern/command pairs are lumped into a single - * argument, split them out again. - * - * TIP #280: Determine the lines the words in the list start at, based on - * the same data for the list word itself. The cmdFramePtr line information - * is manipulated directly. + * Check for cases that allow us to skip copying stuff. */ - splitObjs = 0; - if (objc == 1) { - Tcl_Obj **listv; -#ifdef TCL_TIP280 - blist = objv[0]; -#endif - if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { - return TCL_ERROR; - } + if (count == 1) { + Tcl_SetObjResult(interp, objv[1]); + goto done; + } else if (count < 1) { + goto done; + } + string1 = TclGetStringFromObj(objv[1], &length1); + if (length1 <= 0) { + goto done; + } - /* - * Ensure that the list is non-empty. - */ + /* + * 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. + * + * We have to worry about overflow [Bugs 714106, 2561746]. + * At this point we know 1 <= length1 <= INT_MAX and 2 <= count <= INT_MAX. + * We need to keep 2 <= length2 <= INT_MAX. + */ - if (objc < 1) { - Tcl_WrongNumArgs(interp, 1, savedObjv, - "?switches? string {pattern body ... ?default body?}"); - return TCL_ERROR; - } - objv = listv; - splitObjs = 1; + if (count > (INT_MAX / length1)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "result exceeds max size for a Tcl value (%d bytes)", INT_MAX)); + return TCL_ERROR; } + length2 = length1 * count; /* - * Complain if there is an odd number of words in the list of - * patterns and bodies. + * Include space for the NUL. */ - if (objc % 2) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); - + string2 = attemptckalloc((unsigned) length2 + 1); + if (string2 == 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 '#'. + * Alloc failed. Note that in this case we try to do an error message + * since this is a case that's most likely when the alloc is large and + * that's easy to do with this API. Note that if we fail allocating a + * short string, this will likely keel over too (and fatally). */ - 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; - } - } - } - + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "string size overflow, out of memory allocating %u bytes", + length2 + 1)); return TCL_ERROR; } + for (index = 0; index < count; index++) { + memcpy(string2 + (length1 * index), string1, (size_t) length1); + } + string2[length2] = '\0'; /* - * Complain if the last body is a continuation. Note that this - * check assumes that the list is non-empty! + * We have to directly assign this instead of using Tcl_SetStringObj (and + * indirectly TclInitStringRep) because that makes another copy of the + * data. */ - 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; - } + TclNewObj(resultPtr); + resultPtr->bytes = string2; + resultPtr->length = length2; + Tcl_SetObjResult(interp, resultPtr); - /* - * We've got a match. Find a body to execute, skipping bodies - * that are "-". - * - * TIP#280: Now is also the time to determine a line number for the - * single-word case. - */ + done: + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringRplcCmd -- + * + * This procedure is invoked to process the "string replace" 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. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ -#ifdef TCL_TIP280 - ctx = *iPtr->cmdFramePtr; +static int +StringRplcCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_UniChar *ustring; + int first, last, length; - if (splitObjs) { - /* We have to perform the GetSrc and other type dependent handling - * of the frame here because we are munging with the line numbers, - * something the other commands like if, etc. are not doing. Them - * are fine with simply passing the CmdFrame through and having - * the special handling done in 'info frame', or the bc compiler - */ + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?"); + return TCL_ERROR; + } - if (ctx.type == TCL_LOCATION_BC) { - /* Note: Type BC => ctx.data.eval.path is not used. - * ctx.data.tebc.codePtr is used instead. - */ - TclGetSrcInfoForPc (&ctx); - pc = 1; - /* The line information in the cmdFrame is now a copy we do - * not own */ - } + ustring = Tcl_GetUnicodeFromObj(objv[1], &length); + length--; - if (ctx.type == TCL_LOCATION_SOURCE) { - int bline = ctx.line [bidx]; - if (bline >= 0) { - ctx.line = (int*) ckalloc (objc * sizeof(int)); - ctx.nline = objc; + if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || + TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK){ + return TCL_ERROR; + } - ListLines (blist, bline, objc, ctx.line, objv); - } else { - int k; - /* Dynamic code word ... All elements are relative to themselves */ + if ((last < first) || (last < 0) || (first > length)) { + Tcl_SetObjResult(interp, objv[1]); + } else { + Tcl_Obj *resultPtr; - ctx.line = (int*) ckalloc (objc * sizeof(int)); - ctx.nline = objc; - for (k=0; k < objc; k++) {ctx.line[k] = -1;} - } - } else { - int k; - /* Anything else ... No information, or dynamic ... */ + ustring = Tcl_GetUnicodeFromObj(objv[1], &length); + length--; - ctx.line = (int*) ckalloc (objc * sizeof(int)); - ctx.nline = objc; - for (k=0; k < objc; k++) {ctx.line[k] = -1;} - } + if (first < 0) { + first = 0; } -#endif - 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; - } + resultPtr = Tcl_NewUnicodeObj(ustring, first); + if (objc == 5) { + Tcl_AppendObjToObj(resultPtr, objv[4]); } -#ifndef TCL_TIP280 - result = Tcl_EvalObjEx(interp, objv[j], 0); -#else - /* TIP #280. Make invoking context available to switch branch */ - result = TclEvalObjEx(interp, objv[j], 0, &ctx, splitObjs ? j : bidx+j); - if (splitObjs) { - ckfree ((char*) ctx.line); - if (pc && (ctx.type == TCL_LOCATION_SOURCE)) { - /* Death of SrcInfo reference */ - Tcl_DecrRefCount (ctx.data.eval.path); - } - } -#endif - 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); + if (last < length) { + Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1, + length - last); } - return result; + Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } @@ -2983,13 +2300,14 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_TimeObjCmd -- + * StringRevCmd -- * - * This object-based procedure is invoked to process the "time" Tcl - * command. See the user documentation for details on what it does. + * This procedure is invoked to process the "string reverse" 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. * * Results: - * A standard Tcl object result. + * A standard Tcl result. * * Side effects: * See the user documentation. @@ -2997,1919 +2315,1618 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* 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. */ +static int +StringRevCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - register Tcl_Obj *objPtr; - Tcl_Obj *objs[4]; - register int i, result; - int count; - double totalMicroSec; - Tcl_Time start, stop; - - 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?"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); 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 ) ); - if (count <= 1) { - /* Use int obj since we know time is not fractional [Bug 1202178] */ - objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec); - } else { - objs[0] = Tcl_NewDoubleObj(totalMicroSec/count); - } - objs[1] = Tcl_NewStringObj("microseconds", -1); - objs[2] = Tcl_NewStringObj("per", -1); - objs[3] = Tcl_NewStringObj("iteration", -1); - Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs)); + + Tcl_SetObjResult(interp, TclStringObjReverse(objv[1])); return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_TraceObjCmd -- - * - * This procedure is invoked to process the "trace" Tcl command. - * See the user documentation for details on what it does. - * - * Standard syntax as of Tcl 8.4 is - * - * trace {add|info|remove} {command|variable} name ops cmd + * StringStartCmd -- * + * This procedure is invoked to process the "string wordstart" 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. * * 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. */ +static int +StringStartCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - int optionIndex; - char *name, *flagOps, *p; - /* Main sub commands to 'trace' */ - static CONST char *traceOptions[] = { - "add", "info", "remove", -#ifndef TCL_REMOVE_OBSOLETE_TRACES - "variable", "vdelete", "vinfo", -#endif - (char *) NULL - }; - /* 'OLD' options are pre-Tcl-8.4 style */ - enum traceOptions { - TRACE_ADD, TRACE_INFO, TRACE_REMOVE, -#ifndef TCL_REMOVE_OBSOLETE_TRACES - TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO -#endif - }; + Tcl_UniChar ch; + const char *p, *string; + int cur, index, length, numChars; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "string index"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, - "option", 0, &optionIndex) != TCL_OK) { + string = TclGetStringFromObj(objv[1], &length); + numChars = Tcl_NumUtfChars(string, length); + if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum traceOptions) optionIndex) { - case TRACE_ADD: - case TRACE_REMOVE: - case TRACE_INFO: { - /* - * All sub commands of trace add/remove must take at least - * one more argument. Beyond that we let the subcommand itself - * control the argument structure. - */ - int typeIndex; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, - "option", 0, &typeIndex) != TCL_OK) { - return TCL_ERROR; - } - return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); - } -#ifndef TCL_REMOVE_OBSOLETE_TRACES - case TRACE_OLD_VARIABLE: - case TRACE_OLD_VDELETE: { - Tcl_Obj *copyObjv[6]; - Tcl_Obj *opsList; - int code, numFlags; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); - return TCL_ERROR; - } - - opsList = Tcl_NewObj(); - Tcl_IncrRefCount(opsList); - flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); - if (numFlags == 0) { - Tcl_DecrRefCount(opsList); - goto badVarOps; - } - for (p = flagOps; *p != 0; p++) { - if (*p == 'r') { - Tcl_ListObjAppendElement(NULL, opsList, - Tcl_NewStringObj("read", -1)); - } else if (*p == 'w') { - Tcl_ListObjAppendElement(NULL, opsList, - Tcl_NewStringObj("write", -1)); - } else if (*p == 'u') { - Tcl_ListObjAppendElement(NULL, opsList, - Tcl_NewStringObj("unset", -1)); - } else if (*p == 'a') { - Tcl_ListObjAppendElement(NULL, opsList, - Tcl_NewStringObj("array", -1)); - } else { - Tcl_DecrRefCount(opsList); - goto badVarOps; - } - } - copyObjv[0] = NULL; - memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *)); - copyObjv[4] = opsList; - if (optionIndex == TRACE_OLD_VARIABLE) { - code = (traceSubCmds[2])(interp,TRACE_ADD,objc+1,copyObjv); - } else { - code = (traceSubCmds[2])(interp,TRACE_REMOVE,objc+1,copyObjv); + string = TclGetStringFromObj(objv[1], &length); + if (index >= numChars) { + index = numChars - 1; + } + cur = 0; + if (index > 0) { + p = Tcl_UtfAtIndex(string, index); + for (cur = index; cur >= 0; cur--) { + TclUtfToUniChar(p, &ch); + if (!Tcl_UniCharIsWordChar(ch)) { + break; } - Tcl_DecrRefCount(opsList); - return code; + p = Tcl_UtfPrev(p, string); } - 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; + if (cur != index) { + cur += 1; } -#endif /* TCL_REMOVE_OBSOLETE_TRACES */ } + Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); return TCL_OK; - - badVarOps: - Tcl_AppendResult(interp, "bad operations \"", flagOps, - "\": should be one or more of rwua", (char *) NULL); - return TCL_ERROR; } - /* *---------------------------------------------------------------------- * - * TclTraceExecutionObjCmd -- + * StringEndCmd -- * - * Helper function for Tcl_TraceObjCmd; implements the - * [trace {add|remove|info} execution ...] subcommands. - * See the user documentation for details on what these do. + * This procedure is invoked to process the "string wordend" 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. * * Results: - * Standard Tcl result. + * A standard Tcl result. * * Side effects: - * Depends on the operation (add, remove, or info) being performed; - * may add or remove command traces on a command. + * See the user documentation. * *---------------------------------------------------------------------- */ -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. */ +static int +StringEndCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - int commandLength, index; - char *name, *command; - size_t length; - enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; - static CONST char *opStrings[] = { "enter", "leave", - "enterstep", "leavestep", (char *) NULL }; - enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE, - TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP }; - - switch ((enum traceOptions) optionIndex) { - case TRACE_ADD: - case TRACE_REMOVE: { - int flags = 0; - int i, listLen, result; - Tcl_Obj **elemPtrs; - if (objc != 6) { - Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); - return TCL_ERROR; - } - /* - * Make sure the ops argument is a list object; get its length and - * a pointer to its array of element pointers. - */ - - result = Tcl_ListObjGetElements(interp, objv[4], &listLen, - &elemPtrs); - if (result != TCL_OK) { - return result; - } - if (listLen == 0) { - Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of enter, leave, enterstep, or leavestep", - TCL_STATIC); - return TCL_ERROR; - } - for (i = 0; i < listLen; i++) { - if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, - "operation", TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum operations) index) { - case TRACE_EXEC_ENTER: - flags |= TCL_TRACE_ENTER_EXEC; - break; - case TRACE_EXEC_LEAVE: - flags |= TCL_TRACE_LEAVE_EXEC; - break; - case TRACE_EXEC_ENTER_STEP: - flags |= TCL_TRACE_ENTER_DURING_EXEC; - break; - case TRACE_EXEC_LEAVE_STEP: - flags |= TCL_TRACE_LEAVE_DURING_EXEC; - break; - } - } - command = Tcl_GetStringFromObj(objv[5], &commandLength); - length = (size_t) commandLength; - if ((enum traceOptions) optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr; - tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) - (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) - + length + 1)); - tcmdPtr->flags = flags; - tcmdPtr->stepTrace = NULL; - tcmdPtr->startLevel = 0; - tcmdPtr->startCmd = NULL; - tcmdPtr->length = length; - tcmdPtr->refCount = 1; - flags |= TCL_TRACE_DELETE; - if (flags & (TCL_TRACE_ENTER_DURING_EXEC | - TCL_TRACE_LEAVE_DURING_EXEC)) { - flags |= (TCL_TRACE_ENTER_EXEC | - TCL_TRACE_LEAVE_EXEC); - } - memcpy(tcmdPtr->command, command, length + 1); - name = Tcl_GetString(objv[3]); - if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, - (ClientData) tcmdPtr) != TCL_OK) { - ckfree((char *) tcmdPtr); - return TCL_ERROR; - } - } else { - /* - * Search through all of our traces on this command to - * see if there's one with the given command. If so, then - * delete the first one that matches. - */ - - TraceCommandInfo *tcmdPtr; - ClientData clientData = NULL; - name = Tcl_GetString(objv[3]); - - /* First ensure the name given is valid */ - if (Tcl_FindCommand(interp, name, NULL, - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != NULL) { - tcmdPtr = (TraceCommandInfo *) clientData; - /* - * In checking the 'flags' field we must remove any - * extraneous flags which may have been temporarily - * added by various pieces of the trace mechanism. - */ - if ((tcmdPtr->length == length) - && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | - TCL_TRACE_RENAME | - TCL_TRACE_DELETE)) == flags) - && (strncmp(command, tcmdPtr->command, - (size_t) length) == 0)) { - flags |= TCL_TRACE_DELETE; - if (flags & (TCL_TRACE_ENTER_DURING_EXEC | - TCL_TRACE_LEAVE_DURING_EXEC)) { - flags |= (TCL_TRACE_ENTER_EXEC | - TCL_TRACE_LEAVE_EXEC); - } - Tcl_UntraceCommand(interp, name, - flags, TraceCommandProc, clientData); - if (tcmdPtr->stepTrace != NULL) { - /* - * We need to remove the interpreter-wide trace - * which we created to allow 'step' traces. - */ - Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); - tcmdPtr->stepTrace = NULL; - if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); - } - } - if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { - /* Postpone deletion */ - tcmdPtr->flags = 0; - } - tcmdPtr->refCount--; - if (tcmdPtr->refCount < 0) { - Tcl_Panic("TclTraceExecutionObjCmd: negative TraceCommandInfo refCount"); - } - if (tcmdPtr->refCount == 0) { - ckfree((char*)tcmdPtr); - } - break; - } - } - } - break; - } - case TRACE_INFO: { - ClientData clientData; - Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 3, objv, "name"); - return TCL_ERROR; - } - - clientData = NULL; - name = Tcl_GetString(objv[3]); - - /* First ensure the name given is valid */ - if (Tcl_FindCommand(interp, name, NULL, - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - - resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != NULL) { - int numOps = 0; - - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + Tcl_UniChar ch; + const char *p, *end, *string; + int cur, index, length, numChars; - /* - * 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. - */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "string index"); + return TCL_ERROR; + } - elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - Tcl_IncrRefCount(elemObjPtr); - if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("enter",5)); - } - if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("leave",5)); - } - if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("enterstep",9)); - } - if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("leavestep",9)); - } - Tcl_ListObjLength(NULL, elemObjPtr, &numOps); - if (0 == numOps) { - Tcl_DecrRefCount(elemObjPtr); - continue; - } - eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); - Tcl_DecrRefCount(elemObjPtr); - elemObjPtr = NULL; - - Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, - Tcl_NewStringObj(tcmdPtr->command, -1)); - Tcl_ListObjAppendElement(interp, resultListPtr, - eachTraceObjPtr); + string = TclGetStringFromObj(objv[1], &length); + numChars = Tcl_NumUtfChars(string, length); + if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) { + return TCL_ERROR; + } + string = TclGetStringFromObj(objv[1], &length); + if (index < 0) { + index = 0; + } + if (index < numChars) { + p = Tcl_UtfAtIndex(string, index); + end = string+length; + for (cur = index; p < end; cur++) { + p += TclUtfToUniChar(p, &ch); + if (!Tcl_UniCharIsWordChar(ch)) { + break; } - Tcl_SetObjResult(interp, resultListPtr); - break; } + if (cur == index) { + cur++; + } + } else { + cur = numChars; } + Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); return TCL_OK; } - /* *---------------------------------------------------------------------- * - * TclTraceCommandObjCmd -- + * StringEqualCmd -- * - * Helper function for Tcl_TraceObjCmd; implements the - * [trace {add|info|remove} command ...] subcommands. - * See the user documentation for details on what these do. + * This procedure is invoked to process the "string equal" 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. * * Results: - * Standard Tcl result. + * A standard Tcl result. * * Side effects: - * Depends on the operation (add, remove, or info) being performed; - * may add or remove command traces on a command. + * See the user documentation. * *---------------------------------------------------------------------- */ -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. */ +static int +StringEqualCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + 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. - */ + /* + * 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/...). + */ - result = Tcl_ListObjGetElements(interp, objv[4], &listLen, - &elemPtrs); - if (result != TCL_OK) { - return result; + char *string1, *string2; + int length1, length2, i, match, length, nocase = 0, reqlength = -1; + typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); + strCmpFn_t strCmpFn; + + if (objc < 3 || objc > 6) { + str_cmp_args: + Tcl_WrongNumArgs(interp, 1, objv, + "?-nocase? ?-length int? string1 string2"); + return TCL_ERROR; + } + + for (i = 1; i < objc-2; i++) { + string2 = TclGetStringFromObj(objv[i], &length2); + if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { + nocase = 1; + } else if ((length2 > 1) + && !strncmp(string2, "-length", (size_t)length2)) { + if (i+1 >= objc-2) { + goto str_cmp_args; } - if (listLen == 0) { - Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of delete or rename", TCL_STATIC); + ++i; + if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { return TCL_ERROR; } - for (i = 0; i < listLen; i++) { - if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, - "operation", TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum operations) index) { - case TRACE_CMD_RENAME: - flags |= TCL_TRACE_RENAME; - break; - case TRACE_CMD_DELETE: - flags |= TCL_TRACE_DELETE; - break; - } - } - command = Tcl_GetStringFromObj(objv[5], &commandLength); - length = (size_t) commandLength; - if ((enum traceOptions) optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr; - tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) - (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) - + length + 1)); - tcmdPtr->flags = flags; - tcmdPtr->stepTrace = NULL; - tcmdPtr->startLevel = 0; - tcmdPtr->startCmd = NULL; - tcmdPtr->length = length; - tcmdPtr->refCount = 1; - flags |= TCL_TRACE_DELETE; - memcpy(tcmdPtr->command, command, length + 1); - name = Tcl_GetString(objv[3]); - if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, - (ClientData) tcmdPtr) != TCL_OK) { - ckfree((char *) tcmdPtr); - return TCL_ERROR; - } - } else { - /* - * Search through all of our traces on this command to - * see if there's one with the given command. If so, then - * delete the first one that matches. - */ - - TraceCommandInfo *tcmdPtr; - ClientData clientData = NULL; - name = Tcl_GetString(objv[3]); - - /* First ensure the name given is valid */ - if (Tcl_FindCommand(interp, name, NULL, - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != NULL) { - tcmdPtr = (TraceCommandInfo *) clientData; - if ((tcmdPtr->length == length) - && (tcmdPtr->flags == flags) - && (strncmp(command, tcmdPtr->command, - (size_t) length) == 0)) { - Tcl_UntraceCommand(interp, name, - flags | TCL_TRACE_DELETE, - TraceCommandProc, clientData); - tcmdPtr->flags |= TCL_TRACE_DESTROYED; - tcmdPtr->refCount--; - if (tcmdPtr->refCount < 0) { - Tcl_Panic("TclTraceCommandObjCmd: negative TraceCommandInfo refCount"); - } - if (tcmdPtr->refCount == 0) { - ckfree((char *) tcmdPtr); - } - break; - } - } - } - break; + } else { + Tcl_AppendResult(interp, "bad option \"", string2, + "\": must be -nocase or -length", NULL); + return TCL_ERROR; } - case TRACE_INFO: { - ClientData clientData; - Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 3, objv, "name"); - return TCL_ERROR; - } + } - clientData = NULL; - name = Tcl_GetString(objv[3]); - - /* First ensure the name given is valid */ - if (Tcl_FindCommand(interp, name, NULL, - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - - resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != NULL) { - int numOps = 0; + /* + * From now on, we only access the two objects at the end of the argument + * array. + */ - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + objv += objc-2; - /* - * 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. - */ + if ((reqlength == 0) || (objv[0] == objv[1])) { + /* + * Always match at 0 chars of if it is the same obj. + */ - elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - Tcl_IncrRefCount(elemObjPtr); - if (tcmdPtr->flags & TCL_TRACE_RENAME) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("rename",6)); - } - if (tcmdPtr->flags & TCL_TRACE_DELETE) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("delete",6)); - } - Tcl_ListObjLength(NULL, elemObjPtr, &numOps); - if (0 == numOps) { - Tcl_DecrRefCount(elemObjPtr); - continue; - } - eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); - Tcl_DecrRefCount(elemObjPtr); - - elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); - Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); - Tcl_ListObjAppendElement(interp, resultListPtr, - eachTraceObjPtr); - } - Tcl_SetObjResult(interp, resultListPtr); - break; + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); + return TCL_OK; + } + + 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 = (strCmpFn_t) 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 = (strCmpFn_t) + (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 NUL (\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 *) TclGetStringFromObj(objv[0], &length1); + string2 = (char *) TclGetStringFromObj(objv[1], &length2); + if ((reqlength < 0) && !nocase) { + strCmpFn = (strCmpFn_t) TclpUtfNcmp2; + } else { + length1 = Tcl_NumUtfChars(string1, length1); + length2 = Tcl_NumUtfChars(string2, length2); + strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); + } + } + + if ((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; } } + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); return TCL_OK; } - /* *---------------------------------------------------------------------- * - * TclTraceVariableObjCmd -- + * StringCmpCmd -- * - * Helper function for Tcl_TraceObjCmd; implements the - * [trace {add|info|remove} variable ...] subcommands. - * See the user documentation for details on what these do. + * This procedure is invoked to process the "string compare" 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. * * Results: - * Standard Tcl result. + * A standard Tcl result. * * Side effects: - * Depends on the operation (add, remove, or info) being performed; - * may add or remove variable traces on a variable. + * See the user documentation. * *---------------------------------------------------------------------- */ -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. */ +static int +StringCmpCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + 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. - */ + /* + * 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/...). + */ - 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) { - /* - * This code essentially mallocs together the VarTrace and the - * TraceVarInfo, then inlines the Tcl_TraceVar(). This is - * necessary in order to have the TraceVarInfo to be freed - * automatically when the VarTrace is freed [Bug 1348775] - */ + char *string1, *string2; + int length1, length2, i, match, length, nocase = 0, reqlength = -1; + typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); + strCmpFn_t strCmpFn; - CompoundVarTrace *compTracePtr; - TraceVarInfo *tvarPtr; - Var *varPtr, *arrayPtr; - VarTrace *tracePtr; - int flagMask; - - compTracePtr = (CompoundVarTrace *) ckalloc((unsigned) - (sizeof(CompoundVarTrace) - sizeof(tvarPtr->command) - + length + 1)); - tracePtr = &(compTracePtr->trace); - tvarPtr = &(compTracePtr->tvar); - tvarPtr->flags = flags; - if (objv[0] == NULL) { - tvarPtr->flags |= TCL_TRACE_OLD_STYLE; - } - tvarPtr->length = length; - flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; - memcpy(tvarPtr->command, command, length + 1); - name = Tcl_GetString(objv[3]); - flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; - varPtr = TclLookupVar(interp, name, NULL, - (flags & flagMask) | TCL_LEAVE_ERR_MSG, "trace", - /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { - ckfree((char *) tracePtr); - return TCL_ERROR; - } - flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES - | TCL_TRACE_UNSETS | TCL_TRACE_ARRAY - | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; -#ifndef TCL_REMOVE_OBSOLETE_TRACES - flagMask |= TCL_TRACE_OLD_STYLE; -#endif - tracePtr->traceProc = TraceVarProc; - tracePtr->clientData = (ClientData) tvarPtr; - tracePtr->flags = flags & flagMask; - tracePtr->nextPtr = varPtr->tracePtr; - varPtr->tracePtr = tracePtr; - } else { - /* - * Search through all of our traces on this variable to - * see if there's one with the given command. If so, then - * delete the first one that matches. - */ - - TraceVarInfo *tvarPtr; - ClientData clientData = 0; - name = Tcl_GetString(objv[3]); - while ((clientData = Tcl_VarTraceInfo(interp, name, 0, - TraceVarProc, clientData)) != 0) { - tvarPtr = (TraceVarInfo *) clientData; - if ((tvarPtr->length == length) - && ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags) - && (strncmp(command, tvarPtr->command, - (size_t) length) == 0)) { - Tcl_UntraceVar2(interp, name, NULL, - flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, - TraceVarProc, clientData); - break; - } - } + if (objc < 3 || objc > 6) { + str_cmp_args: + Tcl_WrongNumArgs(interp, 1, objv, + "?-nocase? ?-length int? string1 string2"); + return TCL_ERROR; + } + + for (i = 1; i < objc-2; i++) { + string2 = TclGetStringFromObj(objv[i], &length2); + if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { + nocase = 1; + } else if ((length2 > 1) + && !strncmp(string2, "-length", (size_t)length2)) { + if (i+1 >= objc-2) { + goto str_cmp_args; } - break; - } - case TRACE_INFO: { - ClientData clientData; - Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 3, objv, "name"); + ++i; + if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { return TCL_ERROR; } + } else { + Tcl_AppendResult(interp, "bad option \"", string2, + "\": must be -nocase or -length", NULL); + return TCL_ERROR; + } + } - resultListPtr = Tcl_GetObjResult(interp); - clientData = 0; - name = Tcl_GetString(objv[3]); - while ((clientData = Tcl_VarTraceInfo(interp, name, 0, - TraceVarProc, clientData)) != 0) { + /* + * From now on, we only access the two objects at the end of the argument + * array. + */ - TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + objv += objc-2; - /* - * 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. - */ + if ((reqlength == 0) || (objv[0] == objv[1])) { + /* + * Always match at 0 chars of if it is the same obj. + */ - elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - if (tvarPtr->flags & TCL_TRACE_ARRAY) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("array", 5)); - } - if (tvarPtr->flags & TCL_TRACE_READS) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("read", 4)); - } - if (tvarPtr->flags & TCL_TRACE_WRITES) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("write", 5)); - } - if (tvarPtr->flags & TCL_TRACE_UNSETS) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("unset", 5)); - } - eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + return TCL_OK; + } - elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); - Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); - Tcl_ListObjAppendElement(interp, resultListPtr, - eachTraceObjPtr); - } - Tcl_SetObjResult(interp, resultListPtr); - break; + 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 = (strCmpFn_t) 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 = (strCmpFn_t) + (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 NUL (\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 *) TclGetStringFromObj(objv[0], &length1); + string2 = (char *) TclGetStringFromObj(objv[1], &length2); + if ((reqlength < 0) && !nocase) { + strCmpFn = (strCmpFn_t) TclpUtfNcmp2; + } else { + length1 = Tcl_NumUtfChars(string1, length1); + length2 = Tcl_NumUtfChars(string2, length2); + strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); } } + + 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; + } + + Tcl_SetObjResult(interp, + Tcl_NewIntObj((match > 0) ? 1 : (match < 0) ? -1 : 0)); return TCL_OK; } - /* *---------------------------------------------------------------------- * - * Tcl_CommandTraceInfo -- + * StringBytesCmd -- * - * 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. + * This procedure is invoked to process the "string bytelength" 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. * * Results: - * The return value is the clientData value associated with - * a trace on the given command. Information will only be - * returned for a trace with proc as trace procedure. If - * the clientData argument is NULL then the first such trace is - * returned; otherwise, the next relevant one after the one - * given by clientData will be returned. If the command - * doesn't exist then an error message is left in the interpreter - * and NULL is returned. Also, if there are no (more) traces for - * the given command, NULL is returned. + * A standard Tcl result. * * Side effects: - * None. + * See the user documentation. * *---------------------------------------------------------------------- */ -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. */ +static int +StringBytesCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - Command *cmdPtr; - register CommandTrace *tracePtr; + int length; - cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, - NULL, TCL_LEAVE_ERR_MSG); - if (cmdPtr == NULL) { - return NULL; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); + return TCL_ERROR; } - /* - * 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; + (void) TclGetStringFromObj(objv[1], &length); + Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); + return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_TraceCommand -- + * StringLenCmd -- * - * 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. + * This procedure is invoked to process the "string length" 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. * * Results: - * A standard Tcl return value. + * A standard Tcl result. * * 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. + * See the user documentation. * *---------------------------------------------------------------------- */ -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. */ +static int +StringLenCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - Command *cmdPtr; - register CommandTrace *tracePtr; + int length; - cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, - NULL, TCL_LEAVE_ERR_MSG); - if (cmdPtr == NULL) { + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } /* - * Set up trace information. + * 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. */ - tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace)); - tracePtr->traceProc = proc; - tracePtr->clientData = clientData; - tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE - | TCL_TRACE_ANY_EXEC); - tracePtr->nextPtr = cmdPtr->tracePtr; - tracePtr->refCount = 1; - cmdPtr->tracePtr = tracePtr; - if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { - cmdPtr->flags |= CMD_HAS_EXEC_TRACES; + if (objv[1]->typePtr == &tclByteArrayType) { + (void) Tcl_GetByteArrayFromObj(objv[1], &length); + } else { + length = Tcl_GetCharLength(objv[1]); } + Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_UntraceCommand -- + * StringLowerCmd -- * - * Remove a previously-created trace for a command. + * This procedure is invoked to process the "string tolower" 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. * * Results: - * None. + * A standard Tcl result. * * 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. + * See the user documentation. * *---------------------------------------------------------------------- */ -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. */ +static int +StringLowerCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - 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; + int length1, length2; + char *string1, *string2; + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); + return TCL_ERROR; } - flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); + string1 = TclGetStringFromObj(objv[1], &length1); + + if (objc == 2) { + Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); + + length1 = Tcl_UtfToLower(TclGetString(resultPtr)); + Tcl_SetObjLength(resultPtr, length1); + Tcl_SetObjResult(interp, resultPtr); + } else { + int first, last; + const char *start, *end; + Tcl_Obj *resultPtr; - for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ; - prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { - if (tracePtr == NULL) { - return; + length1 = Tcl_NumUtfChars(string1, length1) - 1; + if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { + return TCL_ERROR; } - 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; + if (first < 0) { + first = 0; } - } - - /* - * 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. - */ + last = first; - for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { - if (activePtr->nextTracePtr == tracePtr) { - if (activePtr->reverseScan) { - activePtr->nextTracePtr = prevPtr; - } else { - activePtr->nextTracePtr = tracePtr->nextPtr; - } + if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, + &last) != TCL_OK)) { + return TCL_ERROR; } - } - if (prevPtr == NULL) { - cmdPtr->tracePtr = tracePtr->nextPtr; - } else { - prevPtr->nextPtr = tracePtr->nextPtr; - } - tracePtr->flags = 0; - - if ((--tracePtr->refCount) <= 0) { - ckfree((char*)tracePtr); - } - - if (hasExecTraces) { - for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ; - prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { - if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { - return; - } + + if (last >= length1) { + last = length1; } - /* - * None of the remaining traces on this command are execution - * traces. We therefore remove this flag: - */ - cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES; + if (last < first) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } + + string1 = TclGetStringFromObj(objv[1], &length1); + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); + resultPtr = Tcl_NewStringObj(string1, end - string1); + string2 = TclGetString(resultPtr) + (start - string1); + + length2 = Tcl_UtfToLower(string2); + Tcl_SetObjLength(resultPtr, length2 + (start - string1)); + + Tcl_AppendToObj(resultPtr, end, -1); + Tcl_SetObjResult(interp, resultPtr); } + + return TCL_OK; } /* *---------------------------------------------------------------------- * - * TraceCommandProc -- + * StringUpperCmd -- * - * This procedure is called to handle command changes that have - * been traced using the "trace" command, when using the - * 'rename' or 'delete' options. + * This procedure is invoked to process the "string toupper" 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. * * Results: - * None. + * A standard Tcl result. * * Side effects: - * Depends on the command associated with the trace. + * See the user documentation. * *---------------------------------------------------------------------- */ - /* 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. */ +static int +StringUpperCmd( + 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 stateCode; - Tcl_SavedResult state; - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; - int code; - Tcl_DString cmd; - - tcmdPtr->refCount++; - - if ((tcmdPtr->flags & flags) && !Tcl_InterpDeleted(interp)) { - /* - * Generate a command to execute by appending list elements - * for the old and new command name and the operation. - */ + int length1, length2; + char *string1, *string2; - 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); - } + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); + return TCL_ERROR; + } - /* - * Execute the command. Save the interp's result used for the - * command, including the value of iPtr->returnCode which may be - * modified when Tcl_Eval is invoked. We discard any object - * result the command returns. - * - * Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to - * other areas that this will be destroyed by us, otherwise a - * double-free might occur depending on what the eval does. - */ + string1 = TclGetStringFromObj(objv[1], &length1); - Tcl_SaveResult(interp, &state); - stateCode = iPtr->returnCode; - if (flags & TCL_TRACE_DESTROYED) { - tcmdPtr->flags |= TCL_TRACE_DESTROYED; + if (objc == 2) { + Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); + + length1 = Tcl_UtfToUpper(TclGetString(resultPtr)); + Tcl_SetObjLength(resultPtr, length1); + Tcl_SetObjResult(interp, resultPtr); + } else { + int first, last; + const char *start, *end; + Tcl_Obj *resultPtr; + + length1 = Tcl_NumUtfChars(string1, length1) - 1; + if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { + return TCL_ERROR; } + if (first < 0) { + first = 0; + } + last = first; - code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), - Tcl_DStringLength(&cmd), 0); - if (code != TCL_OK) { - /* We ignore errors in these traced commands */ + if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, + &last) != TCL_OK)) { + return TCL_ERROR; } - Tcl_RestoreResult(interp, &state); - iPtr->returnCode = stateCode; - - Tcl_DStringFree(&cmd); + if (last >= length1) { + last = length1; + } + if (last < first) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } + + string1 = TclGetStringFromObj(objv[1], &length1); + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); + resultPtr = Tcl_NewStringObj(string1, end - string1); + string2 = TclGetString(resultPtr) + (start - string1); + + length2 = Tcl_UtfToUpper(string2); + Tcl_SetObjLength(resultPtr, length2 + (start - string1)); + + Tcl_AppendToObj(resultPtr, end, -1); + Tcl_SetObjResult(interp, resultPtr); } - /* - * We delete when the trace was destroyed or if this is a delete trace, - * because command deletes are unconditional, so the trace must go away. - */ - if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) { - int untraceFlags = tcmdPtr->flags; - - if (tcmdPtr->stepTrace != NULL) { - Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); - tcmdPtr->stepTrace = NULL; - if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); - } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringTitleCmd -- + * + * This procedure is invoked to process the "string totitle" 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. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringTitleCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int length1, length2; + char *string1, *string2; + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); + return TCL_ERROR; + } + + string1 = TclGetStringFromObj(objv[1], &length1); + + if (objc == 2) { + Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); + + length1 = Tcl_UtfToTitle(TclGetString(resultPtr)); + Tcl_SetObjLength(resultPtr, length1); + Tcl_SetObjResult(interp, resultPtr); + } else { + int first, last; + const char *start, *end; + Tcl_Obj *resultPtr; + + length1 = Tcl_NumUtfChars(string1, length1) - 1; + if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { + return TCL_ERROR; } - if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { - /* Postpone deletion, until exec trace returns */ - tcmdPtr->flags = 0; + if (first < 0) { + first = 0; } + last = first; - /* - * We need to construct the same flags for Tcl_UntraceCommand - * as were passed to Tcl_TraceCommand. Reproduce the processing - * of [trace add execution/command]. Be careful to keep this - * code in sync with that. - */ + if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, + &last) != TCL_OK)) { + return TCL_ERROR; + } - if (untraceFlags & TCL_TRACE_ANY_EXEC) { - untraceFlags |= TCL_TRACE_DELETE; - if (untraceFlags & (TCL_TRACE_ENTER_DURING_EXEC - | TCL_TRACE_LEAVE_DURING_EXEC)) { - untraceFlags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); - } - } else if (untraceFlags & TCL_TRACE_RENAME) { - untraceFlags |= TCL_TRACE_DELETE; + if (last >= length1) { + last = length1; + } + if (last < first) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; } - /* - * Remove the trace since TCL_TRACE_DESTROYED tells us to, or the - * command we're tracing has just gone away. Then decrement the - * clientData refCount that was set up by trace creation. - * - * Note that we save the (return) state of the interpreter to prevent - * bizarre error messages. - */ + string1 = TclGetStringFromObj(objv[1], &length1); + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); + resultPtr = Tcl_NewStringObj(string1, end - string1); + string2 = TclGetString(resultPtr) + (start - string1); - Tcl_SaveResult(interp, &state); - stateCode = iPtr->returnCode; - Tcl_UntraceCommand(interp, oldName, untraceFlags, - TraceCommandProc, clientData); - Tcl_RestoreResult(interp, &state); - iPtr->returnCode = stateCode; + length2 = Tcl_UtfToTitle(string2); + Tcl_SetObjLength(resultPtr, length2 + (start - string1)); - tcmdPtr->refCount--; - } - tcmdPtr->refCount--; - if (tcmdPtr->refCount < 0) { - Tcl_Panic("TraceCommandProc: negative TraceCommandInfo refCount"); - } - if (tcmdPtr->refCount == 0) { - ckfree((char*)tcmdPtr); + Tcl_AppendToObj(resultPtr, end, -1); + Tcl_SetObjResult(interp, resultPtr); } - return; + + return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclCheckExecutionTraces -- + * StringTrimCmd -- * - * 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' + * This procedure is invoked to process the "string trim" 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. * * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR, etc. + * A standard Tcl result. * * Side effects: - * Those side effects made by any trace procedures called. + * See the user documentation. * *---------------------------------------------------------------------- */ -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. */ + +static int +StringTrimCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - 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.reverseScan = 1; - active.nextTracePtr = NULL; - tracePtr = cmdPtr->tracePtr; - while (tracePtr->nextPtr != lastTracePtr) { - active.nextTracePtr = tracePtr; - tracePtr = tracePtr->nextPtr; - } - } else { - active.reverseScan = 0; - active.nextTracePtr = tracePtr->nextPtr; - } - if (tracePtr->traceProc == TraceCommandProc) { - tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; - if (tcmdPtr->flags != 0) { - tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; - tcmdPtr->curCode = code; - tcmdPtr->refCount++; - traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, - curLevel, command, (Tcl_Command)cmdPtr, objc, objv); - tcmdPtr->refCount--; - if (tcmdPtr->refCount < 0) { - Tcl_Panic("TclCheckExecutionTraces: negative TraceCommandInfo refCount"); - } - if (tcmdPtr->refCount == 0) { - ckfree((char*)tcmdPtr); - } - } - } - if (active.nextTracePtr) { - lastTracePtr = active.nextTracePtr->nextPtr; - } + const char *string1, *string2; + int triml, trimr, length1, length2; + + if (objc == 3) { + string2 = TclGetStringFromObj(objv[2], &length2); + } else if (objc == 2) { + string2 = " \t\n\r"; + length2 = strlen(string2); + } else { + Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); + return TCL_ERROR; } - iPtr->activeCmdTracePtr = active.nextPtr; - return(traceCode); + string1 = TclGetStringFromObj(objv[1], &length1); + + triml = TclTrimLeft(string1, length1, string2, length2); + trimr = TclTrimRight(string1 + triml, length1 - triml, string2, length2); + + Tcl_SetObjResult(interp, + Tcl_NewStringObj(string1 + triml, length1 - triml - trimr)); + return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclCheckInterpTraces -- + * StringTrimLCmd -- * - * 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' + * This procedure is invoked to process the "string trimleft" 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. * * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR, etc. + * A standard Tcl result. * * Side effects: - * Those side effects made by any trace procedures called. + * See the user documentation. * *---------------------------------------------------------------------- */ -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. */ + +static int +StringTrimLCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - Interp *iPtr = (Interp *) interp; - Trace *tracePtr, *lastTracePtr; - ActiveInterpTrace active; - int curLevel; - int traceCode = TCL_OK; - - if (command == NULL || iPtr->tracePtr == NULL || - (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) { - return(traceCode); - } - - curLevel = iPtr->numLevels; - - active.nextPtr = iPtr->activeInterpTracePtr; - iPtr->activeInterpTracePtr = &active; - - lastTracePtr = NULL; - for ( tracePtr = iPtr->tracePtr; - (traceCode == TCL_OK) && (tracePtr != NULL); - tracePtr = active.nextTracePtr) { - if (traceFlags & TCL_TRACE_ENTER_EXEC) { - /* - * Execute the trace command in reverse order of creation - * for "enterstep" operation. The order is changed for - * "enterstep" instead of for "leavestep" as was done in - * TclCheckExecutionTraces because for step traces, - * Tcl_CreateObjTrace creates one more linked list of traces - * which results in one more reversal of trace invocation. - */ - active.reverseScan = 1; - active.nextTracePtr = NULL; - tracePtr = iPtr->tracePtr; - while (tracePtr->nextPtr != lastTracePtr) { - active.nextTracePtr = tracePtr; - tracePtr = tracePtr->nextPtr; - } - if (active.nextTracePtr) { - lastTracePtr = active.nextTracePtr->nextPtr; - } - } else { - active.reverseScan = 0; - active.nextTracePtr = tracePtr->nextPtr; - } - if (tracePtr->level > 0 && curLevel > tracePtr->level) { - continue; - } - if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) { - /* - * The proc invoked might delete the traced command which - * which might try to free tracePtr. We want to use tracePtr - * until the end of this if section, so we use - * Tcl_Preserve() and Tcl_Release() to be sure it is not - * freed while we still need it. - */ - Tcl_Preserve((ClientData) tracePtr); - tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; - - if (tracePtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) { - /* New style trace */ - if (tracePtr->flags & traceFlags) { - if (tracePtr->proc == TraceExecutionProc) { - TraceCommandInfo *tcmdPtr = - (TraceCommandInfo *) tracePtr->clientData; - tcmdPtr->curFlags = traceFlags; - tcmdPtr->curCode = code; - } - traceCode = (tracePtr->proc)(tracePtr->clientData, - interp, curLevel, command, (Tcl_Command)cmdPtr, - objc, objv); - } - } else { - /* Old-style trace */ - - if (traceFlags & TCL_TRACE_ENTER_EXEC) { - /* - * Old-style interpreter-wide traces only trigger - * before the command is executed. - */ - traceCode = CallTraceProcedure(interp, tracePtr, cmdPtr, - command, numChars, objc, objv); - } - } - tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; - Tcl_Release((ClientData) tracePtr); - } + const char *string1, *string2; + int trim, length1, length2; + + if (objc == 3) { + string2 = TclGetStringFromObj(objv[2], &length2); + } else if (objc == 2) { + string2 = " \t\n\r"; + length2 = strlen(string2); + } else { + Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); + return TCL_ERROR; } - iPtr->activeInterpTracePtr = active.nextPtr; - return(traceCode); + string1 = TclGetStringFromObj(objv[1], &length1); + + trim = TclTrimLeft(string1, length1, string2, length2); + + Tcl_SetObjResult(interp, Tcl_NewStringObj(string1+trim, length1-trim)); + return TCL_OK; } /* *---------------------------------------------------------------------- * - * CallTraceProcedure -- + * StringTrimRCmd -- * - * 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. + * This procedure is invoked to process the "string trimright" 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. * * Results: - * None. + * A standard Tcl result. * * Side effects: - * Those side effects made by the trace procedure. + * See the user documentation. * *---------------------------------------------------------------------- */ 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. */ +StringTrimRCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - Interp *iPtr = (Interp *) interp; - char *commandCopy; - int traceCode; + const char *string1, *string2; + int trim, length1, length2; + + if (objc == 3) { + string2 = TclGetStringFromObj(objv[2], &length2); + } else if (objc == 2) { + string2 = " \t\n\r"; + length2 = strlen(string2); + } else { + Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); + return TCL_ERROR; + } + string1 = TclGetStringFromObj(objv[1], &length1); - /* - * Copy the command characters into a new string. - */ + trim = TclTrimRight(string1, length1, string2, length2); - 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 ); + Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1-trim)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitStringCmd -- + * + * This procedure creates 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. + * + * Also 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. + * + *---------------------------------------------------------------------- + */ - ckfree((char *) commandCopy); - return(traceCode); +Tcl_Command +TclInitStringCmd( + Tcl_Interp *interp) /* Current interpreter. */ +{ + static const EnsembleImplMap stringImplMap[] = { + {"bytelength", StringBytesCmd, NULL}, + {"compare", StringCmpCmd, TclCompileStringCmpCmd}, + {"equal", StringEqualCmd, TclCompileStringEqualCmd}, + {"first", StringFirstCmd, NULL}, + {"index", StringIndexCmd, TclCompileStringIndexCmd}, + {"is", StringIsCmd, NULL}, + {"last", StringLastCmd, NULL}, + {"length", StringLenCmd, TclCompileStringLenCmd}, + {"map", StringMapCmd, NULL}, + {"match", StringMatchCmd, TclCompileStringMatchCmd}, + {"range", StringRangeCmd, NULL}, + {"repeat", StringReptCmd, NULL}, + {"replace", StringRplcCmd, NULL}, + {"reverse", StringRevCmd, NULL}, + {"tolower", StringLowerCmd, NULL}, + {"toupper", StringUpperCmd, NULL}, + {"totitle", StringTitleCmd, NULL}, + {"trim", StringTrimCmd, NULL}, + {"trimleft", StringTrimLCmd, NULL}, + {"trimright", StringTrimRCmd, NULL}, + {"wordend", StringEndCmd, NULL}, + {"wordstart", StringStartCmd, NULL}, + {NULL} + }; + + return TclMakeEnsemble(interp, "string", stringImplMap); } /* *---------------------------------------------------------------------- * - * CommandObjTraceDeleted -- + * Tcl_SubstObjCmd -- * - * Ensure the trace is correctly deleted by decrementing its - * refCount and only deleting if no other references exist. + * 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: - * None. + * A standard Tcl result. * * Side effects: - * May release memory. + * See the user documentation. * *---------------------------------------------------------------------- */ -static void -CommandObjTraceDeleted(ClientData clientData) { - TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; - tcmdPtr->refCount--; - if (tcmdPtr->refCount < 0) { - Tcl_Panic("CommandObjTraceDeleted: negative TraceCommandInfo refCount"); + +int +Tcl_SubstObjCmd( + 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", NULL + }; + enum substOptions { + SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS + }; + Tcl_Obj *resultPtr; + int flags, i; + + /* + * Parse command-line options. + */ + + flags = TCL_SUBST_ALL; + for (i = 1; i < (objc-1); i++) { + int optionIndex; + + 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: + Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); + } } - if (tcmdPtr->refCount == 0) { - ckfree((char*)tcmdPtr); + 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; } /* *---------------------------------------------------------------------- * - * TraceExecutionProc -- + * Tcl_SwitchObjCmd -- * - * 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. + * This object-based procedure is invoked to process the "switch" Tcl + * command. See the user documentation for details on what it does. * * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR, etc. + * A standard Tcl object result. * * Side effects: - * May invoke an arbitrary Tcl procedure, and may create or - * delete an interpreter-wide trace. + * See the user documentation. * *---------------------------------------------------------------------- */ -static int -TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, - int level, CONST char* command, Tcl_Command cmdInfo, - int objc, struct Tcl_Obj *CONST objv[]) { - int call = 0; + +int +Tcl_SwitchObjCmd( + 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, foundmode, result, splitObjs, numMatchesSaved; + int noCase, patternLength; + char *pattern; + Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; + Tcl_Obj *CONST *savedObjv = objv; + Tcl_RegExp regExpr = NULL; 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; + int pc = 0; + int bidx = 0; /* Index of body argument. */ + Tcl_Obj *blist = NULL; /* List obj which is the body */ + CmdFrame *ctxPtr; /* Copy of the topmost cmdframe, to allow us + * to mess with the line information */ + + /* + * If you add options that make -e and -g not unique prefixes of -exact or + * -glob, you *must* fix TclCompileSwitchCmd's option parser as well. + */ + + static CONST char *options[] = { + "-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp", + "--", NULL + }; + enum options { + OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, + OPT_LAST + }; + typedef int (*strCmpFn_t)(const char *, const char *); + strCmpFn_t strCmpFn = strcmp; + + mode = OPT_EXACT; + foundmode = 0; + indexVarObj = NULL; + matchVarObj = NULL; + numMatchesSaved = 0; + noCase = 0; + for (i = 1; i < objc-2; i++) { + if (TclGetString(objv[i])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + /* + * General options. + */ + + case OPT_LAST: + i++; + goto finishedOptions; + case OPT_NOCASE: + strCmpFn = strcasecmp; + noCase = 1; + break; + + /* + * Handle the different switch mode options. + */ + + default: + if (foundmode) { + /* + * Mode already set via -exact, -glob, or -regexp. + */ + + Tcl_AppendResult(interp, "bad option \"", + TclGetString(objv[i]), "\": ", options[mode], + " option already found", NULL); + return TCL_ERROR; + } else { + foundmode = 1; + mode = index; + break; + } + + /* + * Check for TIP#75 options specifying the variables to write + * regexp information into. + */ + + case OPT_INDEXV: + i++; + if (i >= objc-2) { + Tcl_AppendResult(interp, "missing variable name argument to ", + "-indexvar", " option", NULL); + return TCL_ERROR; + } + indexVarObj = objv[i]; + numMatchesSaved = -1; + break; + case OPT_MATCHV: + i++; + if (i >= objc-2) { + Tcl_AppendResult(interp, "missing variable name argument to ", + "-matchvar", " option", NULL); + return TCL_ERROR; + } + matchVarObj = objv[i]; + numMatchesSaved = -1; + break; + } } - - if (!Tcl_InterpDeleted(interp)) { + + finishedOptions: + if (objc - i < 2) { + Tcl_WrongNumArgs(interp, 1, objv, + "?switches? string pattern body ... ?default body?"); + return TCL_ERROR; + } + if (indexVarObj != NULL && mode != OPT_REGEXP) { + Tcl_AppendResult(interp, + "-indexvar option requires -regexp option", NULL); + return TCL_ERROR; + } + if (matchVarObj != NULL && mode != OPT_REGEXP) { + Tcl_AppendResult(interp, + "-matchvar option requires -regexp option", NULL); + return TCL_ERROR; + } + + stringObj = objv[i]; + objc -= i + 1; + objv += i + 1; + bidx = i + 1; /* First after the match string. */ + + /* + * If all of the pattern/command pairs are lumped into a single argument, + * split them out again. + * + * TIP #280: Determine the lines the words in the list start at, based on + * the same data for the list word itself. The cmdFramePtr line + * information is manipulated directly. + */ + + splitObjs = 0; + if (objc == 1) { + Tcl_Obj **listv; + blist = objv[0]; + + if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){ + return TCL_ERROR; + } + /* - * 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. + * Ensure that the list is non-empty. */ - if (flags & TCL_TRACE_EXEC_DIRECT) { - call = flags & tcmdPtr->flags - & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); - } else { - call = 1; + + 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); + /* - * 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. + * 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 (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); - } + + if (splitObjs) { + for (i=0 ; i<objc ; i+=2) { + if (TclGetString(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(TclGetString(objv[objc-1]), "-") == 0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "no body specified for pattern \"", + TclGetString(objv[objc-2]), "\"", NULL); + return TCL_ERROR; + } + + for (i = 0; i < objc; i += 2) { /* - * Second, create the tcl callback, if required. + * See if the pattern matches the string. */ - if (call) { - Tcl_SavedResult state; - int stateCode, i, saveInterpFlags; - Tcl_DString cmd; - Tcl_DString sub; - - 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"); + pattern = TclGetStringFromObj(objv[i], &patternLength); + + if ((i == objc - 2) && (*pattern == 'd') + && (strcmp(pattern, "default") == 0)) { + Tcl_Obj *emptyObj = NULL; + + /* + * If either indexVarObj or matchVarObj are non-NULL, we're in + * REGEXP mode but have reached the default clause anyway. TIP#75 + * specifies that we set the variables to empty lists (== empty + * objects) in that case. + */ + + if (indexVarObj != NULL) { + TclNewObj(emptyObj); + if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, emptyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; } - } 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"); + } + if (matchVarObj != NULL) { + if (emptyObj == NULL) { + TclNewObj(emptyObj); + } + if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, emptyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + } + goto matchFound; + } else { + switch (mode) { + case OPT_EXACT: + if (strCmpFn(TclGetString(stringObj), pattern) == 0) { + goto matchFound; + } + break; + case OPT_GLOB: + if (Tcl_StringCaseMatch(TclGetString(stringObj), pattern, + noCase)) { + goto matchFound; + } + break; + case OPT_REGEXP: + regExpr = Tcl_GetRegExpFromObj(interp, objv[i], + TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0)); + if (regExpr == NULL) { + return TCL_ERROR; } else { - Tcl_DStringAppendElement(&cmd, "leavestep"); + int matched = Tcl_RegExpExecObj(interp, regExpr, + stringObj, 0, numMatchesSaved, 0); + + if (matched < 0) { + return TCL_ERROR; + } else if (matched) { + goto matchFoundRegexp; + } } - } else { - panic("TraceExecutionProc: bad flag combination"); + break; } - - /* - * Execute the command. Save the interp's result used for - * the command, including the value of iPtr->returnCode which - * may be modified when Tcl_Eval is invoked. We discard any - * object result the command returns. - */ + } + } + return TCL_OK; - Tcl_SaveResult(interp, &state); - stateCode = iPtr->returnCode; - - saveInterpFlags = iPtr->flags; - iPtr->flags |= INTERP_TRACE_IN_PROGRESS; - tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; - tcmdPtr->refCount++; - /* - * This line can have quite arbitrary side-effects, - * including deleting the trace, the command being - * traced, or even the interpreter. - */ - traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); - tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; + matchFoundRegexp: + /* + * We are operating in REGEXP mode and we need to store information about + * what we matched in some user-nominated arrays. So build the lists of + * values and indices to write here. [TIP#75] + */ - /* - * Restore the interp tracing flag to prevent cmd traces - * from affecting interp traces - */ - iPtr->flags = saveInterpFlags;; - if (tcmdPtr->flags == 0) { - flags |= TCL_TRACE_DESTROYED; + if (numMatchesSaved) { + Tcl_RegExpInfo info; + Tcl_Obj *matchesObj, *indicesObj = NULL; + + Tcl_RegExpGetInfo(regExpr, &info); + if (matchVarObj != NULL) { + TclNewObj(matchesObj); + } else { + matchesObj = NULL; + } + if (indexVarObj != NULL) { + TclNewObj(indicesObj); + } + + for (j=0 ; j<=info.nsubs ; j++) { + if (indexVarObj != NULL) { + Tcl_Obj *rangeObjAry[2]; + + rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); + rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end); + + /* + * Never fails; the object is always clean at this point. + */ + + Tcl_ListObjAppendElement(NULL, indicesObj, + Tcl_NewListObj(2, rangeObjAry)); } - - if (traceCode == TCL_OK) { - /* Restore result if trace execution was successful */ - Tcl_RestoreResult(interp, &state); - iPtr->returnCode = stateCode; - } else { - Tcl_DiscardResult(&state); + + if (matchVarObj != NULL) { + Tcl_Obj *substringObj; + + substringObj = Tcl_GetRange(stringObj, + info.matches[j].start, info.matches[j].end-1); + + /* + * Never fails; the object is always clean at this point. + */ + + Tcl_ListObjAppendElement(NULL, matchesObj, substringObj); } + } - Tcl_DStringFree(&cmd); + if (indexVarObj != NULL) { + if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, indicesObj, + TCL_LEAVE_ERR_MSG) == NULL) { + /* + * Careful! Check to see if we have allocated the list of + * matched strings; if so (but there was an error assigning + * the indices list) we have a potential memory leak because + * the match list has not been written to a variable. Except + * that we'll clean that up right now. + */ + + if (matchesObj != NULL) { + Tcl_DecrRefCount(matchesObj); + } + return TCL_ERROR; + } + } + if (matchVarObj != NULL) { + if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, matchesObj, + TCL_LEAVE_ERR_MSG) == NULL) { + /* + * Unlike above, if indicesObj is non-NULL at this point, it + * will have been written to a variable already and will hence + * not be leaked. + */ + + return TCL_ERROR; + } } - + } + + /* + * We've got a match. Find a body to execute, skipping bodies that are + * "-". + */ + + matchFound: + ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); + *ctxPtr = *iPtr->cmdFramePtr; + + if (splitObjs) { /* - * 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. + * We have to perform the GetSrc and other type dependent handling of + * the frame here because we are munging with the line numbers, + * something the other commands like if, etc. are not doing. Them are + * fine with simply passing the CmdFrame through and having the + * special handling done in 'info frame', or the bc compiler */ - if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL) - && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | - TCL_TRACE_LEAVE_DURING_EXEC))) { - tcmdPtr->startLevel = level; - tcmdPtr->startCmd = - (char *) ckalloc((unsigned) (strlen(command) + 1)); - strcpy(tcmdPtr->startCmd, command); - tcmdPtr->refCount++; - tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, - (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, - TraceExecutionProc, (ClientData)tcmdPtr, - CommandObjTraceDeleted); + + if (ctxPtr->type == TCL_LOCATION_BC) { + /* + * Type BC => ctxPtr->data.eval.path is not used. + * ctxPtr->data.tebc.codePtr is used instead. + */ + + TclGetSrcInfoForPc(ctxPtr); + pc = 1; + + /* + * The line information in the cmdFrame is now a copy we do not + * own. + */ } - } - if (flags & TCL_TRACE_DESTROYED) { - if (tcmdPtr->stepTrace != NULL) { - Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); - tcmdPtr->stepTrace = NULL; - if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); + + if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) { + int bline = ctxPtr->line[bidx]; + + ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); + ctxPtr->nline = objc; + TclListLines(blist, bline, objc, ctxPtr->line, objv); + } else { + /* + * This is either a dynamic code word, when all elements are + * relative to themselves, or something else less expected and + * where we have no information. The result is the same in both + * cases; tell the code to come that it doesn't know where it is, + * which triggers reversion to the old behavior. + */ + + int k; + + ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); + ctxPtr->nline = objc; + for (k=0; k < objc; k++) { + ctxPtr->line[k] = -1; } } } - if (call) { - tcmdPtr->refCount--; - if (tcmdPtr->refCount < 0) { - Tcl_Panic("TraceExecutionProc: negative TraceCommandInfo refCount"); + + 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... + */ + + Tcl_Panic("fall-out when searching for body to match pattern"); } - if (tcmdPtr->refCount == 0) { - ckfree((char*)tcmdPtr); + if (strcmp(TclGetString(objv[j]), "-") != 0) { + break; } } - return traceCode; + + /* + * TIP #280: Make invoking context available to switch branch. + */ + + result = TclEvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j); + if (splitObjs) { + ckfree((char *) ctxPtr->line); + if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { + /* + * Death of SrcInfo reference. + */ + + Tcl_DecrRefCount(ctxPtr->data.eval.path); + } + } + + /* + * Generate an error message if necessary. + */ + + if (result == TCL_ERROR) { + int limit = 50; + int overflow = (patternLength > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"%.*s%s\" arm line %d)", + (overflow ? limit : patternLength), pattern, + (overflow ? "..." : ""), interp->errorLine)); + } + TclStackFree(interp, ctxPtr); + return result; } /* *---------------------------------------------------------------------- * - * TraceVarProc -- + * Tcl_TimeObjCmd -- * - * This procedure is called to handle variable accesses that have - * been traced using the "trace" command. + * This object-based procedure is invoked to process the "time" Tcl + * command. See the user documentation for details on what it does. * * Results: - * Normally returns NULL. If the trace command returns an error, - * then this procedure returns an error string. + * A standard Tcl object result. * * Side effects: - * Depends on the command associated with the trace. + * See the user documentation. * *---------------------------------------------------------------------- */ - /* 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. */ +int +Tcl_TimeObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { - Tcl_SavedResult state; - TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; - char *result; - int code, destroy = 0; - Tcl_DString cmd; - - /* - * We might call Tcl_Eval() below, and that might evaluate [trace - * vdelete] which might try to free tvarPtr. However we do not - * need to protect anything here; it's done by our caller because - * the TraceVarInfo is really part of a CompoundVarTrace. [Bug 1348775] - */ + register Tcl_Obj *objPtr; + Tcl_Obj *objs[4]; + register int i, result; + int count; + double totalMicroSec; +#ifndef TCL_WIDE_CLICKS + Tcl_Time start, stop; +#else + Tcl_WideInt start, stop; +#endif - result = NULL; - if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp)) { - if (tvarPtr->length != (size_t) 0) { - /* - * Generate a command to execute by appending list elements - * for the two variable names and the operation. - */ + if (objc == 2) { + count = 1; + } else if (objc == 3) { + result = TclGetIntFromObj(interp, objv[2], &count); + if (result != TCL_OK) { + return result; + } + } else { + Tcl_WrongNumArgs(interp, 1, objv, "command ?count?"); + return TCL_ERROR; + } - 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 { + objPtr = objv[1]; + i = count; +#ifndef TCL_WIDE_CLICKS + Tcl_GetTime(&start); +#else + start = TclpGetWideClicks(); #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 - } + while (i-- > 0) { + result = Tcl_EvalObjEx(interp, objPtr, 0); + if (result != TCL_OK) { + return result; + } + } +#ifndef TCL_WIDE_CLICKS + Tcl_GetTime(&stop); + totalMicroSec = ((double) (stop.sec - start.sec)) * 1.0e6 + + (stop.usec - start.usec); +#else + stop = TclpGetWideClicks(); + totalMicroSec = ((double) TclpWideClicksToNanoseconds(stop - start))/1.0e3; #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)) { - destroy = 1; - tvarPtr->flags |= TCL_TRACE_DESTROYED; - } + if (count <= 1) { + /* + * Use int obj since we know time is not fractional. [Bug 1202178] + */ - 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; - } + objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec); + } else { + objs[0] = Tcl_NewDoubleObj(totalMicroSec/count); + } - Tcl_RestoreResult(interp, &state); + /* + * Construct the result as a list because many programs have always parsed + * as such (extracting the first element, typically). + */ - Tcl_DStringFree(&cmd); - } - } - if (destroy) { - if (result != NULL) { - register Tcl_Obj *errMsgObj = (Tcl_Obj *) result; + TclNewLiteralStringObj(objs[1], "microseconds"); + TclNewLiteralStringObj(objs[2], "per"); + TclNewLiteralStringObj(objs[3], "iteration"); + Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs)); - Tcl_DecrRefCount(errMsgObj); - result = NULL; - } - } - return result; + return TCL_OK; } /* @@ -4917,108 +3934,115 @@ TraceVarProc(clientData, interp, name1, name2, flags) * * Tcl_WhileObjCmd -- * - * This procedure is invoked to process the "while" Tcl command. - * See the user documentation for details on what it does. + * 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} {}" + * 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. + * A standard Tcl result. * * Side effects: - * See the user documentation. + * 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. */ +Tcl_WhileObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { int result, value; -#ifdef TCL_TIP280 - Interp* iPtr = (Interp*) interp; -#endif + Interp *iPtr = (Interp *) interp; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "test command"); - return TCL_ERROR; + return TCL_ERROR; } while (1) { - result = Tcl_ExprBooleanObj(interp, objv[1], &value); - if (result != TCL_OK) { - return result; - } - if (!value) { - break; - } -#ifndef TCL_TIP280 - result = Tcl_EvalObjEx(interp, objv[2], 0); -#else - /* TIP #280. */ - result = TclEvalObjEx(interp, objv[2], 0, iPtr->cmdFramePtr,2); -#endif - if ((result != TCL_OK) && (result != TCL_CONTINUE)) { - if (result == TCL_ERROR) { - char msg[32 + TCL_INTEGER_SPACE]; + result = Tcl_ExprBooleanObj(interp, objv[1], &value); + if (result != TCL_OK) { + return result; + } + if (!value) { + break; + } - sprintf(msg, "\n (\"while\" body line %d)", - interp->errorLine); - Tcl_AddErrorInfo(interp, msg); - } - break; - } + /* TIP #280. */ + result = TclEvalObjEx(interp, objv[2], 0, iPtr->cmdFramePtr, 2); + if ((result != TCL_OK) && (result != TCL_CONTINUE)) { + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"while\" body line %d)", interp->errorLine)); + } + break; + } } if (result == TCL_BREAK) { - result = TCL_OK; + result = TCL_OK; } if (result == TCL_OK) { - Tcl_ResetResult(interp); + Tcl_ResetResult(interp); } return result; } -#ifdef TCL_TIP280 -static void -ListLines(listObj, line, n, lines, elems) - Tcl_Obj* listObj; /* Pointer to obj holding a string with list structure. - * Assumed to be valid. Assumed to contain n elements. - */ - int line; /* line the list as a whole starts on */ - int n; /* #elements in lines */ - int* lines; /* Array of line numbers, to fill */ - Tcl_Obj* const* elems; /* The list elems as Tcl_Obj*, in need of derived - * continuation data */ +/* + *---------------------------------------------------------------------- + * + * TclListLines -- + * + * ??? + * + * Results: + * Filled in array of line numbers? + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclListLines( + Tcl_Obj* listObj, /* Pointer to obj holding a string with list + * structure. Assumed to be valid. Assumed to + * contain n elements. + */ + int line, /* Line the list as a whole starts on. */ + int n, /* #elements in lines */ + int *lines, /* Array of line numbers, to fill. */ + Tcl_Obj* const* elems) /* The list elems as Tcl_Obj*, in need of + * derived continuation data */ { - int i; CONST char* listStr = Tcl_GetString (listObj); CONST char* listHead = listStr; - int length = strlen( listStr); - CONST char* element = NULL; - CONST char* next = NULL; + int i, length = strlen(listStr); + CONST char *element = NULL, *next = NULL; ContLineLoc* clLocPtr = TclContinuationsGet(listObj); - int* clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL); + int* clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL); for (i = 0; i < n; i++) { TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL); - TclAdvanceLines (&line, listStr, element); /* Leading whitespace */ + TclAdvanceLines(&line, listStr, element); + /* Leading whitespace */ TclAdvanceContinuations (&line, &clNext, element - listHead); - if (clNext) { - TclContinuationsEnterDerived (elems[i], element - listHead, clNext); + if (elems && clNext) { + TclContinuationsEnterDerived (elems[i], element - listHead, + clNext); } - - lines [i] = line; - length -= (next - listStr); - TclAdvanceLines (&line, element, next); /* Element */ - listStr = next; + lines[i] = line; + length -= (next - listStr); + TclAdvanceLines(&line, element, next); + /* Element */ + listStr = next; if (*element == 0) { /* ASSERT i == n */ @@ -5026,7 +4050,6 @@ ListLines(listObj, line, n, lines, elems) } } } -#endif /* * Local Variables: @@ -5035,4 +4058,3 @@ ListLines(listObj, line, n, lines, elems) * fill-column: 78 * End: */ - |