#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"
typedef struct {
int flags;
size_t length;
char command[4];
} TraceVarInfo;
typedef struct {
int flags;
size_t length;
Tcl_Trace stepTrace;
int startLevel;
char *startCmd;
int curFlags;
int curCode;
char command[4];
} TraceCommandInfo;
#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
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;
static CONST char *traceTypeOptions[] = {
"execution", "command", "variable", (char*) NULL
};
static Tcl_TraceTypeObjCmd* traceSubCmds[] = {
TclTraceExecutionObjCmd,
TclTraceCommandObjCmd,
TclTraceVariableObjCmd,
};
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;
int
Tcl_PwdObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
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;
}
int
Tcl_RegexpObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
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)) {
Tcl_AppendResult(interp, "regexp match variables not allowed",
" when using -inline", (char *) NULL);
return TCL_ERROR;
}
if (about) {
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) {
return TCL_ERROR;
}
return TCL_OK;
}
objPtr = objv[1];
stringLength = Tcl_GetCharLength(objPtr);
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if (regExpr == NULL) {
return TCL_ERROR;
}
if (offset > 0) {
eflags |= TCL_REG_NOTBOL;
}
objc -= 2;
objv += 2;
resultPtr = Tcl_GetObjResult(interp);
if (doinline) {
numMatchesSaved = -1;
} else {
numMatchesSaved = (objc == 0) ? all : objc;
}
while (1) {
match = Tcl_RegExpExecObj(interp, regExpr, objPtr,
offset , numMatchesSaved, eflags);
if (match < 0) {
return TCL_ERROR;
}
if (match == 0) {
if (all <= 1) {
if (doinline) {
Tcl_SetListObj(resultPtr, 0, NULL);
} else {
Tcl_SetIntObj(resultPtr, 0);
}
return TCL_OK;
}
break;
}
Tcl_RegExpGetInfo(regExpr, &info);
if (doinline) {
objc = info.nsubs + 1;
}
for (i = 0; i < objc; i++) {
Tcl_Obj *newPtr;
if (indices) {
int start, end;
Tcl_Obj *objs[2];
if (i <= info.nsubs && info.matches[i].start >= 0) {
start = offset + info.matches[i].start;
end = offset + info.matches[i].end;
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;
}
if (info.matches[0].end == 0) {
offset++;
}
offset += info.matches[0].end;
all++;
eflags |= TCL_REG_NOTBOL;
if (offset >= stringLength) {
break;
}
}
if (!doinline) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_SetIntObj(resultPtr, (all ? all-1 : 1));
}
return TCL_OK;
}
int
Tcl_RegsubObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
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)) {
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) {
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;
}
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;
numMatches = 0;
for ( ; offset < wlen; ) {
match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset,
10 , ((offset > 0) ? TCL_REG_NOTBOL : 0));
if (match < 0) {
result = TCL_ERROR;
goto done;
}
if (match == 0) {
break;
}
if (numMatches == 0) {
resultPtr = Tcl_NewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
if (offset > 0) {
Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
}
}
numMatches++;
Tcl_RegExpGetInfo(regExpr, &info);
start = info.matches[0].start;
end = info.matches[0].end;
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start);
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) {
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
offset++;
} else {
offset += end;
}
if (!all) {
break;
}
}
regsubDone:
if (numMatches == 0) {
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 {
Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches);
}
} else {
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;
}
int
Tcl_RenameObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
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);
}
int
Tcl_ReturnObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
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) {
Tcl_SetObjResult(interp, objv[0]);
}
iPtr->returnCode = code;
return TCL_RETURN;
}
int
Tcl_SourceObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "fileName");
return TCL_ERROR;
}
return Tcl_FSEvalFile(interp, objv[1]);
}
int
Tcl_SplitObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
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) {
} else if (splitCharLen == 0) {
Tcl_HashTable charReuseTable;
Tcl_HashEntry *hPtr;
int isNew;
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; string < end; string += len) {
len = Tcl_UtfToUniChar(string, &ch);
hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew);
if (isNew) {
objPtr = Tcl_NewStringObj(string, len);
Tcl_SetHashValue(hPtr, (ClientData) objPtr);
} else {
objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr);
}
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
Tcl_DeleteHashTable(&charReuseTable);
} else {
char *element, *p, *splitEnd;
int splitLen;
Tcl_UniChar splitChar;
splitEnd = splitChars + splitCharLen;
for (element = string; string < end; string += len) {
len = Tcl_UtfToUniChar(string, &ch);
for (p = splitChars; p < splitEnd; p += splitLen) {
splitLen = Tcl_UtfToUniChar(p, &splitChar);
if (ch == splitChar) {
objPtr = Tcl_NewStringObj(element, string - element);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
element = string + len;
break;
}
}
}
objPtr = Tcl_NewStringObj(element, string - element);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
return TCL_OK;
}
int
Tcl_StringObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
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: {
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;
}
}
objv += objc-2;
if ((reqlength == 0) || (objv[0] == objv[1])) {
Tcl_SetBooleanObj(resultPtr,
((enum options) index == STR_EQUAL));
break;
} else if (!nocase && objv[0]->typePtr == &tclByteArrayType &&
objv[1]->typePtr == &tclByteArrayType) {
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)) {
string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1);
string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2);
strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
} else {
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;
} else {
length = (length1 < length2) ? length1 : length2;
if (reqlength > 0 && reqlength < length) {
length = reqlength;
} else if (reqlength < 0) {
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;
}
match = -1;
start = 0;
length2 = -1;
ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
if (objc == 5) {
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) {
start = 0;
}
}
if (length1 > 0) {
register Tcl_UniChar *p, *end;
end = ustring2 + length2 - length1 + 1;
for (p = ustring2; p < end; p++) {
if ((*p == *ustring1) &&
(TclUniCharNcmp(ustring1, p,
(unsigned long) length1) == 0)) {
match = p - ustring2;
break;
}
}
}
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 (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 {
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;
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;
}
}
}
objPtr = objv[objc-1];
string1 = Tcl_GetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
}
end = string1 + length1;
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++) {
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;
}
if (TclLooksLikeInt(string1, length1)) {
errno = 0;
#ifdef TCL_WIDE_INT_IS_LONG
strtoul(string1, &stop, 0);
#else
strtoull(string1, &stop, 0);
#endif
if (stop == end) {
if (errno == ERANGE) {
result = 0;
failat = -1;
}
break;
}
}
errno = 0;
strtod(string1, &stop);
if (errno == ERANGE) {
result = 0;
failat = -1;
} else if (stop == string1) {
result = 0;
failat = 0;
} else {
failat = stop - string1;
string1 = stop;
chcomp = Tcl_UniCharIsSpace;
}
break;
}
case STR_IS_GRAPH:
chcomp = Tcl_UniCharIsGraph;
break;
case STR_IS_INT: {
char *stop;
if ((objPtr->typePtr == &tclIntType) ||
(Tcl_GetInt(NULL, string1, &i) == TCL_OK)) {
break;
}
result = 0;
errno = 0;
#ifdef TCL_WIDE_INT_IS_LONG
strtoul(string1, &stop, 0);
#else
strtoull(string1, &stop, 0);
#endif
if (errno == ERANGE) {
failat = -1;
} else if (stop == string1) {
failat = 0;
} else {
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++) {
if ((*((unsigned char *)string1) >= 0xC0) ||
!isxdigit(*(unsigned char *)string1)) {
result = 0;
break;
}
}
break;
}
}
if (chcomp != NULL) {
for (; string1 < end; string1 += length2, failat++) {
length2 = Tcl_UtfToUniChar(string1, &ch);
if (!chcomp(ch)) {
result = 0;
break;
}
}
}
str_is_done:
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;
}
match = -1;
start = 0;
length2 = -1;
ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
if (objc == 5) {
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--) {
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 (objv[2]->typePtr == &tclByteArrayType) {
(void) Tcl_GetByteArrayFromObj(objv[2], &length1);
} else {
length1 = Tcl_GetCharLength(objv[2]);
}
}
Tcl_SetIntObj(resultPtr, length1);
break;
}
case STR_MAP: {
int mapElemc, nocase = 0;
Tcl_Obj **mapElemv;
Tcl_UniChar *ustring1, *ustring2, *p, *end;
int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*,
CONST Tcl_UniChar*, unsigned long));
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string");
return TCL_ERROR;
}
if (objc == 5) {
string2 = Tcl_GetStringFromObj(objv[2], &length2);
if ((length2 > 1) &&
strncmp(string2, "-nocase", (size_t) length2) == 0) {
nocase = 1;
} else {
Tcl_AppendStringsToObj(resultPtr, "bad option \"",
string2, "\": must be -nocase",
(char *) NULL);
return TCL_ERROR;
}
}
if (Tcl_ListObjGetElements(interp, objv[objc-2], &mapElemc,
&mapElemv) != TCL_OK) {
return TCL_ERROR;
}
if (mapElemc == 0) {
Tcl_SetObjResult(interp, objv[objc-1]);
return TCL_OK;
} else if (mapElemc & 1) {
Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1);
return TCL_ERROR;
}
objc--;
ustring1 = Tcl_GetUnicodeFromObj(objv[objc], &length1);
if (length1 == 0) {
break;
}
end = ustring1 + length1;
strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
Tcl_SetUnicodeObj(resultPtr, ustring1, 0);
if (mapElemc == 2) {
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;
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) {
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) {
Tcl_AppendUnicodeToObj(resultPtr, p,
ustring1 - p);
p = ustring1 + length2;
} else {
p += length2;
}
ustring1 = p - 1;
Tcl_AppendUnicodeToObj(resultPtr,
mapStrings[index+1], mapLens[index+1]);
break;
}
}
}
ckfree((char *) mapStrings);
ckfree((char *) mapLens);
if (nocase) {
ckfree((char *) u2lc);
}
}
if (p != ustring1) {
Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
}
break;
}
case STR_MATCH: {
int nocase = 0;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string");
return TCL_ERROR;
}
if (objc == 5) {
string2 = Tcl_GetStringFromObj(objv[2], &length2);
if ((length2 > 1) &&
strncmp(string2, "-nocase", (size_t) length2) == 0) {
nocase = 1;
} else {
Tcl_AppendStringsToObj(resultPtr, "bad option \"",
string2, "\": must be -nocase",
(char *) NULL);
return TCL_ERROR;
}
}
Tcl_SetBooleanObj(resultPtr,
Tcl_UniCharCaseMatch(Tcl_GetUnicode(objv[objc-1]),
Tcl_GetUnicode(objv[objc-2]), nocase));
break;
}
case STR_RANGE: {
int first, last;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "string first last");
return TCL_ERROR;
}
length1 = Tcl_GetCharLength(objv[2]) - 1;
if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
|| (TclGetIntForIndex(interp, objv[4], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if (first < 0) {
first = 0;
}
if (last >= length1) {
last = length1;
}
if (last >= first) {
Tcl_SetObjResult(interp, Tcl_GetRange(objv[2], first, last));
}
break;
}
case STR_REPEAT: {
int count;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string count");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) {
return TCL_ERROR;
}
if (count == 1) {
Tcl_SetObjResult(interp, objv[2]);
} else if (count > 1) {
string1 = Tcl_GetStringFromObj(objv[2], &length1);
if (length1 > 0) {
length2 = length1 * count;
string2 = (char *) ckalloc((size_t) length2+1);
for (index = 0; index < count; index++) {
memcpy(string2 + (length1 * index), string1,
(size_t) length1);
}
string2[length2] = '\0';
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) {
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;
for (p = string1; p < end; p += offset) {
offset = Tcl_UtfToUniChar(p, &ch);
for (check = string2; ; ) {
if (check >= checkEnd) {
p = end;
break;
}
check += Tcl_UtfToUniChar(check, &trim);
if (ch == trim) {
length1 -= offset;
string1 += offset;
break;
}
}
}
}
if (right) {
end = string1;
for (p = string1 + length1; p > end; ) {
p = Tcl_UtfPrev(p, string1);
offset = Tcl_UtfToUniChar(p, &ch);
for (check = string2; ; ) {
if (check >= checkEnd) {
p = end;
break;
}
check += Tcl_UtfToUniChar(check, &trim);
if (ch == trim) {
length1 -= offset;
break;
}
}
}
}
Tcl_SetStringObj(resultPtr, string1, length1);
break;
}
case STR_TRIMLEFT: {
left = 1;
right = 0;
goto dotrim;
}
case STR_TRIMRIGHT: {
left = 0;
right = 1;
goto dotrim;
}
case STR_WORDEND: {
int cur;
Tcl_UniChar ch;
CONST char *p, *end;
int numChars;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string index");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[2], &length1);
numChars = Tcl_NumUtfChars(string1, length1);
if (TclGetIntForIndex(interp, objv[3], numChars-1,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (index < 0) {
index = 0;
}
if (index < numChars) {
p = Tcl_UtfAtIndex(string1, index);
end = string1+length1;
for (cur = index; p < end; cur++) {
p += Tcl_UtfToUniChar(p, &ch);
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
}
if (cur == index) {
cur++;
}
} else {
cur = numChars;
}
Tcl_SetIntObj(resultPtr, cur);
break;
}
case STR_WORDSTART: {
int cur;
Tcl_UniChar ch;
CONST char *p;
int numChars;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string index");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[2], &length1);
numChars = Tcl_NumUtfChars(string1, length1);
if (TclGetIntForIndex(interp, objv[3], numChars-1,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (index >= numChars) {
index = numChars - 1;
}
cur = 0;
if (index > 0) {
p = Tcl_UtfAtIndex(string1, index);
for (cur = index; cur >= 0; cur--) {
Tcl_UtfToUniChar(p, &ch);
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
p = Tcl_UtfPrev(p, string1);
}
if (cur != index) {
cur += 1;
}
}
Tcl_SetIntObj(resultPtr, cur);
break;
}
}
return TCL_OK;
}
int
Tcl_SubstObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
static CONST char *substOptions[] = {
"-nobackslashes", "-nocommands", "-novariables", (char *) NULL
};
enum substOptions {
SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
};
Tcl_Obj *resultPtr;
int optionIndex, flags, i;
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;
}
resultPtr = Tcl_SubstObj(interp, objv[i], flags);
if (resultPtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
Tcl_Obj *
Tcl_SubstObj(interp, objPtr, flags)
Tcl_Interp *interp;
Tcl_Obj *objPtr;
int flags;
{
Tcl_Obj *resultObj;
char *p, *old;
old = p = Tcl_GetString(objPtr);
resultObj = Tcl_NewStringObj("", 0);
while (1) {
switch (*p) {
case 0:
if (p != old) {
Tcl_AppendToObj(resultObj, old, p-old);
}
return resultObj;
case '\\':
if (flags & TCL_SUBST_BACKSLASHES) {
char buf[TCL_UTF_MAX];
int count;
if (p != old) {
Tcl_AppendToObj(resultObj, old, p-old);
}
Tcl_AppendToObj(resultObj, buf,
Tcl_UtfBackslash(p, &count, buf));
p += count;
old = p;
} else {
p++;
}
break;
case '$':
if (flags & TCL_SUBST_VARIABLES) {
Tcl_Parse parse;
int code;
if (Tcl_ParseVarName(interp, p, -1, &parse, 0) != TCL_OK) {
goto errorResult;
}
if (parse.numTokens == 1) {
p++;
break;
}
if (p != old) {
Tcl_AppendToObj(resultObj, old, p-old);
}
p += parse.tokenPtr->size;
code = Tcl_EvalTokensStandard(interp, parse.tokenPtr,
parse.numTokens);
if (code == TCL_ERROR) {
goto errorResult;
}
if (code == TCL_BREAK) {
Tcl_ResetResult(interp);
return resultObj;
}
if (code != TCL_CONTINUE) {
Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
}
Tcl_ResetResult(interp);
old = p;
} else {
p++;
}
break;
case '[':
if (flags & TCL_SUBST_COMMANDS) {
Interp *iPtr = (Interp *) interp;
int code;
if (p != old) {
Tcl_AppendToObj(resultObj, old, p-old);
}
iPtr->evalFlags = TCL_BRACKET_TERM;
code = Tcl_EvalEx(interp, p+1, -1, 0);
switch (code) {
case TCL_ERROR:
goto errorResult;
case TCL_BREAK:
Tcl_ResetResult(interp);
return resultObj;
default:
Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
case TCL_CONTINUE:
Tcl_ResetResult(interp);
old = p = (p+1 + iPtr->termOffset + 1);
}
} else {
p++;
}
break;
default:
p++;
break;
}
}
errorResult:
Tcl_DecrRefCount(resultObj);
return NULL;
}
int
Tcl_SwitchObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
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;
splitObjs = 0;
if (objc == 1) {
Tcl_Obj **listv;
if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
return TCL_ERROR;
}
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, savedObjv,
"?switches? string {pattern body ... ?default body?}");
return TCL_ERROR;
}
objv = listv;
splitObjs = 1;
}
if (objc % 2) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "extra switch pattern with no body", NULL);
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;
}
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) {
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;
}
for (j = i + 1; ; j += 2) {
if (j >= objc) {
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;
}
int
Tcl_TimeObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
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;
}
int
Tcl_TraceObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
int optionIndex, commandLength;
char *name, *flagOps, *command, *p;
size_t length;
static CONST char *traceOptions[] = {
"add", "info", "remove",
#ifndef TCL_REMOVE_OBSOLETE_TRACES
"variable", "vdelete", "vinfo",
#endif
(char *) NULL
};
enum traceOptions {
TRACE_ADD, TRACE_INFO, TRACE_REMOVE,
#ifndef TCL_REMOVE_OBSOLETE_TRACES
TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
#endif
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions,
"option", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE:
case TRACE_INFO: {
int typeIndex;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions,
"option", 0, &typeIndex) != TCL_OK) {
return TCL_ERROR;
}
return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv);
break;
}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
case TRACE_OLD_VARIABLE: {
int flags;
TraceVarInfo *tvarPtr;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
return TCL_ERROR;
}
flags = 0;
flagOps = Tcl_GetString(objv[3]);
for (p = flagOps; *p != 0; p++) {
if (*p == 'r') {
flags |= TCL_TRACE_READS;
} else if (*p == 'w') {
flags |= TCL_TRACE_WRITES;
} else if (*p == 'u') {
flags |= TCL_TRACE_UNSETS;
} else if (*p == 'a') {
flags |= TCL_TRACE_ARRAY;
} else {
goto badVarOps;
}
}
if (flags == 0) {
goto badVarOps;
}
flags |= TCL_TRACE_OLD_STYLE;
command = Tcl_GetStringFromObj(objv[4], &commandLength);
length = (size_t) commandLength;
tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
(sizeof(TraceVarInfo) - sizeof(tvarPtr->command)
+ length + 1));
tvarPtr->flags = flags;
tvarPtr->length = length;
flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
strcpy(tvarPtr->command, command);
name = Tcl_GetString(objv[2]);
if (Tcl_TraceVar(interp, name, flags, TraceVarProc,
(ClientData) tvarPtr) != TCL_OK) {
ckfree((char *) tvarPtr);
return TCL_ERROR;
}
break;
}
case TRACE_OLD_VDELETE: {
int flags;
TraceVarInfo *tvarPtr;
ClientData clientData;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
return TCL_ERROR;
}
flags = 0;
flagOps = Tcl_GetString(objv[3]);
for (p = flagOps; *p != 0; p++) {
if (*p == 'r') {
flags |= TCL_TRACE_READS;
} else if (*p == 'w') {
flags |= TCL_TRACE_WRITES;
} else if (*p == 'u') {
flags |= TCL_TRACE_UNSETS;
} else if (*p == 'a') {
flags |= TCL_TRACE_ARRAY;
} else {
goto badVarOps;
}
}
if (flags == 0) {
goto badVarOps;
}
flags |= TCL_TRACE_OLD_STYLE;
command = Tcl_GetStringFromObj(objv[4], &commandLength);
length = (size_t) commandLength;
clientData = 0;
name = Tcl_GetString(objv[2]);
while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
TraceVarProc, clientData)) != 0) {
tvarPtr = (TraceVarInfo *) clientData;
if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
&& (strncmp(command, tvarPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceVar2(interp, name, NULL,
flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
TraceVarProc, clientData);
Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC);
break;
}
}
break;
}
case TRACE_OLD_VINFO: {
ClientData clientData;
char ops[5];
Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
resultListPtr = Tcl_GetObjResult(interp);
clientData = 0;
name = Tcl_GetString(objv[2]);
while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
TraceVarProc, clientData)) != 0) {
TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
p = ops;
if (tvarPtr->flags & TCL_TRACE_READS) {
*p = 'r';
p++;
}
if (tvarPtr->flags & TCL_TRACE_WRITES) {
*p = 'w';
p++;
}
if (tvarPtr->flags & TCL_TRACE_UNSETS) {
*p = 'u';
p++;
}
if (tvarPtr->flags & TCL_TRACE_ARRAY) {
*p = 'a';
p++;
}
*p = '\0';
elemObjPtr = Tcl_NewStringObj(ops, -1);
Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
break;
}
#endif
}
return TCL_OK;
badVarOps:
Tcl_AppendResult(interp, "bad operations \"", flagOps,
"\": should be one or more of rwua", (char *) NULL);
return TCL_ERROR;
}
int
TclTraceExecutionObjCmd(interp, optionIndex, objc, objv)
Tcl_Interp *interp;
int optionIndex;
int objc;
Tcl_Obj *CONST objv[];
{
int commandLength, index;
char *name, *command;
size_t length;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static CONST char *opStrings[] = { "enter", "leave",
"enterstep", "leavestep", (char *) NULL };
enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE,
TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP };
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0;
int i, listLen, result;
Tcl_Obj **elemPtrs;
if (objc != 6) {
Tcl_WrongNumArgs(interp, 3, objv, "name opList execution");
return TCL_ERROR;
}
result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
&elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetResult(interp, "bad operation list \"\": must be "
"one or more of enter, leave, enterstep, or leavestep", TCL_STATIC);
return TCL_ERROR;
}
for (i = 0; i < listLen; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum operations) index) {
case TRACE_EXEC_ENTER:
flags |= TCL_TRACE_ENTER_EXEC;
break;
case TRACE_EXEC_LEAVE:
flags |= TCL_TRACE_LEAVE_EXEC;
break;
case TRACE_EXEC_ENTER_STEP:
flags |= TCL_TRACE_ENTER_DURING_EXEC;
break;
case TRACE_EXEC_LEAVE_STEP:
flags |= TCL_TRACE_LEAVE_DURING_EXEC;
break;
}
}
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr;
tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
(sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
+ length + 1));
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
tcmdPtr->startCmd = NULL;
tcmdPtr->length = length;
flags |= TCL_TRACE_DELETE;
if (flags & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) {
flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
}
strcpy(tcmdPtr->command, command);
name = Tcl_GetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
(ClientData) tcmdPtr) != TCL_OK) {
ckfree((char *) tcmdPtr);
return TCL_ERROR;
}
} else {
TraceCommandInfo *tcmdPtr;
ClientData clientData;
clientData = 0;
name = Tcl_GetString(objv[3]);
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != 0) {
tcmdPtr = (TraceCommandInfo *) clientData;
if ((tcmdPtr->length == length)
&& ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | TCL_TRACE_RENAME |
TCL_TRACE_DELETE)) == flags)
&& (strncmp(command, tcmdPtr->command,
(size_t) length) == 0)) {
flags |= TCL_TRACE_DELETE;
if (flags & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) {
flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
}
Tcl_UntraceCommand(interp, name,
flags, TraceCommandProc, clientData);
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
tcmdPtr->flags = 0;
} else {
Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC);
}
break;
}
}
}
break;
}
case TRACE_INFO: {
ClientData clientData;
Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
resultListPtr = Tcl_GetObjResult(interp);
clientData = 0;
name = Tcl_GetString(objv[3]);
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != 0) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("enter",6));
}
if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("leave",5));
}
if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("enterstep",9));
}
if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("leavestep",10));
}
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_ListObjAppendElement(interp, resultListPtr,
eachTraceObjPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
break;
}
}
return TCL_OK;
}
int
TclTraceCommandObjCmd(interp, optionIndex, objc, objv)
Tcl_Interp *interp;
int optionIndex;
int objc;
Tcl_Obj *CONST objv[];
{
int commandLength, index;
char *name, *command;
size_t length;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static CONST char *opStrings[] = { "delete", "rename", (char *) NULL };
enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME };
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0;
int i, listLen, result;
Tcl_Obj **elemPtrs;
if (objc != 6) {
Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
return TCL_ERROR;
}
result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
&elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetResult(interp, "bad operation list \"\": must be "
"one or more of delete or rename", TCL_STATIC);
return TCL_ERROR;
}
for (i = 0; i < listLen; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum operations) index) {
case TRACE_CMD_RENAME:
flags |= TCL_TRACE_RENAME;
break;
case TRACE_CMD_DELETE:
flags |= TCL_TRACE_DELETE;
break;
}
}
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr;
tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
(sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
+ length + 1));
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
tcmdPtr->startCmd = NULL;
tcmdPtr->length = length;
flags |= TCL_TRACE_DELETE;
strcpy(tcmdPtr->command, command);
name = Tcl_GetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
(ClientData) tcmdPtr) != TCL_OK) {
ckfree((char *) tcmdPtr);
return TCL_ERROR;
}
} else {
TraceCommandInfo *tcmdPtr;
ClientData clientData;
clientData = 0;
name = Tcl_GetString(objv[3]);
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != 0) {
tcmdPtr = (TraceCommandInfo *) clientData;
if ((tcmdPtr->length == length)
&& (tcmdPtr->flags == flags)
&& (strncmp(command, tcmdPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceCommand(interp, name,
flags | TCL_TRACE_DELETE,
TraceCommandProc, clientData);
ckfree((char *) tcmdPtr);
break;
}
}
}
break;
}
case TRACE_INFO: {
ClientData clientData;
Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
resultListPtr = Tcl_GetObjResult(interp);
clientData = 0;
name = Tcl_GetString(objv[3]);
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != 0) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
if (tcmdPtr->flags & TCL_TRACE_RENAME) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("rename",6));
}
if (tcmdPtr->flags & TCL_TRACE_DELETE) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("delete",6));
}
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_ListObjAppendElement(interp, resultListPtr,
eachTraceObjPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
break;
}
}
return TCL_OK;
}
int
TclTraceVariableObjCmd(interp, optionIndex, objc, objv)
Tcl_Interp *interp;
int optionIndex;
int objc;
Tcl_Obj *CONST objv[];
{
int commandLength, index;
char *name, *command;
size_t length;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static CONST char *opStrings[] = { "array", "read", "unset", "write",
(char *) NULL };
enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET,
TRACE_VAR_WRITE };
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0;
int i, listLen, result;
Tcl_Obj **elemPtrs;
if (objc != 6) {
Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
return TCL_ERROR;
}
result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
&elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetResult(interp, "bad operation list \"\": must be "
"one or more of array, read, unset, or write",
TCL_STATIC);
return TCL_ERROR;
}
for (i = 0; i < listLen ; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum operations) index) {
case TRACE_VAR_ARRAY:
flags |= TCL_TRACE_ARRAY;
break;
case TRACE_VAR_READ:
flags |= TCL_TRACE_READS;
break;
case TRACE_VAR_UNSET:
flags |= TCL_TRACE_UNSETS;
break;
case TRACE_VAR_WRITE:
flags |= TCL_TRACE_WRITES;
break;
}
}
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceVarInfo *tvarPtr;
tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
(sizeof(TraceVarInfo) - sizeof(tvarPtr->command)
+ length + 1));
tvarPtr->flags = flags;
tvarPtr->length = length;
flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
strcpy(tvarPtr->command, command);
name = Tcl_GetString(objv[3]);
if (Tcl_TraceVar(interp, name, flags, TraceVarProc,
(ClientData) tvarPtr) != TCL_OK) {
ckfree((char *) tvarPtr);
return TCL_ERROR;
}
} else {
TraceVarInfo *tvarPtr;
ClientData clientData = 0;
name = Tcl_GetString(objv[3]);
while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
TraceVarProc, clientData)) != 0) {
tvarPtr = (TraceVarInfo *) clientData;
if ((tvarPtr->length == length)
&& (tvarPtr->flags == flags)
&& (strncmp(command, tvarPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceVar2(interp, name, NULL,
flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
TraceVarProc, clientData);
Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC);
break;
}
}
}
break;
}
case TRACE_INFO: {
ClientData clientData;
Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
resultListPtr = Tcl_GetObjResult(interp);
clientData = 0;
name = Tcl_GetString(objv[3]);
while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
TraceVarProc, clientData)) != 0) {
TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
if (tvarPtr->flags & TCL_TRACE_ARRAY) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("array", 5));
}
if (tvarPtr->flags & TCL_TRACE_READS) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("read", 4));
}
if (tvarPtr->flags & TCL_TRACE_WRITES) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("write", 5));
}
if (tvarPtr->flags & TCL_TRACE_UNSETS) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("unset", 5));
}
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_ListObjAppendElement(interp, resultListPtr,
eachTraceObjPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
break;
}
}
return TCL_OK;
}
ClientData
Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData)
Tcl_Interp *interp;
CONST char *cmdName;
int flags;
Tcl_CommandTraceProc *proc;
ClientData prevClientData;
{
Command *cmdPtr;
register CommandTrace *tracePtr;
cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
NULL, TCL_LEAVE_ERR_MSG);
if (cmdPtr == NULL) {
return NULL;
}
tracePtr = cmdPtr->tracePtr;
if (prevClientData != NULL) {
for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
if ((tracePtr->clientData == prevClientData)
&& (tracePtr->traceProc == proc)) {
tracePtr = tracePtr->nextPtr;
break;
}
}
}
for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
if (tracePtr->traceProc == proc) {
return tracePtr->clientData;
}
}
return NULL;
}
int
Tcl_TraceCommand(interp, cmdName, flags, proc, clientData)
Tcl_Interp *interp;
CONST char *cmdName;
int flags;
Tcl_CommandTraceProc *proc;
ClientData clientData;
{
Command *cmdPtr;
register CommandTrace *tracePtr;
cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
NULL, TCL_LEAVE_ERR_MSG);
if (cmdPtr == NULL) {
return TCL_ERROR;
}
tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE
| TCL_TRACE_ANY_EXEC);
tracePtr->nextPtr = cmdPtr->tracePtr;
cmdPtr->tracePtr = tracePtr;
if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
}
return TCL_OK;
}
void
Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData)
Tcl_Interp *interp;
CONST char *cmdName;
int flags;
Tcl_CommandTraceProc *proc;
ClientData clientData;
{
register CommandTrace *tracePtr;
CommandTrace *prevPtr;
Command *cmdPtr;
Interp *iPtr = (Interp *) interp;
ActiveCommandTrace *activePtr;
int hasExecTraces = 0;
cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
NULL, TCL_LEAVE_ERR_MSG);
if (cmdPtr == NULL) {
return;
}
flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC);
for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr == NULL) {
return;
}
if ((tracePtr->traceProc == proc) && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC)) == flags)
&& (tracePtr->clientData == clientData)) {
if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
hasExecTraces = 1;
}
break;
}
}
for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->nextTracePtr == tracePtr) {
activePtr->nextTracePtr = tracePtr->nextPtr;
}
}
if (prevPtr == NULL) {
cmdPtr->tracePtr = tracePtr->nextPtr;
} else {
prevPtr->nextPtr = tracePtr->nextPtr;
}
tracePtr->flags = 0;
Tcl_EventuallyFree((int*)tracePtr, TCL_DYNAMIC);
if (hasExecTraces) {
for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
return;
}
}
cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;
}
}
static void
TraceCommandProc(clientData, interp, oldName, newName, flags)
ClientData clientData;
Tcl_Interp *interp;
CONST char *oldName;
CONST char *newName;
int flags;
{
Tcl_SavedResult state;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
int code;
Tcl_DString cmd;
Tcl_Preserve((ClientData) tcmdPtr);
if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length);
Tcl_DStringAppendElement(&cmd, oldName);
Tcl_DStringAppendElement(&cmd, (newName ? newName : ""));
if (flags & TCL_TRACE_RENAME) {
Tcl_DStringAppend(&cmd, " rename", 7);
} else if (flags & TCL_TRACE_DELETE) {
Tcl_DStringAppend(&cmd, " delete", 7);
}
Tcl_SaveResult(interp, &state);
if (flags & TCL_TRACE_DESTROYED) {
tcmdPtr->flags |= TCL_TRACE_DESTROYED;
}
code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
Tcl_DStringLength(&cmd), 0);
if (code != TCL_OK) {
}
Tcl_RestoreResult(interp, &state);
Tcl_DStringFree(&cmd);
}
if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) {
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
tcmdPtr->flags = 0;
} else {
Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC);
}
}
Tcl_Release((ClientData) tcmdPtr);
return;
}
int
TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, objv)
Tcl_Interp *interp;
CONST char *command;
int numChars;
Command *cmdPtr;
int code;
int traceFlags;
int objc;
Tcl_Obj *CONST objv[];
{
Interp *iPtr = (Interp *) interp;
CommandTrace *tracePtr, *lastTracePtr;
ActiveCommandTrace active;
int curLevel;
int traceCode = TCL_OK;
TraceCommandInfo* tcmdPtr;
if (command == NULL || cmdPtr->tracePtr == NULL) {
return(traceCode);
}
curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level);
active.nextPtr = iPtr->activeCmdTracePtr;
iPtr->activeCmdTracePtr = &active;
active.cmdPtr = cmdPtr;
lastTracePtr = NULL;
for ( tracePtr = cmdPtr->tracePtr;
(traceCode == TCL_OK) && (tracePtr != NULL);
tracePtr = active.nextTracePtr) {
if (traceFlags & TCL_TRACE_LEAVE_EXEC) {
active.nextTracePtr = NULL;
tracePtr = cmdPtr->tracePtr;
while (tracePtr->nextPtr != lastTracePtr) {
active.nextTracePtr = tracePtr;
tracePtr = tracePtr->nextPtr;
}
} else {
active.nextTracePtr = tracePtr->nextPtr;
}
tcmdPtr = (TraceCommandInfo*)tracePtr->clientData;
if (tcmdPtr->flags != 0) {
tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT;
tcmdPtr->curCode = code;
traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp,
curLevel, command, (Tcl_Command)cmdPtr, objc, objv);
}
lastTracePtr = tracePtr;
}
iPtr->activeCmdTracePtr = active.nextPtr;
return(traceCode);
}
int
TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, objv)
Tcl_Interp *interp;
CONST char *command;
int numChars;
Command *cmdPtr;
int code;
int traceFlags;
int objc;
Tcl_Obj *CONST objv[];
{
Interp *iPtr = (Interp *) interp;
Trace *tracePtr, *lastTracePtr;
ActiveInterpTrace active;
int curLevel;
int traceCode = TCL_OK;
TraceCommandInfo* tcmdPtr;
if (command == NULL || iPtr->tracePtr == NULL ||
(iPtr->flags & INTERP_TRACE_IN_PROGRESS)) {
return(traceCode);
}
curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level);
active.nextPtr = iPtr->activeInterpTracePtr;
iPtr->activeInterpTracePtr = &active;
lastTracePtr = NULL;
for ( tracePtr = iPtr->tracePtr;
(traceCode == TCL_OK) && (tracePtr != NULL);
tracePtr = active.nextTracePtr) {
if (traceFlags & TCL_TRACE_ENTER_EXEC) {
active.nextTracePtr = NULL;
tracePtr = iPtr->tracePtr;
while (tracePtr->nextPtr != lastTracePtr) {
active.nextTracePtr = tracePtr;
tracePtr = tracePtr->nextPtr;
}
} else {
active.nextTracePtr = tracePtr->nextPtr;
}
if (tracePtr->level > 0 && curLevel > tracePtr->level) {
continue;
}
if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) {
Tcl_Preserve((ClientData) tracePtr);
tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
if ((tracePtr->flags != TCL_TRACE_EXEC_IN_PROGRESS) &&
((tracePtr->flags & traceFlags) != 0)) {
tcmdPtr = (TraceCommandInfo*)tracePtr->clientData;
tcmdPtr->curFlags = traceFlags;
tcmdPtr->curCode = code;
traceCode = (tracePtr->proc)((ClientData)tcmdPtr,
(Tcl_Interp*)interp,
curLevel, command,
(Tcl_Command)cmdPtr,
objc, objv);
} else {
if (traceFlags & TCL_TRACE_ENTER_EXEC) {
traceCode = CallTraceProcedure(interp, tracePtr, cmdPtr,
command, numChars, objc, objv);
}
}
tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
Tcl_Release((ClientData) tracePtr);
}
lastTracePtr = tracePtr;
}
iPtr->activeInterpTracePtr = active.nextPtr;
return(traceCode);
}
static int
CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
Tcl_Interp *interp;
register Trace *tracePtr;
Command *cmdPtr;
CONST char *command;
int numChars;
register int objc;
Tcl_Obj *CONST objv[];
{
Interp *iPtr = (Interp *) interp;
char *commandCopy;
int traceCode;
commandCopy = (char *) ckalloc((unsigned) (numChars + 1));
memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars);
commandCopy[numChars] = '\0';
traceCode = (tracePtr->proc)( tracePtr->clientData, (Tcl_Interp*) iPtr,
iPtr->numLevels, commandCopy,
(Tcl_Command) cmdPtr, objc, objv );
ckfree((char *) commandCopy);
return(traceCode);
}
int
TraceExecutionProc(ClientData clientData, Tcl_Interp *interp,
int level, CONST char* command, Tcl_Command cmdInfo,
int objc, struct Tcl_Obj *CONST objv[]) {
int call = 0;
Interp *iPtr = (Interp *) interp;
TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData;
int flags = tcmdPtr->curFlags;
int code = tcmdPtr->curCode;
int traceCode = TCL_OK;
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
return(traceCode);
}
if (!(flags & TCL_INTERP_DESTROYED)) {
if (flags & TCL_TRACE_EXEC_DIRECT) {
call = flags & tcmdPtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
} else {
call = 1;
}
if (flags & TCL_TRACE_LEAVE_EXEC) {
if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel)
&& (strcmp(command, tcmdPtr->startCmd) == 0)) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
}
if (call) {
Tcl_SavedResult state;
Tcl_DString cmd;
Tcl_DString sub;
int i;
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length);
Tcl_DStringInit(&sub);
for (i = 0; i < objc; i++) {
char* str;
int len;
str = Tcl_GetStringFromObj(objv[i],&len);
Tcl_DStringAppendElement(&sub, str);
}
Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub));
Tcl_DStringFree(&sub);
if (flags & TCL_TRACE_ENTER_EXEC) {
if (flags & TCL_TRACE_EXEC_DIRECT) {
Tcl_DStringAppendElement(&cmd, "enter");
} else {
Tcl_DStringAppendElement(&cmd, "enterstep");
}
} else if (flags & TCL_TRACE_LEAVE_EXEC) {
Tcl_Obj* resultCode;
char* resultCodeStr;
resultCode = Tcl_NewIntObj(code);
resultCodeStr = Tcl_GetString(resultCode);
Tcl_DStringAppendElement(&cmd, resultCodeStr);
Tcl_DecrRefCount(resultCode);
Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp));
if (flags & TCL_TRACE_EXEC_DIRECT) {
Tcl_DStringAppendElement(&cmd, "leave");
} else {
Tcl_DStringAppendElement(&cmd, "leavestep");
}
} else {
panic("TraceExecutionProc: bad flag combination");
}
Tcl_SaveResult(interp, &state);
tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
iPtr->flags |= INTERP_TRACE_IN_PROGRESS;
Tcl_Preserve((ClientData)tcmdPtr);
traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
iPtr->flags &= ~INTERP_TRACE_IN_PROGRESS;
if (tcmdPtr->flags == 0) {
flags |= TCL_TRACE_DESTROYED;
}
if (traceCode == TCL_OK) {
Tcl_RestoreResult(interp, &state);
}
Tcl_DStringFree(&cmd);
}
if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL)
&& (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC))) {
tcmdPtr->startLevel = level;
tcmdPtr->startCmd =
(char *) ckalloc((unsigned) (strlen(command) + 1));
strcpy(tcmdPtr->startCmd, command);
tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0,
(tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2,
TraceExecutionProc, (ClientData)tcmdPtr, NULL);
}
}
if (flags & TCL_TRACE_DESTROYED) {
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
Tcl_EventuallyFree((ClientData)tcmdPtr, TCL_DYNAMIC);
}
if (call) {
Tcl_Release((ClientData)tcmdPtr);
}
return(traceCode);
}
static char *
TraceVarProc(clientData, interp, name1, name2, flags)
ClientData clientData;
Tcl_Interp *interp;
CONST char *name1;
CONST char *name2;
int flags;
{
Tcl_SavedResult state;
TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
char *result;
int code;
Tcl_DString cmd;
Tcl_Preserve((ClientData) tvarPtr);
result = NULL;
if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
if (tvarPtr->length != (size_t) 0) {
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);
Tcl_DStringAppendElement(&cmd, name1);
Tcl_DStringAppendElement(&cmd, (name2 ? name2 : ""));
#ifndef TCL_REMOVE_OBSOLETE_TRACES
if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) {
if (flags & TCL_TRACE_ARRAY) {
Tcl_DStringAppend(&cmd, " a", 2);
} else if (flags & TCL_TRACE_READS) {
Tcl_DStringAppend(&cmd, " r", 2);
} else if (flags & TCL_TRACE_WRITES) {
Tcl_DStringAppend(&cmd, " w", 2);
} else if (flags & TCL_TRACE_UNSETS) {
Tcl_DStringAppend(&cmd, " u", 2);
}
} else {
#endif
if (flags & TCL_TRACE_ARRAY) {
Tcl_DStringAppend(&cmd, " array", 6);
} else if (flags & TCL_TRACE_READS) {
Tcl_DStringAppend(&cmd, " read", 5);
} else if (flags & TCL_TRACE_WRITES) {
Tcl_DStringAppend(&cmd, " write", 6);
} else if (flags & TCL_TRACE_UNSETS) {
Tcl_DStringAppend(&cmd, " unset", 6);
}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
}
#endif
Tcl_SaveResult(interp, &state);
if (flags & TCL_TRACE_DESTROYED) {
tvarPtr->flags |= TCL_TRACE_DESTROYED;
}
code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
Tcl_DStringLength(&cmd), 0);
if (code != TCL_OK) {
register Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errMsgObj);
result = (char *) errMsgObj;
}
Tcl_RestoreResult(interp, &state);
Tcl_DStringFree(&cmd);
}
}
if (flags & TCL_TRACE_DESTROYED) {
if (result != NULL) {
register Tcl_Obj *errMsgObj = (Tcl_Obj *) result;
Tcl_DecrRefCount(errMsgObj);
result = NULL;
}
Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC);
}
Tcl_Release((ClientData) tvarPtr);
return result;
}
int
Tcl_WhileObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
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;
}