/*
* tclCmdMZ.c --
*
* This file contains the top-level command routines for most of
* the Tcl built-in commands whose names begin with the letters
* M to Z. It contains only commands in the generic core (i.e.
* those that don't depend much upon UNIX facilities).
*
* Copyright (c) 1987-1993 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 Scriptics Corporation.
* Copyright (c) 2002 ActiveState Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclCmdMZ.c,v 1.93 2003/07/04 10:30:27 dkf Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"
/*
*----------------------------------------------------------------------
*
* Tcl_PwdObjCmd --
*
* This procedure is invoked to process the "pwd" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_PwdObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *retVal;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
retVal = Tcl_FSGetCwd(interp);
if (retVal == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, retVal);
Tcl_DecrRefCount(retVal);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_RegexpObjCmd --
*
* This procedure is invoked to process the "regexp" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_RegexpObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int i, indices, match, about, offset, all, doinline, numMatchesSaved;
int cflags, eflags, stringLength;
Tcl_RegExp regExpr;
Tcl_Obj *objPtr, *resultPtr;
Tcl_RegExpInfo info;
static CONST char *options[] = {
"-all", "-about", "-indices", "-inline",
"-expanded", "-line", "-linestop", "-lineanchor",
"-nocase", "-start", "--", (char *) NULL
};
enum options {
REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE,
REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR,
REGEXP_NOCASE, REGEXP_START, REGEXP_LAST
};
indices = 0;
about = 0;
cflags = TCL_REG_ADVANCED;
eflags = 0;
offset = 0;
all = 0;
doinline = 0;
for (i = 1; i < objc; i++) {
char *name;
int index;
name = Tcl_GetString(objv[i]);
if (name[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case REGEXP_ALL: {
all = 1;
break;
}
case REGEXP_INDICES: {
indices = 1;
break;
}
case REGEXP_INLINE: {
doinline = 1;
break;
}
case REGEXP_NOCASE: {
cflags |= TCL_REG_NOCASE;
break;
}
case REGEXP_ABOUT: {
about = 1;
break;
}
case REGEXP_EXPANDED: {
cflags |= TCL_REG_EXPANDED;
break;
}
case REGEXP_LINE: {
cflags |= TCL_REG_NEWLINE;
break;
}
case REGEXP_LINESTOP: {
cflags |= TCL_REG_NLSTOP;
break;
}
case REGEXP_LINEANCHOR: {
cflags |= TCL_REG_NLANCH;
break;
}
case REGEXP_START: {
if (++i >= objc) {
goto endOfForLoop;
}
if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) {
return TCL_ERROR;
}
if (offset < 0) {
offset = 0;
}
break;
}
case REGEXP_LAST: {
i++;
goto endOfForLoop;
}
}
}
endOfForLoop:
if ((objc - i) < (2 - about)) {
Tcl_WrongNumArgs(interp, 1, objv,
"?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
return TCL_ERROR;
}
objc -= i;
objv += i;
if (doinline && ((objc - 2) != 0)) {
/*
* User requested -inline, but specified match variables - a no-no.
*/
Tcl_AppendResult(interp, "regexp match variables not allowed",
" when using -inline", (char *) NULL);
return TCL_ERROR;
}
/*
* Handle the odd about case separately.
*/
if (about) {
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
* Get the length of the string that we are matching against so
* we can do the termination test for -all matches. Do this before
* getting the regexp to avoid shimmering problems.
*/
objPtr = objv[1];
stringLength = Tcl_GetCharLength(objPtr);
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if (regExpr == NULL) {
return TCL_ERROR;
}
if (offset > 0) {
/*
* Add flag if using offset (string is part of a larger string),
* so that "^" won't match.
*/
eflags |= TCL_REG_NOTBOL;
}
objc -= 2;
objv += 2;
resultPtr = Tcl_GetObjResult(interp);
if (doinline) {
/*
* Save all the subexpressions, as we will return them as a list
*/
numMatchesSaved = -1;
} else {
/*
* Save only enough subexpressions for matches we want to keep,
* expect in the case of -all, where we need to keep at least
* one to know where to move the offset.
*/
numMatchesSaved = (objc == 0) ? all : objc;
}
/*
* The following loop is to handle multiple matches within the
* same source string; each iteration handles one match. If "-all"
* hasn't been specified then the loop body only gets executed once.
* We terminate the loop when the starting offset is past the end of the
* string.
*/
while (1) {
match = Tcl_RegExpExecObj(interp, regExpr, objPtr,
offset /* offset */, numMatchesSaved, eflags
| ((offset > 0 &&
(Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n'))
? TCL_REG_NOTBOL : 0));
if (match < 0) {
return TCL_ERROR;
}
if (match == 0) {
/*
* We want to set the value of the intepreter result only when
* this is the first time through the loop.
*/
if (all <= 1) {
/*
* If inlining, set the interpreter's object result to an
* empty list, otherwise set it to an integer object w/
* value 0.
*/
if (doinline) {
Tcl_SetListObj(resultPtr, 0, NULL);
} else {
Tcl_SetIntObj(resultPtr, 0);
}
return TCL_OK;
}
break;
}
/*
* If additional variable names have been specified, return
* index information in those variables.
*/
Tcl_RegExpGetInfo(regExpr, &info);
if (doinline) {
/*
* It's the number of substitutions, plus one for the matchVar
* at index 0
*/
objc = info.nsubs + 1;
}
for (i = 0; i < objc; i++) {
Tcl_Obj *newPtr;
if (indices) {
int start, end;
Tcl_Obj *objs[2];
/*
* Only adjust the match area if there was a match for
* that area. (Scriptics Bug 4391/SF Bug #219232)
*/
if (i <= info.nsubs && info.matches[i].start >= 0) {
start = offset + info.matches[i].start;
end = offset + info.matches[i].end;
/*
* Adjust index so it refers to the last character in the
* match instead of the first character after the match.
*/
if (end >= offset) {
end--;
}
} else {
start = -1;
end = -1;
}
objs[0] = Tcl_NewLongObj(start);
objs[1] = Tcl_NewLongObj(end);
newPtr = Tcl_NewListObj(2, objs);
} else {
if (i <= info.nsubs) {
newPtr = Tcl_GetRange(objPtr,
offset + info.matches[i].start,
offset + info.matches[i].end - 1);
} else {
newPtr = Tcl_NewObj();
}
}
if (doinline) {
if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
!= TCL_OK) {
Tcl_DecrRefCount(newPtr);
return TCL_ERROR;
}
} else {
Tcl_Obj *valuePtr;
valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0);
if (valuePtr == NULL) {
Tcl_DecrRefCount(newPtr);
Tcl_AppendResult(interp, "couldn't set variable \"",
Tcl_GetString(objv[i]), "\"", (char *) NULL);
return TCL_ERROR;
}
}
}
if (all == 0) {
break;
}
/*
* Adjust the offset to the character just after the last one
* in the matchVar and increment all to count how many times
* we are making a match. We always increment the offset by at least
* one to prevent endless looping (as in the case:
* regexp -all {a*} a). Otherwise, when we match the NULL string at
* the end of the input string, we will loop indefinately (because the
* length of the match is 0, so offset never changes).
*/
if (info.matches[0].end == 0) {
offset++;
}
offset += info.matches[0].end;
all++;
eflags |= TCL_REG_NOTBOL;
if (offset >= stringLength) {
break;
}
}
/*
* Set the interpreter's object result to an integer object
* with value 1 if -all wasn't specified, otherwise it's all-1
* (the number of times through the while - 1).
* Get the resultPtr again as the Tcl_ObjSetVar2 above may have
* cause the result to change. [Patch #558324] (watson).
*/
if (!doinline) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_SetIntObj(resultPtr, (all ? all-1 : 1));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_RegsubObjCmd --
*
* This procedure is invoked to process the "regsub" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_RegsubObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
int start, end, subStart, subEnd, match;
Tcl_RegExp regExpr;
Tcl_RegExpInfo info;
Tcl_Obj *resultPtr, *subPtr, *objPtr;
Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend;
static CONST char *options[] = {
"-all", "-nocase", "-expanded",
"-line", "-linestop", "-lineanchor", "-start",
"--", NULL
};
enum options {
REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED,
REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START,
REGSUB_LAST
};
cflags = TCL_REG_ADVANCED;
all = 0;
offset = 0;
resultPtr = NULL;
for (idx = 1; idx < objc; idx++) {
char *name;
int index;
name = Tcl_GetString(objv[idx]);
if (name[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case REGSUB_ALL: {
all = 1;
break;
}
case REGSUB_NOCASE: {
cflags |= TCL_REG_NOCASE;
break;
}
case REGSUB_EXPANDED: {
cflags |= TCL_REG_EXPANDED;
break;
}
case REGSUB_LINE: {
cflags |= TCL_REG_NEWLINE;
break;
}
case REGSUB_LINESTOP: {
cflags |= TCL_REG_NLSTOP;
break;
}
case REGSUB_LINEANCHOR: {
cflags |= TCL_REG_NLANCH;
break;
}
case REGSUB_START: {
if (++idx >= objc) {
goto endOfForLoop;
}
if (Tcl_GetIntFromObj(interp, objv[idx], &offset) != TCL_OK) {
return TCL_ERROR;
}
if (offset < 0) {
offset = 0;
}
break;
}
case REGSUB_LAST: {
idx++;
goto endOfForLoop;
}
}
}
endOfForLoop:
if (objc-idx < 3 || objc-idx > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"?switches? exp string subSpec ?varName?");
return TCL_ERROR;
}
objc -= idx;
objv += idx;
if (all && (offset == 0)
&& (strpbrk(Tcl_GetString(objv[2]), "&\\") == NULL)
&& (strpbrk(Tcl_GetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) {
/*
* This is a simple one pair string map situation. We make use of
* a slightly modified version of the one pair STR_MAP code.
*/
int slen, nocase;
int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar *, CONST Tcl_UniChar *,
unsigned long));
Tcl_UniChar *p, wsrclc;
numMatches = 0;
nocase = (cflags & TCL_REG_NOCASE);
strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen);
wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen);
wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen);
wend = wstring + wlen - (slen ? slen - 1 : 0);
result = TCL_OK;
if (slen == 0) {
/*
* regsub behavior for "" matches between each character.
* 'string map' skips the "" case.
*/
if (wstring < wend) {
resultPtr = Tcl_NewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
for (; wstring < wend; wstring++) {
Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
Tcl_AppendUnicodeToObj(resultPtr, wstring, 1);
numMatches++;
}
wlen = 0;
}
} else {
wsrclc = Tcl_UniCharToLower(*wsrc);
for (p = wfirstChar = wstring; wstring < wend; wstring++) {
if (((*wstring == *wsrc) ||
(nocase && (Tcl_UniCharToLower(*wstring) ==
wsrclc))) &&
((slen == 1) || (strCmpFn(wstring, wsrc,
(unsigned long) slen) == 0))) {
if (numMatches == 0) {
resultPtr = Tcl_NewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
}
if (p != wstring) {
Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p);
p = wstring + slen;
} else {
p += slen;
}
wstring = p - 1;
Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
numMatches++;
}
}
if (numMatches) {
wlen = wfirstChar + wlen - p;
wstring = p;
}
}
objPtr = NULL;
subPtr = NULL;
goto regsubDone;
}
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if (regExpr == NULL) {
return TCL_ERROR;
}
/*
* Make sure to avoid problems where the objects are shared. This
* can cause RegExpObj <> UnicodeObj shimmering that causes data
* corruption. [Bug #461322]
*/
if (objv[1] == objv[0]) {
objPtr = Tcl_DuplicateObj(objv[1]);
} else {
objPtr = objv[1];
}
wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen);
if (objv[2] == objv[0]) {
subPtr = Tcl_DuplicateObj(objv[2]);
} else {
subPtr = objv[2];
}
wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);
result = TCL_OK;
/*
* The following loop is to handle multiple matches within the
* same source string; each iteration handles one match and its
* corresponding substitution. If "-all" hasn't been specified
* then the loop body only gets executed once. We must use
* 'offset <= wlen' in particular for the case where the regexp
* pattern can match the empty string - this is useful when
* doing, say, 'regsub -- ^ $str ...' when $str might be empty.
*/
numMatches = 0;
for ( ; offset <= wlen; ) {
/*
* The flags argument is set if string is part of a larger string,
* so that "^" won't match.
*/
match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset,
10 /* matches */, ((offset > 0 &&
(Tcl_GetUniChar(objPtr,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 (!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 code, level;
Tcl_Obj *valuePtr;
/* Start with the default options */
if (iPtr->returnOpts != iPtr->defaultReturnOpts) {
Tcl_DecrRefCount(iPtr->returnOpts);
iPtr->returnOpts = iPtr->defaultReturnOpts;
Tcl_IncrRefCount(iPtr->returnOpts);
}
objv++, objc--;
if (objc) {
/* We're going to add our options, so manage Tcl_Obj sharing */
Tcl_DecrRefCount(iPtr->returnOpts);
iPtr->returnOpts = Tcl_DuplicateObj(iPtr->returnOpts);
Tcl_IncrRefCount(iPtr->returnOpts);
}
for (; objc > 1; objv += 2, objc -= 2) {
int optLen;
CONST char *opt = Tcl_GetStringFromObj(objv[0], &optLen);
if ((optLen == 8) && (*opt == '-') && (strcmp(opt, "-options") == 0)) {
Tcl_DictSearch search;
int done = 0;
Tcl_Obj *keyPtr;
Tcl_Obj *dict = objv[1];
nestedOptions:
if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict,
&search, &keyPtr, &valuePtr, &done)) {
/* Value is not a legal dictionary */
Tcl_DecrRefCount(iPtr->returnOpts);
iPtr->returnOpts = iPtr->defaultReturnOpts;
Tcl_IncrRefCount(iPtr->returnOpts);
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad -options value: expected dictionary but got \"",
Tcl_GetString(objv[1]), "\"", (char *) NULL);
return TCL_ERROR;
}
while (!done) {
Tcl_DictObjPut(NULL, iPtr->returnOpts, keyPtr, valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
valuePtr = NULL;
Tcl_DictObjGet(NULL, iPtr->returnOpts,
iPtr->returnOptionsKey, &valuePtr);
if (valuePtr != NULL) {
dict = valuePtr;
Tcl_DictObjRemove(NULL, iPtr->returnOpts,
iPtr->returnOptionsKey);
goto nestedOptions;
}
} else {
Tcl_DictObjPut(NULL, iPtr->returnOpts, objv[0], objv[1]);
}
}
/* Check for bogus -code value */
Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnCodeKey, &valuePtr);
if (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code)) {
static CONST char *returnCodes[] = {
"ok", "error", "return", "break", "continue", NULL
};
if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes,
NULL, TCL_EXACT, &code)) {
/* Value is not a legal return code */
Tcl_DecrRefCount(iPtr->returnOpts);
iPtr->returnOpts = iPtr->defaultReturnOpts;
Tcl_IncrRefCount(iPtr->returnOpts);
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad completion code \"",
Tcl_GetString(valuePtr),
"\": must be ok, error, return, break, ",
"continue, or an integer", (char *) NULL);
return TCL_ERROR;
}
/* Have a legal string value for a return code; convert to integer */
Tcl_DictObjPut(NULL, iPtr->returnOpts,
iPtr->returnCodeKey, Tcl_NewIntObj(code));
}
/* Check for bogus -level value */
Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnLevelKey, &valuePtr);
if (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level) || (level < 0)) {
/* Value is not a legal level */
Tcl_DecrRefCount(iPtr->returnOpts);
iPtr->returnOpts = iPtr->defaultReturnOpts;
Tcl_IncrRefCount(iPtr->returnOpts);
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad -level value: expected non-negative integer but got \"",
Tcl_GetString(valuePtr), "\"", (char *) NULL);
return TCL_ERROR;
}
/*
* Convert [return -code return -level X] to
* [return -code ok -level X+1]
*/
if (code == TCL_RETURN) {
level++;
Tcl_DictObjPut(NULL, iPtr->returnOpts,
iPtr->returnLevelKey, Tcl_NewIntObj(level));
Tcl_DictObjPut(NULL, iPtr->returnOpts,
iPtr->returnCodeKey, Tcl_NewIntObj(TCL_OK));
}
if (level == 0) {
if (code == TCL_ERROR) {
valuePtr = NULL;
Tcl_DictObjGet(NULL, iPtr->returnOpts,
iPtr->returnErrorinfoKey, &valuePtr);
if (valuePtr != NULL) {
int infoLen;
CONST char *info = Tcl_GetStringFromObj(valuePtr,&infoLen);
if (infoLen) {
Tcl_AddObjErrorInfo(interp, info, infoLen);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
valuePtr = NULL;
Tcl_DictObjGet(NULL, iPtr->returnOpts,
iPtr->returnErrorcodeKey, &valuePtr);
if (valuePtr != NULL) {
Tcl_SetVar2Ex(interp, "errorCode", NULL,
valuePtr, TCL_GLOBAL_ONLY);
iPtr->flags |= ERROR_CODE_SET;
}
}
} else {
code = TCL_RETURN;
}
if (objc == 1) {
Tcl_SetObjResult(interp, objv[0]);
}
return code;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SourceObjCmd --
*
* This procedure is invoked to process the "source" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_SourceObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "fileName");
return TCL_ERROR;
}
return Tcl_FSEvalFile(interp, objv[1]);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SplitObjCmd --
*
* This procedure is invoked to process the "split" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_SplitObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_UniChar ch;
int len;
char *splitChars, *string, *end;
int splitCharLen, stringLen;
Tcl_Obj *listPtr, *objPtr;
if (objc == 2) {
splitChars = " \n\t\r";
splitCharLen = 4;
} else if (objc == 3) {
splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
return TCL_ERROR;
}
string = Tcl_GetStringFromObj(objv[1], &stringLen);
end = string + stringLen;
listPtr = Tcl_GetObjResult(interp);
if (stringLen == 0) {
/*
* Do nothing.
*/
} else if (splitCharLen == 0) {
Tcl_HashTable charReuseTable;
Tcl_HashEntry *hPtr;
int isNew;
/*
* Handle the special case of splitting on every character.
*
* Uses a hash table to ensure that each kind of character has
* only one Tcl_Obj instance (multiply-referenced) in the
* final list. This is a *major* win when splitting on a long
* string (especially in the megabyte range!) - DKF
*/
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; string < end; string += len) {
len = TclUtfToUniChar(string, &ch);
/* Assume Tcl_UniChar is an integral type... */
hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew);
if (isNew) {
objPtr = Tcl_NewStringObj(string, len);
/* Don't need to fiddle with refcount... */
Tcl_SetHashValue(hPtr, (ClientData) objPtr);
} else {
objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr);
}
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
Tcl_DeleteHashTable(&charReuseTable);
} else if (splitCharLen == 1) {
char *p;
/*
* Handle the special case of splitting on a single character.
* This is only true for the one-char ASCII case, as one unicode
* char is > 1 byte in length.
*/
while (*string && (p = strchr(string, (int) *splitChars)) != NULL) {
objPtr = Tcl_NewStringObj(string, p - string);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
string = p + 1;
}
objPtr = Tcl_NewStringObj(string, end - string);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
} else {
char *element, *p, *splitEnd;
int splitLen;
Tcl_UniChar splitChar;
/*
* Normal case: split on any of a given set of characters.
* Discard instances of the split characters.
*/
splitEnd = splitChars + splitCharLen;
for (element = string; string < end; string += len) {
len = TclUtfToUniChar(string, &ch);
for (p = splitChars; p < splitEnd; p += splitLen) {
splitLen = TclUtfToUniChar(p, &splitChar);
if (ch == splitChar) {
objPtr = Tcl_NewStringObj(element, string - element);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
element = string + len;
break;
}
}
}
objPtr = Tcl_NewStringObj(element, string - element);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_StringObjCmd --
*
* This procedure is invoked to process the "string" Tcl command.
* See the user documentation for details on what it does. Note
* that this command only functions correctly on properly formed
* Tcl UTF strings.
*
* Note that the primary methods here (equal, compare, match, ...)
* have bytecode equivalents. You will find the code for those in
* tclExecute.c. The code here will only be used in the non-bc
* case (like in an 'eval').
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_StringObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int index, left, right;
Tcl_Obj *resultPtr;
char *string1, *string2;
int length1, length2;
static CONST char *options[] = {
"bytelength", "compare", "equal", "first",
"index", "is", "last", "length",
"map", "match", "range", "repeat",
"replace", "tolower", "toupper", "totitle",
"trim", "trimleft", "trimright",
"wordend", "wordstart", (char *) NULL
};
enum options {
STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST,
STR_INDEX, STR_IS, STR_LAST, STR_LENGTH,
STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT,
STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE,
STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
STR_WORDEND, STR_WORDSTART
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_GetObjResult(interp);
switch ((enum options) index) {
case STR_EQUAL:
case STR_COMPARE: {
/*
* Remember to keep code here in some sync with the
* byte-compiled versions in tclExecute.c (INST_STR_EQ,
* INST_STR_NEQ and INST_STR_CMP as well as the expr string
* comparison in INST_EQ/INST_NEQ/INST_LT/...).
*/
int i, match, length, nocase = 0, reqlength = -1;
int (*strCmpFn)();
if (objc < 4 || objc > 7) {
str_cmp_args:
Tcl_WrongNumArgs(interp, 2, objv,
"?-nocase? ?-length int? string1 string2");
return TCL_ERROR;
}
for (i = 2; i < objc-2; i++) {
string2 = Tcl_GetStringFromObj(objv[i], &length2);
if ((length2 > 1)
&& strncmp(string2, "-nocase", (size_t)length2) == 0) {
nocase = 1;
} else if ((length2 > 1)
&& strncmp(string2, "-length", (size_t)length2) == 0) {
if (i+1 >= objc-2) {
goto str_cmp_args;
}
if (Tcl_GetIntFromObj(interp, objv[++i],
&reqlength) != TCL_OK) {
return TCL_ERROR;
}
} else {
Tcl_AppendStringsToObj(resultPtr, "bad option \"",
string2, "\": must be -nocase or -length",
(char *) NULL);
return TCL_ERROR;
}
}
/*
* From now on, we only access the two objects at the end
* of the argument array.
*/
objv += objc-2;
if ((reqlength == 0) || (objv[0] == objv[1])) {
/*
* Alway match at 0 chars of if it is the same obj.
*/
Tcl_SetBooleanObj(resultPtr,
((enum options) index == STR_EQUAL));
break;
} else if (!nocase && objv[0]->typePtr == &tclByteArrayType &&
objv[1]->typePtr == &tclByteArrayType) {
/*
* Use binary versions of comparisons since that won't
* cause undue type conversions and it is much faster.
* Only do this if we're case-sensitive (which is all
* that really makes sense with byte arrays anyway, and
* we have no memcasecmp() for some reason... :^)
*/
string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1);
string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2);
strCmpFn = memcmp;
} else if ((objv[0]->typePtr == &tclStringType)
&& (objv[1]->typePtr == &tclStringType)) {
/*
* Do a unicode-specific comparison if both of the args
* are of String type. In benchmark testing this proved
* the most efficient check between the unicode and
* string comparison operations.
*/
string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1);
string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2);
strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
} else {
/*
* As a catch-all we will work with UTF-8. We cannot use
* memcmp() as that is unsafe with any string containing
* NULL (\xC0\x80 in Tcl's utf rep). We can use the more
* efficient TclpUtfNcmp2 if we are case-sensitive and no
* specific length was requested.
*/
string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1);
string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2);
if ((reqlength < 0) && !nocase) {
strCmpFn = TclpUtfNcmp2;
} else {
length1 = Tcl_NumUtfChars(string1, length1);
length2 = Tcl_NumUtfChars(string2, length2);
strCmpFn = nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp;
}
}
if (((enum options) index == STR_EQUAL)
&& (reqlength < 0) && (length1 != length2)) {
match = 1; /* this will be reversed below */
} else {
length = (length1 < length2) ? length1 : length2;
if (reqlength > 0 && reqlength < length) {
length = reqlength;
} else if (reqlength < 0) {
/*
* The requested length is negative, so we ignore it by
* setting it to length + 1 so we correct the match var.
*/
reqlength = length + 1;
}
match = strCmpFn(string1, string2, (unsigned) length);
if ((match == 0) && (reqlength > length)) {
match = length1 - length2;
}
}
if ((enum options) index == STR_EQUAL) {
Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1);
} else {
Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 :
(match < 0) ? -1 : 0));
}
break;
}
case STR_FIRST: {
Tcl_UniChar *ustring1, *ustring2;
int match, start;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv,
"subString string ?startIndex?");
return TCL_ERROR;
}
/*
* We are searching string2 for the sequence string1.
*/
match = -1;
start = 0;
length2 = -1;
ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
if (objc == 5) {
/*
* If a startIndex is specified, we will need to fast
* forward to that point in the string before we think
* about a match
*/
if (TclGetIntForIndex(interp, objv[4], length2 - 1,
&start) != TCL_OK) {
return TCL_ERROR;
}
if (start >= length2) {
goto str_first_done;
} else if (start > 0) {
ustring2 += start;
length2 -= start;
} else if (start < 0) {
/*
* Invalid start index mapped to string start;
* Bug #423581
*/
start = 0;
}
}
if (length1 > 0) {
register Tcl_UniChar *p, *end;
end = ustring2 + length2 - length1 + 1;
for (p = ustring2; p < end; p++) {
/*
* Scan forward to find the first character.
*/
if ((*p == *ustring1) &&
(TclUniCharNcmp(ustring1, p,
(unsigned long) length1) == 0)) {
match = p - ustring2;
break;
}
}
}
/*
* Compute the character index of the matching string by
* counting the number of characters before the match.
*/
if ((match != -1) && (objc == 5)) {
match += start;
}
str_first_done:
Tcl_SetIntObj(resultPtr, match);
break;
}
case STR_INDEX: {
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
return TCL_ERROR;
}
/*
* If we have a ByteArray object, avoid indexing in the
* Utf string since the byte array contains one byte per
* character. Otherwise, use the Unicode string rep to
* get the index'th char.
*/
if (objv[2]->typePtr == &tclByteArrayType) {
string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1);
if (TclGetIntForIndex(interp, objv[3], length1 - 1,
&index) != TCL_OK) {
return TCL_ERROR;
}
if ((index >= 0) && (index < length1)) {
Tcl_SetByteArrayObj(resultPtr,
(unsigned char *)(&string1[index]), 1);
}
} else {
/*
* Get Unicode char length to calulate what 'end' means.
*/
length1 = Tcl_GetCharLength(objv[2]);
if (TclGetIntForIndex(interp, objv[3], length1 - 1,
&index) != TCL_OK) {
return TCL_ERROR;
}
if ((index >= 0) && (index < length1)) {
char buf[TCL_UTF_MAX];
Tcl_UniChar ch;
ch = Tcl_GetUniChar(objv[2], index);
length1 = Tcl_UniCharToUtf(ch, buf);
Tcl_SetStringObj(resultPtr, buf, length1);
}
}
break;
}
case STR_IS: {
char *end;
Tcl_UniChar ch;
/*
* The UniChar comparison function
*/
int (*chcomp)_ANSI_ARGS_((int)) = NULL;
int i, failat = 0, result = 1, strict = 0;
Tcl_Obj *objPtr, *failVarObj = NULL;
static CONST char *isOptions[] = {
"alnum", "alpha", "ascii", "control",
"boolean", "digit", "double", "false",
"graph", "integer", "lower", "print",
"punct", "space", "true", "upper",
"wordchar", "xdigit", (char *) NULL
};
enum isOptions {
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE,
STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT,
STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER,
STR_IS_WORD, STR_IS_XDIGIT
};
if (objc < 4 || objc > 7) {
Tcl_WrongNumArgs(interp, 2, objv,
"class ?-strict? ?-failindex var? str");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (objc != 4) {
for (i = 3; i < objc-1; i++) {
string2 = Tcl_GetStringFromObj(objv[i], &length2);
if ((length2 > 1) &&
strncmp(string2, "-strict", (size_t) length2) == 0) {
strict = 1;
} else if ((length2 > 1) &&
strncmp(string2, "-failindex",
(size_t) length2) == 0) {
if (i+1 >= objc-1) {
Tcl_WrongNumArgs(interp, 3, objv,
"?-strict? ?-failindex var? str");
return TCL_ERROR;
}
failVarObj = objv[++i];
} else {
Tcl_AppendStringsToObj(resultPtr, "bad option \"",
string2, "\": must be -strict or -failindex",
(char *) NULL);
return TCL_ERROR;
}
}
}
/*
* We get the objPtr so that we can short-cut for some classes
* by checking the object type (int and double), but we need
* the string otherwise, because we don't want any conversion
* of type occuring (as, for example, Tcl_Get*FromObj would do
*/
objPtr = objv[objc-1];
string1 = Tcl_GetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
}
end = string1 + length1;
/*
* When entering here, result == 1 and failat == 0
*/
switch ((enum isOptions) index) {
case STR_IS_ALNUM:
chcomp = Tcl_UniCharIsAlnum;
break;
case STR_IS_ALPHA:
chcomp = Tcl_UniCharIsAlpha;
break;
case STR_IS_ASCII:
for (; string1 < end; string1++, failat++) {
/*
* This is a valid check in unicode, because all
* bytes < 0xC0 are single byte chars (but isascii
* limits that def'n to 0x80).
*/
if (*((unsigned char *)string1) >= 0x80) {
result = 0;
break;
}
}
break;
case STR_IS_BOOL:
case STR_IS_TRUE:
case STR_IS_FALSE:
if (objPtr->typePtr == &tclBooleanType) {
if ((((enum isOptions) index == STR_IS_TRUE) &&
objPtr->internalRep.longValue == 0) ||
(((enum isOptions) index == STR_IS_FALSE) &&
objPtr->internalRep.longValue != 0)) {
result = 0;
}
} else if ((Tcl_GetBoolean(NULL, string1, &i)
== TCL_ERROR) ||
(((enum isOptions) index == STR_IS_TRUE) &&
i == 0) ||
(((enum isOptions) index == STR_IS_FALSE) &&
i != 0)) {
result = 0;
}
break;
case STR_IS_CONTROL:
chcomp = Tcl_UniCharIsControl;
break;
case STR_IS_DIGIT:
chcomp = Tcl_UniCharIsDigit;
break;
case STR_IS_DOUBLE: {
char *stop;
if ((objPtr->typePtr == &tclDoubleType) ||
(objPtr->typePtr == &tclIntType)) {
break;
}
/*
* This is adapted from Tcl_GetDouble
*
* The danger in this function is that
* "12345678901234567890" is an acceptable 'double',
* but will later be interp'd as an int by something
* like [expr]. Therefore, we check to see if it looks
* like an int, and if so we do a range check on it.
* If strtoul gets to the end, we know we either
* received an acceptable int, or over/underflow
*/
if (TclLooksLikeInt(string1, length1)) {
errno = 0;
#ifdef TCL_WIDE_INT_IS_LONG
strtoul(string1, &stop, 0); /* INTL: Tcl source. */
#else
strtoull(string1, &stop, 0); /* INTL: Tcl source. */
#endif
if (stop == end) {
if (errno == ERANGE) {
result = 0;
failat = -1;
}
break;
}
}
errno = 0;
strtod(string1, &stop); /* INTL: Tcl source. */
if (errno == ERANGE) {
/*
* if (errno == ERANGE), then it was an over/underflow
* problem, but in this method, we only want to know
* yes or no, so bad flow returns 0 (false) and sets
* the failVarObj to the string length.
*/
result = 0;
failat = -1;
} else if (stop == string1) {
/*
* In this case, nothing like a number was found
*/
result = 0;
failat = 0;
} else {
/*
* Assume we sucked up one char per byte
* and then we go onto SPACE, since we are
* allowed trailing whitespace
*/
failat = stop - string1;
string1 = stop;
chcomp = Tcl_UniCharIsSpace;
}
break;
}
case STR_IS_GRAPH:
chcomp = Tcl_UniCharIsGraph;
break;
case STR_IS_INT: {
char *stop;
long int l = 0;
if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) {
break;
}
/*
* Like STR_IS_DOUBLE, but we use strtoul.
* Since Tcl_GetIntFromObj already failed,
* we set result to 0.
*/
result = 0;
errno = 0;
l = strtol(string1, &stop, 0); /* INTL: Tcl source. */
if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) {
/*
* if (errno == ERANGE), then it was an over/underflow
* problem, but in this method, we only want to know
* yes or no, so bad flow returns 0 (false) and sets
* the failVarObj to the string length.
*/
failat = -1;
} else if (stop == string1) {
/*
* In this case, nothing like a number was found
*/
failat = 0;
} else {
/*
* Assume we sucked up one char per byte
* and then we go onto SPACE, since we are
* allowed trailing whitespace
*/
failat = stop - string1;
string1 = stop;
chcomp = Tcl_UniCharIsSpace;
}
break;
}
case STR_IS_LOWER:
chcomp = Tcl_UniCharIsLower;
break;
case STR_IS_PRINT:
chcomp = Tcl_UniCharIsPrint;
break;
case STR_IS_PUNCT:
chcomp = Tcl_UniCharIsPunct;
break;
case STR_IS_SPACE:
chcomp = Tcl_UniCharIsSpace;
break;
case STR_IS_UPPER:
chcomp = Tcl_UniCharIsUpper;
break;
case STR_IS_WORD:
chcomp = Tcl_UniCharIsWordChar;
break;
case STR_IS_XDIGIT: {
for (; string1 < end; string1++, failat++) {
/* INTL: We assume unicode is bad for this class */
if ((*((unsigned char *)string1) >= 0xC0) ||
!isxdigit(*(unsigned char *)string1)) {
result = 0;
break;
}
}
break;
}
}
if (chcomp != NULL) {
for (; string1 < end; string1 += length2, failat++) {
length2 = TclUtfToUniChar(string1, &ch);
if (!chcomp(ch)) {
result = 0;
break;
}
}
}
str_is_done:
/*
* Only set the failVarObj when we will return 0
* and we have indicated a valid fail index (>= 0)
*/
if ((result == 0) && (failVarObj != NULL) &&
Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat),
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
Tcl_SetBooleanObj(resultPtr, result);
break;
}
case STR_LAST: {
Tcl_UniChar *ustring1, *ustring2, *p;
int match, start;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv,
"subString string ?startIndex?");
return TCL_ERROR;
}
/*
* We are searching string2 for the sequence string1.
*/
match = -1;
start = 0;
length2 = -1;
ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
if (objc == 5) {
/*
* If a startIndex is specified, we will need to restrict
* the string range to that char index in the string
*/
if (TclGetIntForIndex(interp, objv[4], length2 - 1,
&start) != TCL_OK) {
return TCL_ERROR;
}
if (start < 0) {
goto str_last_done;
} else if (start < length2) {
p = ustring2 + start + 1 - length1;
} else {
p = ustring2 + length2 - length1;
}
} else {
p = ustring2 + length2 - length1;
}
if (length1 > 0) {
for (; p >= ustring2; p--) {
/*
* Scan backwards to find the first character.
*/
if ((*p == *ustring1) &&
(memcmp((char *) ustring1, (char *) p, (size_t)
(length1 * sizeof(Tcl_UniChar))) == 0)) {
match = p - ustring2;
break;
}
}
}
str_last_done:
Tcl_SetIntObj(resultPtr, match);
break;
}
case STR_BYTELENGTH:
case STR_LENGTH: {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "string");
return TCL_ERROR;
}
if ((enum options) index == STR_BYTELENGTH) {
(void) Tcl_GetStringFromObj(objv[2], &length1);
} else {
/*
* If we have a ByteArray object, avoid recomputing the
* string since the byte array contains one byte per
* character. Otherwise, use the Unicode string rep to
* calculate the length.
*/
if (objv[2]->typePtr == &tclByteArrayType) {
(void) Tcl_GetByteArrayFromObj(objv[2], &length1);
} else {
length1 = Tcl_GetCharLength(objv[2]);
}
}
Tcl_SetIntObj(resultPtr, length1);
break;
}
case STR_MAP: {
int mapElemc, nocase = 0, mapWithDict = 0;
Tcl_Obj **mapElemv;
Tcl_UniChar *ustring1, *ustring2, *p, *end;
int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*,
CONST Tcl_UniChar*, unsigned long));
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string");
return TCL_ERROR;
}
if (objc == 5) {
string2 = Tcl_GetStringFromObj(objv[2], &length2);
if ((length2 > 1) &&
strncmp(string2, "-nocase", (size_t) length2) == 0) {
nocase = 1;
} else {
Tcl_AppendStringsToObj(resultPtr, "bad option \"",
string2, "\": must be -nocase", (char *) NULL);
return TCL_ERROR;
}
}
/*
* This test is tricky, but has to be that way or you get
* other strange inconsistencies (see test string-10.20
* for illustration why!)
*/
if (objv[objc-2]->typePtr == &tclDictType &&
objv[objc-2]->bytes == NULL) {
int i, done;
Tcl_DictSearch search;
/*
* We know the type exactly, so all dict operations
* will succeed for sure. This shortens this code
* quite a bit.
*/
Tcl_DictObjSize(interp, objv[objc-2], &mapElemc);
if (mapElemc == 0) {
/*
* empty charMap, just return whatever string was given
*/
Tcl_SetObjResult(interp, objv[objc-1]);
return TCL_OK;
}
mapElemc *= 2;
mapWithDict = 1;
/*
* Copy the dictionary out into an array; that's the
* easiest way to adapt this code...
*/
mapElemv = (Tcl_Obj **) ckalloc(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);
}
} else {
if (Tcl_ListObjGetElements(interp, objv[objc-2],
&mapElemc, &mapElemv) != TCL_OK) {
return TCL_ERROR;
}
if (mapElemc == 0) {
/*
* empty charMap, just return whatever string was given
*/
Tcl_SetObjResult(interp, objv[objc-1]);
return TCL_OK;
} else if (mapElemc & 1) {
/*
* The charMap must be an even number of key/value items
*/
Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1);
return TCL_ERROR;
}
}
objc--;
ustring1 = Tcl_GetUnicodeFromObj(objv[objc], &length1);
if (length1 == 0) {
/*
* Empty input string, just stop now
*/
if (mapWithDict) {
ckfree((char *) mapElemv);
}
break;
}
end = ustring1 + length1;
strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
/*
* Force result to be Unicode
*/
Tcl_SetUnicodeObj(resultPtr, ustring1, 0);
if (mapElemc == 2) {
/*
* Special case for one map pair which avoids the extra
* for loop and extra calls to get Unicode data. The
* algorithm is otherwise identical to the multi-pair case.
* This will be >30% faster on larger strings.
*/
int mapLen;
Tcl_UniChar *mapString, u2lc;
ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
p = ustring1;
if (length2 == 0) {
ustring1 = end;
} else {
mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen);
u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0);
for (; ustring1 < end; ustring1++) {
if (((*ustring1 == *ustring2) ||
(nocase && (Tcl_UniCharToLower(*ustring1) ==
u2lc))) &&
((length2 == 1) || strCmpFn(ustring1, ustring2,
(unsigned long) length2) == 0)) {
if (p != ustring1) {
Tcl_AppendUnicodeToObj(resultPtr, p,
ustring1 - p);
p = ustring1 + length2;
} else {
p += length2;
}
ustring1 = p - 1;
Tcl_AppendUnicodeToObj(resultPtr, mapString,
mapLen);
}
}
}
} else {
Tcl_UniChar **mapStrings, *u2lc = NULL;
int *mapLens;
/*
* Precompute pointers to the unicode string and length.
* This saves us repeated function calls later,
* significantly speeding up the algorithm. We only need
* the lowercase first char in the nocase case.
*/
mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2)
* sizeof(Tcl_UniChar *));
mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int));
if (nocase) {
u2lc = (Tcl_UniChar *)
ckalloc((mapElemc) * sizeof(Tcl_UniChar));
}
for (index = 0; index < mapElemc; index++) {
mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
&(mapLens[index]));
if (nocase && ((index % 2) == 0)) {
u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]);
}
}
for (p = ustring1; ustring1 < end; ustring1++) {
for (index = 0; index < mapElemc; index += 2) {
/*
* Get the key string to match on.
*/
ustring2 = mapStrings[index];
length2 = mapLens[index];
if ((length2 > 0) && ((*ustring1 == *ustring2) ||
(nocase && (Tcl_UniCharToLower(*ustring1) ==
u2lc[index/2]))) &&
((length2 == 1) || strCmpFn(ustring2, ustring1,
(unsigned long) length2) == 0)) {
if (p != ustring1) {
/*
* Put the skipped chars onto the result first
*/
Tcl_AppendUnicodeToObj(resultPtr, p,
ustring1 - p);
p = ustring1 + length2;
} else {
p += length2;
}
/*
* Adjust len to be full length of matched string
*/
ustring1 = p - 1;
/*
* Append the map value to the unicode string
*/
Tcl_AppendUnicodeToObj(resultPtr,
mapStrings[index+1], mapLens[index+1]);
break;
}
}
}
ckfree((char *) mapStrings);
ckfree((char *) mapLens);
if (nocase) {
ckfree((char *) u2lc);
}
}
if (p != ustring1) {
/*
* Put the rest of the unmapped chars onto result
*/
Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
}
if (mapWithDict) {
ckfree((char *) mapElemv);
}
break;
}
case STR_MATCH: {
Tcl_UniChar *ustring1, *ustring2;
int nocase = 0;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string");
return TCL_ERROR;
}
if (objc == 5) {
string2 = Tcl_GetStringFromObj(objv[2], &length2);
if ((length2 > 1) &&
strncmp(string2, "-nocase", (size_t) length2) == 0) {
nocase = 1;
} else {
Tcl_AppendStringsToObj(resultPtr, "bad option \"",
string2, "\": must be -nocase",
(char *) NULL);
return TCL_ERROR;
}
}
ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1);
ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2);
Tcl_SetBooleanObj(resultPtr, TclUniCharMatch(ustring1, length1,
ustring2, length2, nocase));
break;
}
case STR_RANGE: {
int first, last;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "string first last");
return TCL_ERROR;
}
/*
* If we have a ByteArray object, avoid indexing in the
* Utf string since the byte array contains one byte per
* character. Otherwise, use the Unicode string rep to
* get the range.
*/
if (objv[2]->typePtr == &tclByteArrayType) {
string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1);
length1--;
} else {
/*
* Get the length in actual characters.
*/
string1 = NULL;
length1 = Tcl_GetCharLength(objv[2]) - 1;
}
if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
|| (TclGetIntForIndex(interp, objv[4], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if (first < 0) {
first = 0;
}
if (last >= length1) {
last = length1;
}
if (last >= first) {
if (string1 != NULL) {
int numBytes = last - first + 1;
resultPtr = Tcl_NewByteArrayObj(
(unsigned char *) &string1[first], numBytes);
Tcl_SetObjResult(interp, resultPtr);
} else {
Tcl_SetObjResult(interp,
Tcl_GetRange(objv[2], first, last));
}
}
break;
}
case STR_REPEAT: {
int count;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string count");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) {
return TCL_ERROR;
}
if (count == 1) {
Tcl_SetObjResult(interp, objv[2]);
} else if (count > 1) {
string1 = Tcl_GetStringFromObj(objv[2], &length1);
if (length1 > 0) {
/*
* Only build up a string that has data. Instead of
* building it up with repeated appends, we just allocate
* the necessary space once and copy the string value in.
* Check for overflow with back-division. [Bug #714106]
*/
length2 = length1 * count;
if ((length2 / count) != length1) {
char buf[TCL_INTEGER_SPACE+1];
sprintf(buf, "%d", INT_MAX);
Tcl_AppendStringsToObj(resultPtr,
"string size overflow, must be less than ",
buf, (char *) NULL);
return TCL_ERROR;
}
/*
* Include space for the NULL
*/
string2 = (char *) ckalloc((size_t) length2+1);
for (index = 0; index < count; index++) {
memcpy(string2 + (length1 * index), string1,
(size_t) length1);
}
string2[length2] = '\0';
/*
* We have to directly assign this instead of using
* Tcl_SetStringObj (and indirectly TclInitStringRep)
* because that makes another copy of the data.
*/
resultPtr = Tcl_NewObj();
resultPtr->bytes = string2;
resultPtr->length = length2;
Tcl_SetObjResult(interp, resultPtr);
}
}
break;
}
case STR_REPLACE: {
Tcl_UniChar *ustring1;
int first, last;
if (objc < 5 || objc > 6) {
Tcl_WrongNumArgs(interp, 2, objv,
"string first last ?string?");
return TCL_ERROR;
}
ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
length1--;
if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
|| (TclGetIntForIndex(interp, objv[4], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if ((last < first) || (last < 0) || (first > length1)) {
Tcl_SetObjResult(interp, objv[2]);
} else {
if (first < 0) {
first = 0;
}
Tcl_SetUnicodeObj(resultPtr, ustring1, first);
if (objc == 6) {
Tcl_AppendObjToObj(resultPtr, objv[5]);
}
if (last < length1) {
Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1,
length1 - last);
}
}
break;
}
case STR_TOLOWER:
case STR_TOUPPER:
case STR_TOTITLE:
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[2], &length1);
if (objc == 3) {
/*
* Since the result object is not a shared object, it is
* safe to copy the string into the result and do the
* conversion in place. The conversion may change the length
* of the string, so reset the length after conversion.
*/
Tcl_SetStringObj(resultPtr, string1, length1);
if ((enum options) index == STR_TOLOWER) {
length1 = Tcl_UtfToLower(Tcl_GetString(resultPtr));
} else if ((enum options) index == STR_TOUPPER) {
length1 = Tcl_UtfToUpper(Tcl_GetString(resultPtr));
} else {
length1 = Tcl_UtfToTitle(Tcl_GetString(resultPtr));
}
Tcl_SetObjLength(resultPtr, length1);
} else {
int first, last;
CONST char *start, *end;
length1 = Tcl_NumUtfChars(string1, length1) - 1;
if (TclGetIntForIndex(interp, objv[3], length1,
&first) != TCL_OK) {
return TCL_ERROR;
}
if (first < 0) {
first = 0;
}
last = first;
if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if (last >= length1) {
last = length1;
}
if (last < first) {
Tcl_SetObjResult(interp, objv[2]);
break;
}
start = Tcl_UtfAtIndex(string1, first);
end = Tcl_UtfAtIndex(start, last - first + 1);
length2 = end-start;
string2 = ckalloc((size_t) length2+1);
memcpy(string2, start, (size_t) length2);
string2[length2] = '\0';
if ((enum options) index == STR_TOLOWER) {
length2 = Tcl_UtfToLower(string2);
} else if ((enum options) index == STR_TOUPPER) {
length2 = Tcl_UtfToUpper(string2);
} else {
length2 = Tcl_UtfToTitle(string2);
}
Tcl_SetStringObj(resultPtr, string1, start - string1);
Tcl_AppendToObj(resultPtr, string2, length2);
Tcl_AppendToObj(resultPtr, end, -1);
ckfree(string2);
}
break;
case STR_TRIM: {
Tcl_UniChar ch, trim;
register CONST char *p, *end;
char *check, *checkEnd;
int offset;
left = 1;
right = 1;
dotrim:
if (objc == 4) {
string2 = Tcl_GetStringFromObj(objv[3], &length2);
} else if (objc == 3) {
string2 = " \t\n\r";
length2 = strlen(string2);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[2], &length1);
checkEnd = string2 + length2;
if (left) {
end = string1 + length1;
/*
* The outer loop iterates over the string. The inner
* loop iterates over the trim characters. The loops
* terminate as soon as a non-trim character is discovered
* and string1 is left pointing at the first non-trim
* character.
*/
for (p = string1; p < end; p += offset) {
offset = TclUtfToUniChar(p, &ch);
for (check = string2; ; ) {
if (check >= checkEnd) {
p = end;
break;
}
check += TclUtfToUniChar(check, &trim);
if (ch == trim) {
length1 -= offset;
string1 += offset;
break;
}
}
}
}
if (right) {
end = string1;
/*
* The outer loop iterates over the string. The inner
* loop iterates over the trim characters. The loops
* terminate as soon as a non-trim character is discovered
* and length1 marks the last non-trim character.
*/
for (p = string1 + length1; p > end; ) {
p = Tcl_UtfPrev(p, string1);
offset = TclUtfToUniChar(p, &ch);
for (check = string2; ; ) {
if (check >= checkEnd) {
p = end;
break;
}
check += TclUtfToUniChar(check, &trim);
if (ch == trim) {
length1 -= offset;
break;
}
}
}
}
Tcl_SetStringObj(resultPtr, string1, length1);
break;
}
case STR_TRIMLEFT: {
left = 1;
right = 0;
goto dotrim;
}
case STR_TRIMRIGHT: {
left = 0;
right = 1;
goto dotrim;
}
case STR_WORDEND: {
int cur;
Tcl_UniChar ch;
CONST char *p, *end;
int numChars;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string index");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[2], &length1);
numChars = Tcl_NumUtfChars(string1, length1);
if (TclGetIntForIndex(interp, objv[3], numChars-1,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (index < 0) {
index = 0;
}
if (index < numChars) {
p = Tcl_UtfAtIndex(string1, index);
end = string1+length1;
for (cur = index; p < end; cur++) {
p += TclUtfToUniChar(p, &ch);
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
}
if (cur == index) {
cur++;
}
} else {
cur = numChars;
}
Tcl_SetIntObj(resultPtr, cur);
break;
}
case STR_WORDSTART: {
int cur;
Tcl_UniChar ch;
CONST char *p;
int numChars;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string index");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[2], &length1);
numChars = Tcl_NumUtfChars(string1, length1);
if (TclGetIntForIndex(interp, objv[3], numChars-1,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (index >= numChars) {
index = numChars - 1;
}
cur = 0;
if (index > 0) {
p = Tcl_UtfAtIndex(string1, index);
for (cur = index; cur >= 0; cur--) {
TclUtfToUniChar(p, &ch);
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
p = Tcl_UtfPrev(p, string1);
}
if (cur != index) {
cur += 1;
}
}
Tcl_SetIntObj(resultPtr, cur);
break;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SubstObjCmd --
*
* This procedure is invoked to process the "subst" Tcl command.
* See the user documentation for details on what it does. This
* command relies on Tcl_SubstObj() for its implementation.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_SubstObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *substOptions[] = {
"-nobackslashes", "-nocommands", "-novariables", (char *) NULL
};
enum substOptions {
SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
};
Tcl_Obj *resultPtr;
int optionIndex, flags, i;
/*
* Parse command-line options.
*/
flags = TCL_SUBST_ALL;
for (i = 1; i < (objc-1); i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], substOptions,
"switch", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch (optionIndex) {
case SUBST_NOBACKSLASHES: {
flags &= ~TCL_SUBST_BACKSLASHES;
break;
}
case SUBST_NOCOMMANDS: {
flags &= ~TCL_SUBST_COMMANDS;
break;
}
case SUBST_NOVARS: {
flags &= ~TCL_SUBST_VARIABLES;
break;
}
default: {
panic("Tcl_SubstObjCmd: bad option index to SubstOptions");
}
}
}
if (i != (objc-1)) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-nobackslashes? ?-nocommands? ?-novariables? string");
return TCL_ERROR;
}
/*
* Perform the substitution.
*/
resultPtr = Tcl_SubstObj(interp, objv[i], flags);
if (resultPtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SwitchObjCmd --
*
* This object-based procedure is invoked to process the "switch" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_SwitchObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int i, j, index, mode, matched, result, splitObjs;
char *string, *pattern;
Tcl_Obj *stringObj;
Tcl_Obj *CONST *savedObjv = objv;
static CONST char *options[] = {
"-exact", "-glob", "-regexp", "--",
NULL
};
enum options {
OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST
};
mode = OPT_EXACT;
for (i = 1; i < objc; i++) {
string = Tcl_GetString(objv[i]);
if (string[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (index == OPT_LAST) {
i++;
break;
}
mode = index;
}
if (objc - i < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
"?switches? string pattern body ... ?default body?");
return TCL_ERROR;
}
stringObj = objv[i];
objc -= i + 1;
objv += i + 1;
/*
* If all of the pattern/command pairs are lumped into a single
* argument, split them out again.
*/
splitObjs = 0;
if (objc == 1) {
Tcl_Obj **listv;
if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Ensure that the list is non-empty.
*/
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, savedObjv,
"?switches? string {pattern body ... ?default body?}");
return TCL_ERROR;
}
objv = listv;
splitObjs = 1;
}
/*
* Complain if there is an odd number of words in the list of
* patterns and bodies.
*/
if (objc % 2) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "extra switch pattern with no body", NULL);
/*
* Check if this can be due to a badly placed comment
* in the switch block.
*
* The following is an heuristic to detect the infamous
* "comment in switch" error: just check if a pattern
* begins with '#'.
*/
if (splitObjs) {
for (i=0 ; i<objc ; i+=2) {
if (Tcl_GetString(objv[i])[0] == '#') {
Tcl_AppendResult(interp, ", this may be due to a ",
"comment incorrectly placed outside of a ",
"switch body - see the \"switch\" ",
"documentation", NULL);
break;
}
}
}
return TCL_ERROR;
}
/*
* Complain if the last body is a continuation. Note that this
* check assumes that the list is non-empty!
*/
if (strcmp(Tcl_GetString(objv[objc-1]), "-") == 0) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "no body specified for pattern \"",
Tcl_GetString(objv[objc-2]), "\"", NULL);
return TCL_ERROR;
}
for (i = 0; i < objc; i += 2) {
/*
* See if the pattern matches the string.
*/
pattern = Tcl_GetString(objv[i]);
matched = 0;
if ((i == objc - 2)
&& (*pattern == 'd')
&& (strcmp(pattern, "default") == 0)) {
matched = 1;
} else {
switch (mode) {
case OPT_EXACT:
matched = (strcmp(Tcl_GetString(stringObj), pattern) == 0);
break;
case OPT_GLOB:
matched = Tcl_StringMatch(Tcl_GetString(stringObj),
pattern);
break;
case OPT_REGEXP:
matched = Tcl_RegExpMatchObj(interp, stringObj, objv[i]);
if (matched < 0) {
return TCL_ERROR;
}
break;
}
}
if (matched == 0) {
continue;
}
/*
* We've got a match. Find a body to execute, skipping bodies
* that are "-".
*/
for (j = i + 1; ; j += 2) {
if (j >= objc) {
/*
* This shouldn't happen since we've checked that the
* last body is not a continuation...
*/
panic("fall-out when searching for body to match pattern");
}
if (strcmp(Tcl_GetString(objv[j]), "-") != 0) {
break;
}
}
result = Tcl_EvalObjEx(interp, objv[j], 0);
if (result == TCL_ERROR) {
char msg[100 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern,
interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
return result;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_TimeObjCmd --
*
* This object-based procedure is invoked to process the "time" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_TimeObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Tcl_Obj *objPtr;
register int i, result;
int count;
double totalMicroSec;
Tcl_Time start, stop;
char buf[100];
if (objc == 2) {
count = 1;
} else if (objc == 3) {
result = Tcl_GetIntFromObj(interp, objv[2], &count);
if (result != TCL_OK) {
return result;
}
} else {
Tcl_WrongNumArgs(interp, 1, objv, "command ?count?");
return TCL_ERROR;
}
objPtr = objv[1];
i = count;
Tcl_GetTime(&start);
while (i-- > 0) {
result = Tcl_EvalObjEx(interp, objPtr, 0);
if (result != TCL_OK) {
return result;
}
}
Tcl_GetTime(&stop);
totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6
+ ( stop.usec - start.usec ) );
sprintf(buf, "%.0f microseconds per iteration",
((count <= 0) ? 0 : totalMicroSec/count));
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_WhileObjCmd --
*
* This procedure is invoked to process the "while" Tcl command.
* See the user documentation for details on what it does.
*
* With the bytecode compiler, this procedure is only called when
* a command name is computed at runtime, and is "while" or the name
* to which "while" was renamed: e.g., "set z while; $z {$i<100} {}"
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_WhileObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result, value;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "test command");
return TCL_ERROR;
}
while (1) {
result = Tcl_ExprBooleanObj(interp, objv[1], &value);
if (result != TCL_OK) {
return result;
}
if (!value) {
break;
}
result = Tcl_EvalObjEx(interp, objv[2], 0);
if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
if (result == TCL_ERROR) {
char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"while\" body line %d)",
interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
}
break;
}
}
if (result == TCL_BREAK) {
result = TCL_OK;
}
if (result == TCL_OK) {
Tcl_ResetResult(interp);
}
return result;
}