通讯编程

开发平台：

Visual C++

tclCmdMZ.c：源码内容

/*
* 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).
*
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.29 2007/06/27 17:29:22 dgp Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"
#include "tclCompile.h"
/*
* Structures used to hold information about variable traces:
*/
typedef struct {
int flags; /* Operations for which Tcl command is
* to be invoked. */
size_t length; /* Number of non-NULL chars. in command. */
char command[4]; /* Space for Tcl command to invoke. Actual
* size will be as large as necessary to
* hold command. This field must be the
* last in the structure, so that it can
* be larger than 4 bytes. */
} TraceVarInfo;
typedef struct {
VarTrace trace;
TraceVarInfo tvar;
} CompoundVarTrace;
/*
* Structure used to hold information about command traces:
*/
typedef struct {
int flags; /* Operations for which Tcl command is
* to be invoked. */
size_t length; /* Number of non-NULL chars. in command. */
Tcl_Trace stepTrace; /* Used for execution traces, when tracing
* inside the given command */
int startLevel; /* Used for bookkeeping with step execution
* traces, store the level at which the step
* trace was invoked */
char *startCmd; /* Used for bookkeeping with step execution
* traces, store the command name which invoked
* step trace */
int curFlags; /* Trace flags for the current command */
int curCode; /* Return code for the current command */
int refCount; /* Used to ensure this structure is
* not deleted too early. Keeps track
* of how many pieces of code have
* a pointer to this structure. */
char command[4]; /* Space for Tcl command to invoke. Actual
* size will be as large as necessary to
* hold command. This field must be the
* last in the structure, so that it can
* be larger than 4 bytes. */
} TraceCommandInfo;
/*
* Used by command execution traces. Note that we assume in the code
* that the first two defines are exactly 4 times the
* 'TCL_TRACE_ENTER_EXEC' and 'TCL_TRACE_LEAVE_EXEC' constants.
*
* TCL_TRACE_ENTER_DURING_EXEC - Trace each command inside the command
* currently being traced, before execution.
* TCL_TRACE_LEAVE_DURING_EXEC - Trace each command inside the command
* currently being traced, after execution.
* TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags.
* TCL_TRACE_EXEC_IN_PROGRESS - The callback procedure on this trace
* is currently executing. Therefore we
* don't let further traces execute.
* TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly
* by the command being traced, not because
* of an internal trace.
* The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also
* be used in command execution traces.
*/
#define TCL_TRACE_ENTER_DURING_EXEC 4
#define TCL_TRACE_LEAVE_DURING_EXEC 8
#define TCL_TRACE_ANY_EXEC 15
#define TCL_TRACE_EXEC_IN_PROGRESS 0x10
#define TCL_TRACE_EXEC_DIRECT 0x20
/*
* Forward declarations for procedures defined in this file:
*/
typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp,
int optionIndex, int objc, Tcl_Obj *CONST objv[]));
Tcl_TraceTypeObjCmd TclTraceVariableObjCmd;
Tcl_TraceTypeObjCmd TclTraceCommandObjCmd;
Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd;
/*
* Each subcommand has a number of 'types' to which it can apply.
* Currently 'execution', 'command' and 'variable' are the only
* types supported. These three arrays MUST be kept in sync!
* In the future we may provide an API to add to the list of
* supported trace types.
*/
static CONST char *traceTypeOptions[] = {
"execution", "command", "variable", (char*) NULL
};
static Tcl_TraceTypeObjCmd* traceSubCmds[] = {
TclTraceExecutionObjCmd,
TclTraceCommandObjCmd,
TclTraceVariableObjCmd,
};
/*
* Declarations for local procedures to this file:
*/
static int CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
Trace *tracePtr, Command *cmdPtr,
CONST char *command, int numChars,
int objc, Tcl_Obj *CONST objv[]));
static char * TraceVarProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, CONST char *name1,
CONST char *name2, int flags));
static void TraceCommandProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, CONST char *oldName,
CONST char *newName, int flags));
static Tcl_CmdObjTraceProc TraceExecutionProc;
#ifdef TCL_TIP280
static void ListLines _ANSI_ARGS_((CONST char* listStr, int line,
int n, int* lines));
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_PwdObjCmd --
*
* This procedure is invoked to process the "pwd" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_PwdObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *retVal;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
retVal = Tcl_FSGetCwd(interp);
if (retVal == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, retVal);
Tcl_DecrRefCount(retVal);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_RegexpObjCmd --
*
* This procedure is invoked to process the "regexp" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_RegexpObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int i, indices, match, about, offset, all, doinline, numMatchesSaved;
int cflags, eflags, stringLength;
Tcl_RegExp regExpr;
Tcl_Obj *objPtr, *resultPtr;
Tcl_RegExpInfo info;
static CONST char *options[] = {
"-all", "-about", "-indices", "-inline",
"-expanded", "-line", "-linestop", "-lineanchor",
"-nocase", "-start", "--", (char *) NULL
};
enum options {
REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE,
REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR,
REGEXP_NOCASE, REGEXP_START, REGEXP_LAST
};
indices = 0;
about = 0;
cflags = TCL_REG_ADVANCED;
eflags = 0;
offset = 0;
all = 0;
doinline = 0;
for (i = 1; i < objc; i++) {
char *name;
int index;
name = Tcl_GetString(objv[i]);
if (name[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case REGEXP_ALL: {
all = 1;
break;
}
case REGEXP_INDICES: {
indices = 1;
break;
}
case REGEXP_INLINE: {
doinline = 1;
break;
}
case REGEXP_NOCASE: {
cflags |= TCL_REG_NOCASE;
break;
}
case REGEXP_ABOUT: {
about = 1;
break;
}
case REGEXP_EXPANDED: {
cflags |= TCL_REG_EXPANDED;
break;
}
case REGEXP_LINE: {
cflags |= TCL_REG_NEWLINE;
break;
}
case REGEXP_LINESTOP: {
cflags |= TCL_REG_NLSTOP;
break;
}
case REGEXP_LINEANCHOR: {
cflags |= TCL_REG_NLANCH;
break;
}
case REGEXP_START: {
if (++i >= objc) {
goto endOfForLoop;
}
if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) {
return TCL_ERROR;
}
if (offset < 0) {
offset = 0;
}
break;
}
case REGEXP_LAST: {
i++;
goto endOfForLoop;
}
}
}
endOfForLoop:
if ((objc - i) < (2 - about)) {
Tcl_WrongNumArgs(interp, 1, objv,
"?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
return TCL_ERROR;
}
objc -= i;
objv += i;
if (doinline && ((objc - 2) != 0)) {
/*
* User requested -inline, but specified match variables - a no-no.
*/
Tcl_AppendResult(interp, "regexp match variables not allowed",
" when using -inline", (char *) NULL);
return TCL_ERROR;
}
/*
* Handle the odd about case separately.
*/
if (about) {
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
* Get the length of the string that we are matching against so
* we can do the termination test for -all matches. Do this before
* getting the regexp to avoid shimmering problems.
*/
objPtr = objv[1];
stringLength = Tcl_GetCharLength(objPtr);
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if (regExpr == NULL) {
return TCL_ERROR;
}
if (offset > 0) {
/*
* Add flag if using offset (string is part of a larger string),
* so that "^" won't match.
*/
eflags |= TCL_REG_NOTBOL;
}
objc -= 2;
objv += 2;
resultPtr = Tcl_GetObjResult(interp);
if (doinline) {
/*
* Save all the subexpressions, as we will return them as a list
*/
numMatchesSaved = -1;
} else {
/*
* Save only enough subexpressions for matches we want to keep,
* expect in the case of -all, where we need to keep at least
* one to know where to move the offset.
*/
numMatchesSaved = (objc == 0) ? all : objc;
}
/*
* The following loop is to handle multiple matches within the
* same source string; each iteration handles one match. If "-all"
* hasn't been specified then the loop body only gets executed once.
* We terminate the loop when the starting offset is past the end of the
* string.
*/
while (1) {
match = Tcl_RegExpExecObj(interp, regExpr, objPtr,
offset /* offset */, numMatchesSaved, eflags
| ((offset > 0 &&
(Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'n'))
? TCL_REG_NOTBOL : 0));
if (match < 0) {
return TCL_ERROR;
}
if (match == 0) {
/*
* We want to set the value of the intepreter result only when
* this is the first time through the loop.
*/
if (all <= 1) {
/*
* If inlining, set the interpreter's object result to an
* empty list, otherwise set it to an integer object w/
* value 0.
*/
if (doinline) {
Tcl_SetListObj(resultPtr, 0, NULL);
} else {
Tcl_SetIntObj(resultPtr, 0);
}
return TCL_OK;
}
break;
}
/*
* If additional variable names have been specified, return
* index information in those variables.
*/
Tcl_RegExpGetInfo(regExpr, &info);
if (doinline) {
/*
* It's the number of substitutions, plus one for the matchVar
* at index 0
*/
objc = info.nsubs + 1;
}
for (i = 0; i < objc; i++) {
Tcl_Obj *newPtr;
if (indices) {
int start, end;
Tcl_Obj *objs[2];
/*
* Only adjust the match area if there was a match for
* that area. (Scriptics Bug 4391/SF Bug #219232)
*/
if (i <= info.nsubs && info.matches[i].start >= 0) {
start = offset + info.matches[i].start;
end = offset + info.matches[i].end;
/*
* Adjust index so it refers to the last character in the
* match instead of the first character after the match.
*/
if (end >= offset) {
end--;
}
} else {
start = -1;
end = -1;
}
objs[0] = Tcl_NewLongObj(start);
objs[1] = Tcl_NewLongObj(end);
newPtr = Tcl_NewListObj(2, objs);
} else {
if (i <= info.nsubs) {
newPtr = Tcl_GetRange(objPtr,
offset + info.matches[i].start,
offset + info.matches[i].end - 1);
} else {
newPtr = Tcl_NewObj();
}
}
if (doinline) {
if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
!= TCL_OK) {
Tcl_DecrRefCount(newPtr);
return TCL_ERROR;
}
} else {
Tcl_Obj *valuePtr;
Tcl_IncrRefCount(newPtr);
valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0);
Tcl_DecrRefCount(newPtr);
if (valuePtr == NULL) {
Tcl_AppendResult(interp, "couldn't set variable "",
Tcl_GetString(objv[i]), """, (char *) NULL);
return TCL_ERROR;
}
}
}
if (all == 0) {
break;
}
/*
* Adjust the offset to the character just after the last one
* in the matchVar and increment all to count how many times
* we are making a match. We always increment the offset by at least
* one to prevent endless looping (as in the case:
* regexp -all {a*} a). Otherwise, when we match the NULL string at
* the end of the input string, we will loop indefinately (because the
* length of the match is 0, so offset never changes).
*/
if (info.matches[0].end == 0) {
offset++;
}
offset += info.matches[0].end;
all++;
eflags |= TCL_REG_NOTBOL;
if (offset >= stringLength) {
break;
}
}
/*
* Set the interpreter's object result to an integer object
* with value 1 if -all wasn't specified, otherwise it's all-1
* (the number of times through the while - 1).
* Get the resultPtr again as the Tcl_ObjSetVar2 above may have
* cause the result to change. [Patch #558324] (watson).
*/
if (!doinline) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_SetIntObj(resultPtr, (all ? all-1 : 1));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_RegsubObjCmd --
*
* This procedure is invoked to process the "regsub" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_RegsubObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
int start, end, subStart, subEnd, match;
Tcl_RegExp regExpr;
Tcl_RegExpInfo info;
Tcl_Obj *resultPtr, *subPtr, *objPtr;
Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend;
static CONST char *options[] = {
"-all", "-nocase", "-expanded",
"-line", "-linestop", "-lineanchor", "-start",
"--", NULL
};
enum options {
REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED,
REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START,
REGSUB_LAST
};
cflags = TCL_REG_ADVANCED;
all = 0;
offset = 0;
resultPtr = NULL;
for (idx = 1; idx < objc; idx++) {
char *name;
int index;
name = Tcl_GetString(objv[idx]);
if (name[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case REGSUB_ALL: {
all = 1;
break;
}
case REGSUB_NOCASE: {
cflags |= TCL_REG_NOCASE;
break;
}
case REGSUB_EXPANDED: {
cflags |= TCL_REG_EXPANDED;
break;
}
case REGSUB_LINE: {
cflags |= TCL_REG_NEWLINE;
break;
}
case REGSUB_LINESTOP: {
cflags |= TCL_REG_NLSTOP;
break;
}
case REGSUB_LINEANCHOR: {
cflags |= TCL_REG_NLANCH;
break;
}
case REGSUB_START: {
if (++idx >= objc) {
goto endOfForLoop;
}
if (Tcl_GetIntFromObj(interp, objv[idx], &offset) != TCL_OK) {
return TCL_ERROR;
}
if (offset < 0) {
offset = 0;
}
break;
}
case REGSUB_LAST: {
idx++;
goto endOfForLoop;
}
}
}
endOfForLoop:
if (objc-idx < 3 || objc-idx > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"?switches? exp string subSpec ?varName?");
return TCL_ERROR;
}
objc -= idx;
objv += idx;
if (all && (offset == 0)
&& (strpbrk(Tcl_GetString(objv[2]), "&\") == NULL)
&& (strpbrk(Tcl_GetString(objv[0]), "*+?{}()[].\|^$") == NULL)) {
/*
* This is a simple one pair string map situation. We make use of
* a slightly modified version of the one pair STR_MAP code.
*/
int slen, nocase;
int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar *, CONST Tcl_UniChar *,
unsigned long));
Tcl_UniChar *p, wsrclc;
numMatches = 0;
nocase = (cflags & TCL_REG_NOCASE);
strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen);
wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen);
wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen);
wend = wstring + wlen - (slen ? slen - 1 : 0);
result = TCL_OK;
if (slen == 0) {
/*
* regsub behavior for "" matches between each character.
* 'string map' skips the "" case.
*/
if (wstring < wend) {
resultPtr = Tcl_NewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
for (; wstring < wend; wstring++) {
Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
Tcl_AppendUnicodeToObj(resultPtr, wstring, 1);
numMatches++;
}
wlen = 0;
}
} else {
wsrclc = Tcl_UniCharToLower(*wsrc);
for (p = wfirstChar = wstring; wstring < wend; wstring++) {
if (((*wstring == *wsrc) ||
(nocase && (Tcl_UniCharToLower(*wstring) ==
wsrclc))) &&
((slen == 1) || (strCmpFn(wstring, wsrc,
(unsigned long) slen) == 0))) {
if (numMatches == 0) {
resultPtr = Tcl_NewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
}
if (p != wstring) {
Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p);
p = wstring + slen;
} else {
p += slen;
}
wstring = p - 1;
Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
numMatches++;
}
}
if (numMatches) {
wlen = wfirstChar + wlen - p;
wstring = p;
}
}
objPtr = NULL;
subPtr = NULL;
goto regsubDone;
}
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if (regExpr == NULL) {
return TCL_ERROR;
}
/*
* Make sure to avoid problems where the objects are shared. This
* can cause RegExpObj <> UnicodeObj shimmering that causes data
* corruption. [Bug #461322]
*/
if (objv[1] == objv[0]) {
objPtr = Tcl_DuplicateObj(objv[1]);
} else {
objPtr = objv[1];
}
wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen);
if (objv[2] == objv[0]) {
subPtr = Tcl_DuplicateObj(objv[2]);
} else {
subPtr = objv[2];
}
wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);
result = TCL_OK;
/*
* The following loop is to handle multiple matches within the
* same source string; each iteration handles one match and its
* corresponding substitution. If "-all" hasn't been specified
* then the loop body only gets executed once. We must use
* 'offset <= wlen' in particular for the case where the regexp
* pattern can match the empty string - this is useful when
* doing, say, 'regsub -- ^ $str ...' when $str might be empty.
*/
numMatches = 0;
for ( ; offset <= wlen; ) {
/*
* The flags argument is set if string is part of a larger string,
* so that "^" won't match.
*/
match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset,
10 /* matches */, ((offset > 0 &&
(wstring[offset-1] != (Tcl_UniChar)'n'))
? TCL_REG_NOTBOL : 0));
if (match < 0) {
result = TCL_ERROR;
goto done;
}
if (match == 0) {
break;
}
if (numMatches == 0) {
resultPtr = Tcl_NewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
if (offset > 0) {
/*
* Copy the initial portion of the string in if an offset
* was specified.
*/
Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
}
}
numMatches++;
/*
* Copy the portion of the source string before the match to the
* result variable.
*/
Tcl_RegExpGetInfo(regExpr, &info);
start = info.matches[0].start;
end = info.matches[0].end;
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start);
/*
* Append the subSpec argument to the variable, making appropriate
* substitutions. This code is a bit hairy because of the backslash
* conventions and because the code saves up ranges of characters in
* subSpec to reduce the number of calls to Tcl_SetVar.
*/
wsrc = wfirstChar = wsubspec;
wend = wsubspec + wsublen;
for (ch = *wsrc; wsrc != wend; wsrc++, ch = *wsrc) {
if (ch == '&') {
idx = 0;
} else if (ch == '\') {
ch = wsrc[1];
if ((ch >= '0') && (ch <= '9')) {
idx = ch - '0';
} else if ((ch == '\') || (ch == '&')) {
*wsrc = ch;
Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
wsrc - wfirstChar + 1);
*wsrc = '\';
wfirstChar = wsrc + 2;
wsrc++;
continue;
} else {
continue;
}
} else {
continue;
}
if (wfirstChar != wsrc) {
Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
wsrc - wfirstChar);
}
if (idx <= info.nsubs) {
subStart = info.matches[idx].start;
subEnd = info.matches[idx].end;
if ((subStart >= 0) && (subEnd >= 0)) {
Tcl_AppendUnicodeToObj(resultPtr,
wstring + offset + subStart, subEnd - subStart);
}
}
if (*wsrc == '\') {
wsrc++;
}
wfirstChar = wsrc + 1;
}
if (wfirstChar != wsrc) {
Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar);
}
if (end == 0) {
/*
* Always consume at least one character of the input string
* in order to prevent infinite loops.
*/
if (offset < wlen) {
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
}
offset++;
} else {
offset += end;
if (start == end) {
/*
* We matched an empty string, which means we must go
* forward one more step so we don't match again at the
* same spot.
*/
if (offset < wlen) {
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
}
offset++;
}
}
if (!all) {
break;
}
}
/*
* Copy the portion of the source string after the last match to the
* result variable.
*/
regsubDone:
if (numMatches == 0) {
/*
* On zero matches, just ignore the offset, since it shouldn't
* matter to us in this case, and the user may have skewed it.
*/
resultPtr = objv[1];
Tcl_IncrRefCount(resultPtr);
} else if (offset < wlen) {
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
}
if (objc == 4) {
if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) {
Tcl_AppendResult(interp, "couldn't set variable "",
Tcl_GetString(objv[3]), """, (char *) NULL);
result = TCL_ERROR;
} else {
/*
* Set the interpreter's object result to an integer object
* holding the number of matches.
*/
Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches);
}
} else {
/*
* No varname supplied, so just return the modified string.
*/
Tcl_SetObjResult(interp, resultPtr);
}
done:
if (objPtr && (objv[1] == objv[0])) { Tcl_DecrRefCount(objPtr); }
if (subPtr && (objv[2] == objv[0])) { Tcl_DecrRefCount(subPtr); }
if (resultPtr) { Tcl_DecrRefCount(resultPtr); }
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_RenameObjCmd --
*
* This procedure is invoked to process the "rename" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_RenameObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Arbitrary value passed to the command. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *oldName, *newName;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
return TCL_ERROR;
}
oldName = Tcl_GetString(objv[1]);
newName = Tcl_GetString(objv[2]);
return TclRenameCommand(interp, oldName, newName);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ReturnObjCmd --
*
* This object-based procedure is invoked to process the "return" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_ReturnObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
int optionLen, argLen, code, result;
if (iPtr->errorInfo != NULL) {
ckfree(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
if (iPtr->errorCode != NULL) {
ckfree(iPtr->errorCode);
iPtr->errorCode = NULL;
}
code = TCL_OK;
for (objv++, objc--; objc > 1; objv += 2, objc -= 2) {
char *option = Tcl_GetStringFromObj(objv[0], &optionLen);
char *arg = Tcl_GetStringFromObj(objv[1], &argLen);
if (strcmp(option, "-code") == 0) {
register int c = arg[0];
if ((c == 'o') && (strcmp(arg, "ok") == 0)) {
code = TCL_OK;
} else if ((c == 'e') && (strcmp(arg, "error") == 0)) {
code = TCL_ERROR;
} else if ((c == 'r') && (strcmp(arg, "return") == 0)) {
code = TCL_RETURN;
} else if ((c == 'b') && (strcmp(arg, "break") == 0)) {
code = TCL_BREAK;
} else if ((c == 'c') && (strcmp(arg, "continue") == 0)) {
code = TCL_CONTINUE;
} else {
result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1],
&code);
if (result != TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad completion code "",
Tcl_GetString(objv[1]),
"": must be ok, error, return, break, ",
"continue, or an integer", (char *) NULL);
return result;
}
}
} else if (strcmp(option, "-errorinfo") == 0) {
iPtr->errorInfo =
(char *) ckalloc((unsigned) (strlen(arg) + 1));
strcpy(iPtr->errorInfo, arg);
} else if (strcmp(option, "-errorcode") == 0) {
iPtr->errorCode =
(char *) ckalloc((unsigned) (strlen(arg) + 1));
strcpy(iPtr->errorCode, arg);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option "", option,
"": must be -code, -errorcode, or -errorinfo",
(char *) NULL);
return TCL_ERROR;
}
}
if (objc == 1) {
/*
* Set the interpreter's object result. An inline version of
* Tcl_SetObjResult.
*/
Tcl_SetObjResult(interp, objv[0]);
}
iPtr->returnCode = code;
return TCL_RETURN;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SourceObjCmd --
*
* This procedure is invoked to process the "source" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_SourceObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "fileName");
return TCL_ERROR;
}
return Tcl_FSEvalFile(interp, objv[1]);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SplitObjCmd --
*
* This procedure is invoked to process the "split" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_SplitObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_UniChar ch;
int len;
char *splitChars, *string, *end;
int splitCharLen, stringLen;
Tcl_Obj *listPtr, *objPtr;
if (objc == 2) {
splitChars = " ntr";
splitCharLen = 4;
} else if (objc == 3) {
splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
return TCL_ERROR;
}
string = Tcl_GetStringFromObj(objv[1], &stringLen);
end = string + stringLen;
listPtr = Tcl_GetObjResult(interp);
if (stringLen == 0) {
/*
* Do nothing.
*/
} else if (splitCharLen == 0) {
Tcl_HashTable charReuseTable;
Tcl_HashEntry *hPtr;
int isNew;
/*
* Handle the special case of splitting on every character.
*
* Uses a hash table to ensure that each kind of character has
* only one Tcl_Obj instance (multiply-referenced) in the
* final list. This is a *major* win when splitting on a long
* string (especially in the megabyte range!) - DKF
*/
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; string < end; string += len) {
len = TclUtfToUniChar(string, &ch);
/* Assume Tcl_UniChar is an integral type... */
hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew);
if (isNew) {
objPtr = Tcl_NewStringObj(string, len);
/* Don't need to fiddle with refcount... */
Tcl_SetHashValue(hPtr, (ClientData) objPtr);
} else {
objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr);
}
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
Tcl_DeleteHashTable(&charReuseTable);
} else if (splitCharLen == 1) {
char *p;
/*
* Handle the special case of splitting on a single character.
* This is only true for the one-char ASCII case, as one unicode
* char is > 1 byte in length.
*/
while (*string && (p = strchr(string, (int) *splitChars)) != NULL) {
objPtr = Tcl_NewStringObj(string, p - string);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
string = p + 1;
}
objPtr = Tcl_NewStringObj(string, end - string);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
} else {
char *element, *p, *splitEnd;
int splitLen;
Tcl_UniChar splitChar;
/*
* Normal case: split on any of a given set of characters.
* Discard instances of the split characters.
*/
splitEnd = splitChars + splitCharLen;
for (element = string; string < end; string += len) {
len = TclUtfToUniChar(string, &ch);
for (p = splitChars; p < splitEnd; p += splitLen) {
splitLen = TclUtfToUniChar(p, &splitChar);
if (ch == splitChar) {
objPtr = Tcl_NewStringObj(element, string - element);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
element = string + len;
break;
}
}
}
objPtr = Tcl_NewStringObj(element, string - element);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_StringObjCmd --
*
* This procedure is invoked to process the "string" Tcl command.
* See the user documentation for details on what it does. Note
* that this command only functions correctly on properly formed
* Tcl UTF strings.
*
* Note that the primary methods here (equal, compare, match, ...)
* have bytecode equivalents. You will find the code for those in
* tclExecute.c. The code here will only be used in the non-bc
* case (like in an 'eval').
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_StringObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int index, left, right;
Tcl_Obj *resultPtr;
char *string1, *string2;
int length1, length2;
static CONST char *options[] = {
"bytelength", "compare", "equal", "first",
"index", "is", "last", "length",
"map", "match", "range", "repeat",
"replace", "tolower", "toupper", "totitle",
"trim", "trimleft", "trimright",
"wordend", "wordstart", (char *) NULL
};
enum options {
STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST,
STR_INDEX, STR_IS, STR_LAST, STR_LENGTH,
STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT,
STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE,
STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
STR_WORDEND, STR_WORDSTART
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_GetObjResult(interp);
switch ((enum options) index) {
case STR_EQUAL:
case STR_COMPARE: {
/*
* Remember to keep code here in some sync with the
* byte-compiled versions in tclExecute.c (INST_STR_EQ,
* INST_STR_NEQ and INST_STR_CMP as well as the expr string
* comparison in INST_EQ/INST_NEQ/INST_LT/...).
*/
int i, match, length, nocase = 0, reqlength = -1;
int (*strCmpFn)();
if (objc < 4 || objc > 7) {
str_cmp_args:
Tcl_WrongNumArgs(interp, 2, objv,
"?-nocase? ?-length int? string1 string2");
return TCL_ERROR;
}
for (i = 2; i < objc-2; i++) {
string2 = Tcl_GetStringFromObj(objv[i], &length2);
if ((length2 > 1)
&& strncmp(string2, "-nocase", (size_t)length2) == 0) {
nocase = 1;
} else if ((length2 > 1)
&& strncmp(string2, "-length", (size_t)length2) == 0) {
if (i+1 >= objc-2) {
goto str_cmp_args;
}
if (Tcl_GetIntFromObj(interp, objv[++i],
&reqlength) != TCL_OK) {
return TCL_ERROR;
}
} else {
Tcl_AppendStringsToObj(resultPtr, "bad option "",
string2, "": must be -nocase or -length",
(char *) NULL);
return TCL_ERROR;
}
}
/*
* From now on, we only access the two objects at the end
* of the argument array.
*/
objv += objc-2;
if ((reqlength == 0) || (objv[0] == objv[1])) {
/*
* Alway match at 0 chars of if it is the same obj.
*/
Tcl_SetBooleanObj(resultPtr,
((enum options) index == STR_EQUAL));
break;
} else if (!nocase && objv[0]->typePtr == &tclByteArrayType &&
objv[1]->typePtr == &tclByteArrayType) {
/*
* Use binary versions of comparisons since that won't
* cause undue type conversions and it is much faster.
* Only do this if we're case-sensitive (which is all
* that really makes sense with byte arrays anyway, and
* we have no memcasecmp() for some reason... :^)
*/
string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1);
string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2);
strCmpFn = memcmp;
} else if ((objv[0]->typePtr == &tclStringType)
&& (objv[1]->typePtr == &tclStringType)) {
/*
* Do a unicode-specific comparison if both of the args
* are of String type. In benchmark testing this proved
* the most efficient check between the unicode and
* string comparison operations.
*/
string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1);
string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2);
strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
} else {
/*
* As a catch-all we will work with UTF-8. We cannot use
* memcmp() as that is unsafe with any string containing
* NULL (xC0x80 in Tcl's utf rep). We can use the more
* efficient TclpUtfNcmp2 if we are case-sensitive and no
* specific length was requested.
*/
string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1);
string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2);
if ((reqlength < 0) && !nocase) {
strCmpFn = TclpUtfNcmp2;
} else {
length1 = Tcl_NumUtfChars(string1, length1);
length2 = Tcl_NumUtfChars(string2, length2);
strCmpFn = nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp;
}
}
if (((enum options) index == STR_EQUAL)
&& (reqlength < 0) && (length1 != length2)) {
match = 1; /* this will be reversed below */
} else {
length = (length1 < length2) ? length1 : length2;
if (reqlength > 0 && reqlength < length) {
length = reqlength;
} else if (reqlength < 0) {
/*
* The requested length is negative, so we ignore it by
* setting it to length + 1 so we correct the match var.
*/
reqlength = length + 1;
}
match = strCmpFn(string1, string2, (unsigned) length);
if ((match == 0) && (reqlength > length)) {
match = length1 - length2;
}
}
if ((enum options) index == STR_EQUAL) {
Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1);
} else {
Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 :
(match < 0) ? -1 : 0));
}
break;
}
case STR_FIRST: {
Tcl_UniChar *ustring1, *ustring2;
int match, start;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv,
"subString string ?startIndex?");
return TCL_ERROR;
}
/*
* We are searching string2 for the sequence string1.
*/
match = -1;
start = 0;
length2 = -1;
ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
if (objc == 5) {
/*
* If a startIndex is specified, we will need to fast
* forward to that point in the string before we think
* about a match
*/
if (TclGetIntForIndex(interp, objv[4], length2 - 1,
&start) != TCL_OK) {
return TCL_ERROR;
}
if (start >= length2) {
goto str_first_done;
} else if (start > 0) {
ustring2 += start;
length2 -= start;
} else if (start < 0) {
/*
* Invalid start index mapped to string start;
* Bug #423581
*/
start = 0;
}
}
if (length1 > 0) {
register Tcl_UniChar *p, *end;
end = ustring2 + length2 - length1 + 1;
for (p = ustring2; p < end; p++) {
/*
* Scan forward to find the first character.
*/
if ((*p == *ustring1) &&
(TclUniCharNcmp(ustring1, p,
(unsigned long) length1) == 0)) {
match = p - ustring2;
break;
}
}
}
/*
* Compute the character index of the matching string by
* counting the number of characters before the match.
*/
if ((match != -1) && (objc == 5)) {
match += start;
}
str_first_done:
Tcl_SetIntObj(resultPtr, match);
break;
}
case STR_INDEX: {
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
return TCL_ERROR;
}
/*
* If we have a ByteArray object, avoid indexing in the
* Utf string since the byte array contains one byte per
* character. Otherwise, use the Unicode string rep to
* get the index'th char.
*/
if (objv[2]->typePtr == &tclByteArrayType) {
string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1);
if (TclGetIntForIndex(interp, objv[3], length1 - 1,
&index) != TCL_OK) {
return TCL_ERROR;
}
if ((index >= 0) && (index < length1)) {
Tcl_SetByteArrayObj(resultPtr,
(unsigned char *)(&string1[index]), 1);
}
} else {
/*
* Get Unicode char length to calulate what 'end' means.
*/
length1 = Tcl_GetCharLength(objv[2]);
if (TclGetIntForIndex(interp, objv[3], length1 - 1,
&index) != TCL_OK) {
return TCL_ERROR;
}
if ((index >= 0) && (index < length1)) {
char buf[TCL_UTF_MAX];
Tcl_UniChar ch;
ch = Tcl_GetUniChar(objv[2], index);
length1 = Tcl_UniCharToUtf(ch, buf);
Tcl_SetStringObj(resultPtr, buf, length1);
}
}
break;
}
case STR_IS: {
char *end;
Tcl_UniChar ch;
/*
* The UniChar comparison function
*/
int (*chcomp)_ANSI_ARGS_((int)) = NULL;
int i, failat = 0, result = 1, strict = 0;
Tcl_Obj *objPtr, *failVarObj = NULL;
static CONST char *isOptions[] = {
"alnum", "alpha", "ascii", "control",
"boolean", "digit", "double", "false",
"graph", "integer", "lower", "print",
"punct", "space", "true", "upper",
"wordchar", "xdigit", (char *) NULL
};
enum isOptions {
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE,
STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT,
STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER,
STR_IS_WORD, STR_IS_XDIGIT
};
if (objc < 4 || objc > 7) {
Tcl_WrongNumArgs(interp, 2, objv,
"class ?-strict? ?-failindex var? str");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (objc != 4) {
for (i = 3; i < objc-1; i++) {
string2 = Tcl_GetStringFromObj(objv[i], &length2);
if ((length2 > 1) &&
strncmp(string2, "-strict", (size_t) length2) == 0) {
strict = 1;
} else if ((length2 > 1) &&
strncmp(string2, "-failindex",
(size_t) length2) == 0) {
if (i+1 >= objc-1) {
Tcl_WrongNumArgs(interp, 3, objv,
"?-strict? ?-failindex var? str");
return TCL_ERROR;
}
failVarObj = objv[++i];
} else {
Tcl_AppendStringsToObj(resultPtr, "bad option "",
string2, "": must be -strict or -failindex",
(char *) NULL);
return TCL_ERROR;
}
}
}
/*
* We get the objPtr so that we can short-cut for some classes
* by checking the object type (int and double), but we need
* the string otherwise, because we don't want any conversion
* of type occuring (as, for example, Tcl_Get*FromObj would do
*/
objPtr = objv[objc-1];
string1 = Tcl_GetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
}
end = string1 + length1;
/*
* When entering here, result == 1 and failat == 0
*/
switch ((enum isOptions) index) {
case STR_IS_ALNUM:
chcomp = Tcl_UniCharIsAlnum;
break;
case STR_IS_ALPHA:
chcomp = Tcl_UniCharIsAlpha;
break;
case STR_IS_ASCII:
for (; string1 < end; string1++, failat++) {
/*
* This is a valid check in unicode, because all
* bytes < 0xC0 are single byte chars (but isascii
* limits that def'n to 0x80).
*/
if (*((unsigned char *)string1) >= 0x80) {
result = 0;
break;
}
}
break;
case STR_IS_BOOL:
case STR_IS_TRUE:
case STR_IS_FALSE:
/* Optimizers, beware Bug 1187123 ! */
if ((Tcl_GetBoolean(NULL, string1, &i)
== TCL_ERROR) ||
(((enum isOptions) index == STR_IS_TRUE) &&
i == 0) ||
(((enum isOptions) index == STR_IS_FALSE) &&
i != 0)) {
result = 0;
}
break;
case STR_IS_CONTROL:
chcomp = Tcl_UniCharIsControl;
break;
case STR_IS_DIGIT:
chcomp = Tcl_UniCharIsDigit;
break;
case STR_IS_DOUBLE: {
char *stop;
if ((objPtr->typePtr == &tclDoubleType) ||
(objPtr->typePtr == &tclIntType)) {
break;
}
/*
* This is adapted from Tcl_GetDouble
*
* The danger in this function is that
* "12345678901234567890" is an acceptable 'double',
* but will later be interp'd as an int by something
* like [expr]. Therefore, we check to see if it looks
* like an int, and if so we do a range check on it.
* If strtoul gets to the end, we know we either
* received an acceptable int, or over/underflow
*/
if (TclLooksLikeInt(string1, length1)) {
errno = 0;
#ifdef TCL_WIDE_INT_IS_LONG
strtoul(string1, &stop, 0); /* INTL: Tcl source. */
#else
strtoull(string1, &stop, 0); /* INTL: Tcl source. */
#endif
if (stop == end) {
if (errno == ERANGE) {
result = 0;
failat = -1;
}
break;
}
}
errno = 0;
strtod(string1, &stop); /* INTL: Tcl source. */
if (errno == ERANGE) {
/*
* if (errno == ERANGE), then it was an over/underflow
* problem, but in this method, we only want to know
* yes or no, so bad flow returns 0 (false) and sets
* the failVarObj to the string length.
*/
result = 0;
failat = -1;
} else if (stop == string1) {
/*
* In this case, nothing like a number was found
*/
result = 0;
failat = 0;
} else {
/*
* Assume we sucked up one char per byte
* and then we go onto SPACE, since we are
* allowed trailing whitespace
*/
failat = stop - string1;
string1 = stop;
chcomp = Tcl_UniCharIsSpace;
}
break;
}
case STR_IS_GRAPH:
chcomp = Tcl_UniCharIsGraph;
break;
case STR_IS_INT: {
char *stop;
long int l = 0;
if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) {
break;
}
/*
* Like STR_IS_DOUBLE, but we use strtoul.
* Since Tcl_GetIntFromObj already failed,
* we set result to 0.
*/
result = 0;
errno = 0;
l = strtol(string1, &stop, 0); /* INTL: Tcl source. */
if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) {
/*
* if (errno == ERANGE), then it was an over/underflow
* problem, but in this method, we only want to know
* yes or no, so bad flow returns 0 (false) and sets
* the failVarObj to the string length.
*/
failat = -1;
} else if (stop == string1) {
/*
* In this case, nothing like a number was found
*/
failat = 0;
} else {
/*
* Assume we sucked up one char per byte
* and then we go onto SPACE, since we are
* allowed trailing whitespace
*/
failat = stop - string1;
string1 = stop;
chcomp = Tcl_UniCharIsSpace;
}
break;
}
case STR_IS_LOWER:
chcomp = Tcl_UniCharIsLower;
break;
case STR_IS_PRINT:
chcomp = Tcl_UniCharIsPrint;
break;
case STR_IS_PUNCT:
chcomp = Tcl_UniCharIsPunct;
break;
case STR_IS_SPACE:
chcomp = Tcl_UniCharIsSpace;
break;
case STR_IS_UPPER:
chcomp = Tcl_UniCharIsUpper;
break;
case STR_IS_WORD:
chcomp = Tcl_UniCharIsWordChar;
break;
case STR_IS_XDIGIT: {
for (; string1 < end; string1++, failat++) {
/* INTL: We assume unicode is bad for this class */
if ((*((unsigned char *)string1) >= 0xC0) ||
!isxdigit(*(unsigned char *)string1)) {
result = 0;
break;
}
}
break;
}
}
if (chcomp != NULL) {
for (; string1 < end; string1 += length2, failat++) {
length2 = TclUtfToUniChar(string1, &ch);
if (!chcomp(ch)) {
result = 0;
break;
}
}
}
str_is_done:
/*
* Only set the failVarObj when we will return 0
* and we have indicated a valid fail index (>= 0)
*/
if ((result == 0) && (failVarObj != NULL)) {
Tcl_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;
}
case STR_LAST: {
Tcl_UniChar *ustring1, *ustring2, *p;
int match, start;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv,
"subString string ?startIndex?");
return TCL_ERROR;
}
/*
* We are searching string2 for the sequence string1.
*/
match = -1;
start = 0;
length2 = -1;
ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
if (objc == 5) {
/*
* If a startIndex is specified, we will need to restrict
* the string range to that char index in the string
*/
if (TclGetIntForIndex(interp, objv[4], length2 - 1,
&start) != TCL_OK) {
return TCL_ERROR;
}
if (start < 0) {
goto str_last_done;
} else if (start < length2) {
p = ustring2 + start + 1 - length1;
} else {
p = ustring2 + length2 - length1;
}
} else {
p = ustring2 + length2 - length1;
}
if (length1 > 0) {
for (; p >= ustring2; p--) {
/*
* Scan backwards to find the first character.
*/
if ((*p == *ustring1) &&
(memcmp((char *) ustring1, (char *) p, (size_t)
(length1 * sizeof(Tcl_UniChar))) == 0)) {
match = p - ustring2;
break;
}
}
}
str_last_done:
Tcl_SetIntObj(resultPtr, match);
break;
}
case STR_BYTELENGTH:
case STR_LENGTH: {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "string");
return TCL_ERROR;
}
if ((enum options) index == STR_BYTELENGTH) {
(void) Tcl_GetStringFromObj(objv[2], &length1);
} else {
/*
* If we have a ByteArray object, avoid recomputing the
* string since the byte array contains one byte per
* character. Otherwise, use the Unicode string rep to
* calculate the length.
*/
if (objv[2]->typePtr == &tclByteArrayType) {
(void) Tcl_GetByteArrayFromObj(objv[2], &length1);
} else {
length1 = Tcl_GetCharLength(objv[2]);
}
}
Tcl_SetIntObj(resultPtr, length1);
break;
}
case STR_MAP: {
int mapElemc, nocase = 0, copySource = 0;
Tcl_Obj **mapElemv, *sourceObj;
Tcl_UniChar *ustring1, *ustring2, *p, *end;
int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*,
CONST Tcl_UniChar*, unsigned long));
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string");
return TCL_ERROR;
}
if (objc == 5) {
string2 = Tcl_GetStringFromObj(objv[2], &length2);
if ((length2 > 1) &&
strncmp(string2, "-nocase", (size_t) length2) == 0) {
nocase = 1;
} else {
Tcl_AppendStringsToObj(resultPtr, "bad option "",
string2, "": must be -nocase",
(char *) NULL);
return TCL_ERROR;
}
}
if (Tcl_ListObjGetElements(interp, objv[objc-2], &mapElemc,
&mapElemv) != TCL_OK) {
return TCL_ERROR;
}
if (mapElemc == 0) {
/*
* empty charMap, just return whatever string was given
*/
Tcl_SetObjResult(interp, objv[objc-1]);
return TCL_OK;
} else if (mapElemc & 1) {
/*
* The charMap must be an even number of key/value items
*/
Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1);
return TCL_ERROR;
}
/*
* Take a copy of the source string object if it is the
* same as the map string to cut out nasty sharing
* crashes. [Bug 1018562]
*/
if (objv[objc-2] == objv[objc-1]) {
sourceObj = Tcl_DuplicateObj(objv[objc-1]);
copySource = 1;
} else {
sourceObj = objv[objc-1];
}
ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1);
if (length1 == 0) {
/*
* Empty input string, just stop now
*/
if (copySource) {
Tcl_DecrRefCount(sourceObj);
}
break;
}
end = ustring1 + length1;
strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
/*
* Force result to be Unicode
*/
Tcl_SetUnicodeObj(resultPtr, ustring1, 0);
if (mapElemc == 2) {
/*
* Special case for one map pair which avoids the extra
* for loop and extra calls to get Unicode data. The
* algorithm is otherwise identical to the multi-pair case.
* This will be >30% faster on larger strings.
*/
int mapLen;
Tcl_UniChar *mapString, u2lc;
ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
p = ustring1;
if ((length2 > length1) || (length2 == 0)) {
/* match string is either longer than input or empty */
ustring1 = end;
} else {
mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen);
u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0);
for (; ustring1 < end; ustring1++) {
if (((*ustring1 == *ustring2) ||
(nocase && (Tcl_UniCharToLower(*ustring1) ==
u2lc))) &&
((length2 == 1) || strCmpFn(ustring1, ustring2,
(unsigned long) length2) == 0)) {
if (p != ustring1) {
Tcl_AppendUnicodeToObj(resultPtr, p,
ustring1 - p);
p = ustring1 + length2;
} else {
p += length2;
}
ustring1 = p - 1;
Tcl_AppendUnicodeToObj(resultPtr, mapString,
mapLen);
}
}
}
} else {
Tcl_UniChar **mapStrings, *u2lc = NULL;
int *mapLens;
/*
* Precompute pointers to the unicode string and length.
* This saves us repeated function calls later,
* significantly speeding up the algorithm. We only need
* the lowercase first char in the nocase case.
*/
mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2)
* sizeof(Tcl_UniChar *));
mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int));
if (nocase) {
u2lc = (Tcl_UniChar *)
ckalloc((mapElemc) * sizeof(Tcl_UniChar));
}
for (index = 0; index < mapElemc; index++) {
mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
&(mapLens[index]));
if (nocase && ((index % 2) == 0)) {
u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]);
}
}
for (p = ustring1; ustring1 < end; ustring1++) {
for (index = 0; index < mapElemc; index += 2) {
/*
* Get the key string to match on.
*/
ustring2 = mapStrings[index];
length2 = mapLens[index];
if ((length2 > 0) && ((*ustring1 == *ustring2) ||
(nocase && (Tcl_UniCharToLower(*ustring1) ==
u2lc[index/2]))) &&
/* restrict max compare length */
((end - ustring1) >= length2) &&
((length2 == 1) || strCmpFn(ustring2, ustring1,
(unsigned long) length2) == 0)) {
if (p != ustring1) {
/*
* Put the skipped chars onto the result first
*/
Tcl_AppendUnicodeToObj(resultPtr, p,
ustring1 - p);
p = ustring1 + length2;
} else {
p += length2;
}
/*
* Adjust len to be full length of matched string
*/
ustring1 = p - 1;
/*
* Append the map value to the unicode string
*/
Tcl_AppendUnicodeToObj(resultPtr,
mapStrings[index+1], mapLens[index+1]);
break;
}
}
}
ckfree((char *) mapStrings);
ckfree((char *) mapLens);
if (nocase) {
ckfree((char *) u2lc);
}
}
if (p != ustring1) {
/*
* Put the rest of the unmapped chars onto result
*/
Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
}
if (copySource) {
Tcl_DecrRefCount(sourceObj);
}
break;
}
case STR_MATCH: {
Tcl_UniChar *ustring1, *ustring2;
int nocase = 0;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string");
return TCL_ERROR;
}
if (objc == 5) {
string2 = Tcl_GetStringFromObj(objv[2], &length2);
if ((length2 > 1) &&
strncmp(string2, "-nocase", (size_t) length2) == 0) {
nocase = 1;
} else {
Tcl_AppendStringsToObj(resultPtr, "bad option "",
string2, "": must be -nocase",
(char *) NULL);
return TCL_ERROR;
}
}
ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1);
ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2);
Tcl_SetBooleanObj(resultPtr, TclUniCharMatch(ustring1, length1,
ustring2, length2, nocase));
break;
}
case STR_RANGE: {
int first, last;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "string first last");
return TCL_ERROR;
}
/*
* If we have a ByteArray object, avoid indexing in the
* Utf string since the byte array contains one byte per
* character. Otherwise, use the Unicode string rep to
* get the range.
*/
if (objv[2]->typePtr == &tclByteArrayType) {
string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1);
length1--;
} else {
/*
* Get the length in actual characters.
*/
string1 = NULL;
length1 = Tcl_GetCharLength(objv[2]) - 1;
}
if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
|| (TclGetIntForIndex(interp, objv[4], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if (first < 0) {
first = 0;
}
if (last >= length1) {
last = length1;
}
if (last >= first) {
if (string1 != NULL) {
int numBytes = last - first + 1;
resultPtr = Tcl_NewByteArrayObj(
(unsigned char *) &string1[first], numBytes);
Tcl_SetObjResult(interp, resultPtr);
} else {
Tcl_SetObjResult(interp,
Tcl_GetRange(objv[2], first, last));
}
}
break;
}
case STR_REPEAT: {
int count;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string count");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) {
return TCL_ERROR;
}
if (count == 1) {
Tcl_SetObjResult(interp, objv[2]);
} else if (count > 1) {
string1 = Tcl_GetStringFromObj(objv[2], &length1);
if (length1 > 0) {
/*
* Only build up a string that has data. Instead of
* building it up with repeated appends, we just allocate
* the necessary space once and copy the string value in.
* Check for overflow with back-division. [Bug #714106]
*/
length2 = length1 * count;
if ((length2 / count) != length1) {
char buf[TCL_INTEGER_SPACE+1];
sprintf(buf, "%d", INT_MAX);
Tcl_AppendStringsToObj(resultPtr,
"string size overflow, must be less than ",
buf, (char *) NULL);
return TCL_ERROR;
}
/*
* Include space for the NULL
*/
string2 = (char *) ckalloc((size_t) length2+1);
for (index = 0; index < count; index++) {
memcpy(string2 + (length1 * index), string1,
(size_t) length1);
}
string2[length2] = '';
/*
* We have to directly assign this instead of using
* Tcl_SetStringObj (and indirectly TclInitStringRep)
* because that makes another copy of the data.
*/
resultPtr = Tcl_NewObj();
resultPtr->bytes = string2;
resultPtr->length = length2;
Tcl_SetObjResult(interp, resultPtr);
}
}
break;
}
case STR_REPLACE: {
Tcl_UniChar *ustring1;
int first, last;
if (objc < 5 || objc > 6) {
Tcl_WrongNumArgs(interp, 2, objv,
"string first last ?string?");
return TCL_ERROR;
}
ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
length1--;
if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
|| (TclGetIntForIndex(interp, objv[4], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if ((last < first) || (last < 0) || (first > length1)) {
Tcl_SetObjResult(interp, objv[2]);
} else {
if (first < 0) {
first = 0;
}
Tcl_SetUnicodeObj(resultPtr, ustring1, first);
if (objc == 6) {
Tcl_AppendObjToObj(resultPtr, objv[5]);
}
if (last < length1) {
Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1,
length1 - last);
}
}
break;
}
case STR_TOLOWER:
case STR_TOUPPER:
case STR_TOTITLE:
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[2], &length1);
if (objc == 3) {
/*
* Since the result object is not a shared object, it is
* safe to copy the string into the result and do the
* conversion in place. The conversion may change the length
* of the string, so reset the length after conversion.
*/
Tcl_SetStringObj(resultPtr, string1, length1);
if ((enum options) index == STR_TOLOWER) {
length1 = Tcl_UtfToLower(Tcl_GetString(resultPtr));
} else if ((enum options) index == STR_TOUPPER) {
length1 = Tcl_UtfToUpper(Tcl_GetString(resultPtr));
} else {
length1 = Tcl_UtfToTitle(Tcl_GetString(resultPtr));
}
Tcl_SetObjLength(resultPtr, length1);
} else {
int first, last;
CONST char *start, *end;
length1 = Tcl_NumUtfChars(string1, length1) - 1;
if (TclGetIntForIndex(interp, objv[3], length1,
&first) != TCL_OK) {
return TCL_ERROR;
}
if (first < 0) {
first = 0;
}
last = first;
if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if (last >= length1) {
last = length1;
}
if (last < first) {
Tcl_SetObjResult(interp, objv[2]);
break;
}
start = Tcl_UtfAtIndex(string1, first);
end = Tcl_UtfAtIndex(start, last - first + 1);
length2 = end-start;
string2 = ckalloc((size_t) length2+1);
memcpy(string2, start, (size_t) length2);
string2[length2] = '';
if ((enum options) index == STR_TOLOWER) {
length2 = Tcl_UtfToLower(string2);
} else if ((enum options) index == STR_TOUPPER) {
length2 = Tcl_UtfToUpper(string2);
} else {
length2 = Tcl_UtfToTitle(string2);
}
Tcl_SetStringObj(resultPtr, string1, start - string1);
Tcl_AppendToObj(resultPtr, string2, length2);
Tcl_AppendToObj(resultPtr, end, -1);
ckfree(string2);
}
break;
case STR_TRIM: {
Tcl_UniChar ch, trim;
register CONST char *p, *end;
char *check, *checkEnd;
int offset;
left = 1;
right = 1;
dotrim:
if (objc == 4) {
string2 = Tcl_GetStringFromObj(objv[3], &length2);
} else if (objc == 3) {
string2 = " tnr";
length2 = strlen(string2);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[2], &length1);
checkEnd = string2 + length2;
if (left) {
end = string1 + length1;
/*
* The outer loop iterates over the string. The inner
* loop iterates over the trim characters. The loops
* terminate as soon as a non-trim character is discovered
* and string1 is left pointing at the first non-trim
* character.
*/
for (p = string1; p < end; p += offset) {
offset = TclUtfToUniChar(p, &ch);
for (check = string2; ; ) {
if (check >= checkEnd) {
p = end;
break;
}
check += TclUtfToUniChar(check, &trim);
if (ch == trim) {
length1 -= offset;
string1 += offset;
break;
}
}
}
}
if (right) {
end = string1;
/*
* The outer loop iterates over the string. The inner
* loop iterates over the trim characters. The loops
* terminate as soon as a non-trim character is discovered
* and length1 marks the last non-trim character.
*/
for (p = string1 + length1; p > end; ) {
p = Tcl_UtfPrev(p, string1);
offset = TclUtfToUniChar(p, &ch);
for (check = string2; ; ) {
if (check >= checkEnd) {
p = end;
break;
}
check += TclUtfToUniChar(check, &trim);
if (ch == trim) {
length1 -= offset;
break;
}
}
}
}
Tcl_SetStringObj(resultPtr, string1, length1);
break;
}
case STR_TRIMLEFT: {
left = 1;
right = 0;
goto dotrim;
}
case STR_TRIMRIGHT: {
left = 0;
right = 1;
goto dotrim;
}
case STR_WORDEND: {
int cur;
Tcl_UniChar ch;
CONST char *p, *end;
int numChars;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string index");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[2], &length1);
numChars = Tcl_NumUtfChars(string1, length1);
if (TclGetIntForIndex(interp, objv[3], numChars-1,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (index < 0) {
index = 0;
}
if (index < numChars) {
p = Tcl_UtfAtIndex(string1, index);
end = string1+length1;
for (cur = index; p < end; cur++) {
p += TclUtfToUniChar(p, &ch);
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
}
if (cur == index) {
cur++;
}
} else {
cur = numChars;
}
Tcl_SetIntObj(resultPtr, cur);
break;
}
case STR_WORDSTART: {
int cur;
Tcl_UniChar ch;
CONST char *p;
int numChars;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string index");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[2], &length1);
numChars = Tcl_NumUtfChars(string1, length1);
if (TclGetIntForIndex(interp, objv[3], numChars-1,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (index >= numChars) {
index = numChars - 1;
}
cur = 0;
if (index > 0) {
p = Tcl_UtfAtIndex(string1, index);
for (cur = index; cur >= 0; cur--) {
TclUtfToUniChar(p, &ch);
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
p = Tcl_UtfPrev(p, string1);
}
if (cur != index) {
cur += 1;
}
}
Tcl_SetIntObj(resultPtr, cur);
break;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SubstObjCmd --
*
* This procedure is invoked to process the "subst" Tcl command.
* See the user documentation for details on what it does. This
* command relies on Tcl_SubstObj() for its implementation.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_SubstObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *substOptions[] = {
"-nobackslashes", "-nocommands", "-novariables", (char *) NULL
};
enum substOptions {
SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
};
Tcl_Obj *resultPtr;
int optionIndex, flags, i;
/*
* Parse command-line options.
*/
flags = TCL_SUBST_ALL;
for (i = 1; i < (objc-1); i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], substOptions,
"switch", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch (optionIndex) {
case SUBST_NOBACKSLASHES: {
flags &= ~TCL_SUBST_BACKSLASHES;
break;
}