summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdMZ.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCmdMZ.c')
-rw-r--r--generic/tclCmdMZ.c6470
1 files changed, 2740 insertions, 3730 deletions
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 4ada397..0ad77aa 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 *CONST 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[] = {
+ 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,180 @@ 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_LINEANCHOR: {
- cflags |= TCL_REG_NLANCH;
- 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_START: {
- if (++i >= objc) {
- goto endOfForLoop;
- }
- if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) {
- return TCL_ERROR;
- }
- if (offset < 0) {
- offset = 0;
- }
- break;
+ if (TclGetIntForIndexM(interp, objv[i], 0, &temp) != TCL_OK) {
+ goto optionError;
}
- 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) {
+ eflags = 0;
+ } else if (offset > stringLength) {
+ eflags = TCL_REG_NOTBOL;
+ } else if (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 +285,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 +302,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 +326,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 +344,7 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv)
}
} else {
start = -1;
- end = -1;
+ end = -1;
}
objs[0] = Tcl_NewLongObj(start);
@@ -465,6 +364,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 +372,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 +381,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).
+ */
+
+ matchLength = info.matches[0].end - info.matches[0].start;
+ offset += info.matches[0].end;
+
/*
- * 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).
+ * A match of length zero could happen for {^} {$} or {.*} and in
+ * these cases we always want to bump the index up one.
*/
- if (info.matches[0].end == 0) {
+
+ 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 +428,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,22 +440,21 @@ 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[] = {
+ static const char *options[] = {
"-all", "-nocase", "-expanded",
"-line", "-linestop", "-lineanchor", "-start",
"--", NULL
@@ -568,95 +473,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 +587,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 +623,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 +644,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 +678,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 +699,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 +727,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 +741,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 +766,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 +785,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 +801,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 +837,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 +849,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 +885,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 +920,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 +932,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 +970,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 +982,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 +999,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 +1021,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 --
+ * StringFirstCmd --
*
- * This procedure is invoked to process the "string" Tcl command.
- * See the user documentation for details on what it does. Note
- * that this command only functions correctly on properly formed
- * Tcl UTF strings.
- *
- * Note that the primary methods here (equal, compare, match, ...)
- * have bytecode equivalents. You will find the code for those in
- * tclExecute.c. The code here will only be used in the non-bc
- * case (like in an 'eval').
+ * 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 +1117,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;
+ }
+ }
+ }
+
+ 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.
+ *
+ *----------------------------------------------------------------------
+ */
- ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
- ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
+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 (objc == 5) {
- /*
- * If a startIndex is specified, we will need to restrict
- * the string range to that char index in the string
- */
- if (TclGetIntForIndex(interp, objv[4], length2 - 1,
- &start) != TCL_OK) {
- return TCL_ERROR;
- }
- if (start < 0) {
- goto str_last_done;
- } else if (start < length2) {
- p = ustring2 + start + 1 - length1;
- } else {
- p = ustring2 + length2 - length1;
- }
- } else {
- p = ustring2 + length2 - length1;
- }
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "string charIndex");
+ return TCL_ERROR;
+ }
- 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 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.
+ */
- str_last_done:
- Tcl_SetIntObj(resultPtr, match);
- break;
+ 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 +2000,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 +2015,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 +2065,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 +2143,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 +2303,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,1938 +2318,1622 @@ 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;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * StringBytesCmd --
+ *
+ * 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:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+StringBytesCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ int length;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "string");
+ return TCL_ERROR;
+ }
+
+ (void) TclGetStringFromObj(objv[1], &length);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(length));
+ return TCL_OK;
+}
/*
*----------------------------------------------------------------------
*
- * Tcl_CommandTraceInfo --
+ * StringLenCmd --
*
- * 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 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:
- * 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
+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) {
- return NULL;
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "string");
+ return TCL_ERROR;
}
/*
- * Find the relevant trace, if any, and return its clientData.
+ * 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 = 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;
- }
+ if (objv[1]->typePtr == &tclByteArrayType) {
+ (void) Tcl_GetByteArrayFromObj(objv[1], &length);
+ } else {
+ length = Tcl_GetCharLength(objv[1]);
}
- return NULL;
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(length));
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_TraceCommand --
+ * StringLowerCmd --
*
- * 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 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:
- * 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
+StringLowerCmd(
+ 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 length1, length2;
+ char *string1, *string2;
- cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
- NULL, TCL_LEAVE_ERR_MSG);
- if (cmdPtr == NULL) {
+ if (objc < 2 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
- /*
- * Set up trace information.
- */
+ string1 = TclGetStringFromObj(objv[1], &length1);
- 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)) {
- cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
+ if (objc == 2) {
+ Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
- /*
- * Bug 3484621: New execution trace means we no longer compile
- * this command if we normally would. Invalidate bytecode.
- */
+ length1 = Tcl_UtfToLower(TclGetString(resultPtr));
+ Tcl_SetObjLength(resultPtr, length1);
+ Tcl_SetObjResult(interp, resultPtr);
+ } else {
+ int first, last;
+ const char *start, *end;
+ Tcl_Obj *resultPtr;
- if (cmdPtr->compileProc != NULL) {
- ((Interp *)interp)->compileEpoch++;
+ 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;
+
+ if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1,
+ &last) != TCL_OK)) {
+ return TCL_ERROR;
+ }
+
+ 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_UtfToLower(string2);
+ Tcl_SetObjLength(resultPtr, length2 + (start - string1));
+
+ Tcl_AppendToObj(resultPtr, end, -1);
+ Tcl_SetObjResult(interp, resultPtr);
}
+
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_UntraceCommand --
+ * StringUpperCmd --
*
- * Remove a previously-created trace for a command.
+ * 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:
- * 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
+StringUpperCmd(
+ 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_UtfToUpper(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;
+ }
+ if (last < first) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
}
- /*
- * None of the remaining traces on this command are execution
- * traces. We therefore remove this flag:
- */
- cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;
- /*
- * Bug 3484621: No more execution trace means we can compile
- * the command again. If we will, invalidate bytecode.
- */
+ 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);
- if (cmdPtr->compileProc != NULL) {
- ((Interp *)interp)->compileEpoch++;
- }
+ length2 = Tcl_UtfToUpper(string2);
+ Tcl_SetObjLength(resultPtr, length2 + (start - string1));
+
+ Tcl_AppendToObj(resultPtr, end, -1);
+ Tcl_SetObjResult(interp, resultPtr);
}
+
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * TraceCommandProc --
+ * StringTitleCmd --
*
- * 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 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:
- * 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
+StringTitleCmd(
+ 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);
- code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
- Tcl_DStringLength(&cmd), 0);
- if (code != TCL_OK) {
- /* We ignore errors in these traced commands */
- }
+ length1 = Tcl_UtfToTitle(TclGetString(resultPtr));
+ Tcl_SetObjLength(resultPtr, length1);
+ Tcl_SetObjResult(interp, resultPtr);
+ } else {
+ int first, last;
+ const char *start, *end;
+ Tcl_Obj *resultPtr;
- Tcl_RestoreResult(interp, &state);
- iPtr->returnCode = stateCode;
-
- Tcl_DStringFree(&cmd);
- }
- /*
- * We delete when the trace was destroyed or if this is a delete trace,
- * because command deletes are unconditional, so the trace must go away.
- */
- if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) {
- int untraceFlags = tcmdPtr->flags;
-
- if (tcmdPtr->stepTrace != NULL) {
- Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
- tcmdPtr->stepTrace = NULL;
- if (tcmdPtr->startCmd != NULL) {
- ckfree((char *)tcmdPtr->startCmd);
- }
+ 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, 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;
+ }
+ }
+
+ 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;
}
-
- if (!Tcl_InterpDeleted(interp)) {
+
+ 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");
+ 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;
+ }
+ }
+ 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, "enterstep");
+ int matched = Tcl_RegExpExecObj(interp, regExpr,
+ stringObj, 0, numMatchesSaved, 0);
+
+ if (matched < 0) {
+ return TCL_ERROR;
+ } else if (matched) {
+ goto matchFoundRegexp;
+ }
}
- } 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");
+ break;
+ }
+ }
+ }
+ return TCL_OK;
+
+ 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]
+ */
+
+ 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];
+
+ if (info.matches[j].end > 0) {
+ rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start);
+ rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end-1);
} else {
- Tcl_DStringAppendElement(&cmd, "leavestep");
+ rangeObjAry[0] = rangeObjAry[1] = Tcl_NewIntObj(-1);
}
- } else {
- panic("TraceExecutionProc: bad flag combination");
+
+ /*
+ * Never fails; the object is always clean at this point.
+ */
+
+ Tcl_ListObjAppendElement(NULL, indicesObj,
+ Tcl_NewListObj(2, rangeObjAry));
}
-
- /*
- * Execute the command. Save the interp's result used for
- * the command, including the value of iPtr->returnCode which
- * may be modified when Tcl_Eval is invoked. We discard any
- * object result the command returns.
- */
- Tcl_SaveResult(interp, &state);
- stateCode = iPtr->returnCode;
-
- 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;
+ if (matchVarObj != NULL) {
+ Tcl_Obj *substringObj;
- /*
- * Restore the interp tracing flag to prevent cmd traces
- * from affecting interp traces
- */
- iPtr->flags = saveInterpFlags;;
- if (tcmdPtr->flags == 0) {
- flags |= TCL_TRACE_DESTROYED;
+ 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);
}
-
- if (traceCode == TCL_OK) {
- /* Restore result if trace execution was successful */
- Tcl_RestoreResult(interp, &state);
- iPtr->returnCode = stateCode;
- } else {
- Tcl_DiscardResult(&state);
+ }
+
+ 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.
+ */
- Tcl_DStringFree(&cmd);
+ 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;
}
/*
@@ -4936,108 +3941,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;
+ const char* listStr = Tcl_GetString (listObj);
+ const char* listHead = listStr;
+ 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 */
@@ -5045,7 +4057,6 @@ ListLines(listObj, line, n, lines, elems)
}
}
}
-#endif
/*
* Local Variables:
@@ -5054,4 +4065,3 @@ ListLines(listObj, line, n, lines, elems)
* fill-column: 78
* End:
*/
-