summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdMZ.c
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-16 00:46:29 (GMT)
committerstanton <stanton>1999-04-16 00:46:29 (GMT)
commit97464e6cba8eb0008cf2727c15718671992b913f (patch)
treece9959f2747257d98d52ec8d18bf3b0de99b9535 /generic/tclCmdMZ.c
parenta8c96ddb94d1483a9de5e340b740cb74ef6cafa7 (diff)
downloadtcl-97464e6cba8eb0008cf2727c15718671992b913f.zip
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.gz
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.bz2
merged tcl 8.1 branch back into the main trunk
Diffstat (limited to 'generic/tclCmdMZ.c')
-rw-r--r--generic/tclCmdMZ.c1715
1 files changed, 732 insertions, 983 deletions
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 53583a8..38a3f8d 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -8,16 +8,34 @@
*
* Copyright (c) 1987-1993 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics 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.2 1998/09/14 18:39:57 stanton Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.3 1999/04/16 00:46:43 stanton Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
#include "tclCompile.h"
+#include "tclRegexp.h"
+
+/*
+ * Flag values used by Tcl_ScanObjCmd.
+ */
+
+#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */
+#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */
+#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */
+#define SCAN_WIDTH 0x8 /* A width value was supplied. */
+
+#define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */
+#define SCAN_NODIGITS 0x20 /* No digits have been scanned. */
+#define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */
+#define SCAN_XOK 0x80 /* An 'x' is allowed. */
+#define SCAN_PTOK 0x100 /* Decimal point is allowed. */
+#define SCAN_EXPOK 0x200 /* An exponent is allowed. */
/*
* Structure used to hold information about variable traces:
@@ -28,7 +46,7 @@ typedef struct {
* to be invoked. */
char *errMsg; /* Error message returned from Tcl command,
* or NULL. Malloc'ed. */
- int length; /* Number of non-NULL chars. in command. */
+ size_t length; /* Number of non-NULL chars. in command. */
char command[4]; /* Space for Tcl command to invoke. Actual
* size will be as large as necessary to
* hold command. This field must be the
@@ -47,7 +65,7 @@ static char * TraceVarProc _ANSI_ARGS_((ClientData clientData,
/*
*----------------------------------------------------------------------
*
- * Tcl_PwdCmd --
+ * Tcl_PwdObjCmd --
*
* This procedure is invoked to process the "pwd" Tcl command.
* See the user documentation for details on what it does.
@@ -63,35 +81,35 @@ static char * TraceVarProc _ANSI_ARGS_((ClientData clientData,
/* ARGSUSED */
int
-Tcl_PwdCmd(dummy, interp, argc, argv)
+Tcl_PwdObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *dirName;
+ Tcl_DString ds;
- if (argc != 1) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], "\"", (char *) NULL);
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
- dirName = TclGetCwd(interp);
- if (dirName == NULL) {
+ if (Tcl_GetCwd(interp, &ds) == NULL) {
return TCL_ERROR;
}
- Tcl_SetResult(interp, dirName, TCL_VOLATILE);
+ Tcl_DStringResult(interp, &ds);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_RegexpCmd --
+ * Tcl_RegexpObjCmd --
*
* This procedure is invoked to process the "regexp" Tcl command.
- * See the user documentation for details on what it does.
+ * See the user documentation for details on what it does. The
+ * REGEXP_TEST stuff is to minimize code differences between this
+ * and the "testregexp" command.
*
* Results:
* A standard Tcl result.
@@ -104,96 +122,124 @@ Tcl_PwdCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_RegexpCmd(dummy, interp, argc, argv)
+Tcl_RegexpObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int noCase = 0;
- int indices = 0;
+ int i, result, indices, stringLength, wLen, match, about;
+ int cflags, eflags;
Tcl_RegExp regExpr;
- char **argPtr, *string, *pattern, *start, *end;
- int match = 0; /* Initialization needed only to
- * prevent compiler warning. */
- int i;
- Tcl_DString stringDString, patternDString;
-
- if (argc < 3) {
- wrongNumArgs:
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ?switches? exp string ?matchVar? ?subMatchVar ",
- "subMatchVar ...?\"", (char *) NULL);
- return TCL_ERROR;
- }
- argPtr = argv+1;
- argc--;
- while ((argc > 0) && (argPtr[0][0] == '-')) {
- if (strcmp(argPtr[0], "-indices") == 0) {
- indices = 1;
- } else if (strcmp(argPtr[0], "-nocase") == 0) {
- noCase = 1;
- } else if (strcmp(argPtr[0], "--") == 0) {
- argPtr++;
- argc--;
+ char *string;
+ Tcl_DString stringBuffer, valueBuffer;
+ Tcl_UniChar *wStart;
+ static char *options[] = {
+ "-indices", "-nocase", "-about", "-expanded",
+ "-line", "-linestop", "-lineanchor",
+ "--", (char *) NULL
+ };
+ enum options {
+ REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED,
+ REGEXP_LINE, REGEXP_LINESTOP, REGEXP_LINEANCHOR,
+ REGEXP_LAST
+ };
+
+ indices = 0;
+ about = 0;
+ cflags = REG_ADVANCED;
+ eflags = 0;
+
+ for (i = 1; i < objc; i++) {
+ char *name;
+ int index;
+
+ name = Tcl_GetString(objv[i]);
+ if (name[0] != '-') {
break;
- } else {
- Tcl_AppendResult(interp, "bad switch \"", argPtr[0],
- "\": must be -indices, -nocase, or --", (char *) NULL);
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
+ &index) != TCL_OK) {
return TCL_ERROR;
}
- argPtr++;
- argc--;
- }
- if (argc < 2) {
- goto wrongNumArgs;
- }
-
- /*
- * Convert the string and pattern to lower case, if desired, and
- * perform the matching operation.
- */
-
- if (noCase) {
- register char *p;
-
- Tcl_DStringInit(&patternDString);
- Tcl_DStringAppend(&patternDString, argPtr[0], -1);
- pattern = Tcl_DStringValue(&patternDString);
- for (p = pattern; *p != 0; p++) {
- if (isupper(UCHAR(*p))) {
- *p = (char)tolower(UCHAR(*p));
+ switch ((enum options) index) {
+ case REGEXP_INDICES: {
+ indices = 1;
+ break;
}
- }
- Tcl_DStringInit(&stringDString);
- Tcl_DStringAppend(&stringDString, argPtr[1], -1);
- string = Tcl_DStringValue(&stringDString);
- for (p = string; *p != 0; p++) {
- if (isupper(UCHAR(*p))) {
- *p = (char)tolower(UCHAR(*p));
+ case REGEXP_NOCASE: {
+ cflags |= REG_ICASE;
+ break;
+ }
+ case REGEXP_ABOUT: {
+ about = 1;
+ break;
+ }
+ case REGEXP_EXPANDED: {
+ cflags |= REG_EXPANDED;
+ break;
+ }
+ case REGEXP_LINE: {
+ cflags |= REG_NEWLINE;
+ break;
+ }
+ case REGEXP_LINESTOP: {
+ cflags |= REG_NLSTOP;
+ break;
+ }
+ case REGEXP_LINEANCHOR: {
+ cflags |= REG_NLANCH;
+ break;
+ }
+ case REGEXP_LAST: {
+ i++;
+ goto endOfForLoop;
}
}
- } else {
- pattern = argPtr[0];
- string = argPtr[1];
- }
- regExpr = Tcl_RegExpCompile(interp, pattern);
- if (regExpr != NULL) {
- match = Tcl_RegExpExec(interp, regExpr, string, string);
}
- if (noCase) {
- Tcl_DStringFree(&stringDString);
- Tcl_DStringFree(&patternDString);
+
+ endOfForLoop:
+ if (objc - i < 2 - about) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
+ return TCL_ERROR;
}
+ objc -= i;
+ objv += i;
+
+ regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if (regExpr == NULL) {
return TCL_ERROR;
}
+
+ if (about) {
+ if (TclRegAbout(interp, regExpr) < 0) {
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ }
+
+ result = TCL_OK;
+ string = Tcl_GetStringFromObj(objv[1], &stringLength);
+
+ Tcl_DStringInit(&valueBuffer);
+
+ Tcl_DStringInit(&stringBuffer);
+ wStart = Tcl_UtfToUniCharDString(string, stringLength, &stringBuffer);
+ wLen = Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar);
+
+ match = TclRegExpExecUniChar(interp, regExpr, wStart, wLen, objc-2, eflags);
if (match < 0) {
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
- if (!match) {
- Tcl_SetResult(interp, "0", TCL_STATIC);
- return TCL_OK;
+ if (match == 0) {
+ /*
+ * Set the interpreter's object result to an integer object w/ value 0.
+ */
+
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
+ goto done;
}
/*
@@ -201,51 +247,59 @@ Tcl_RegexpCmd(dummy, interp, argc, argv)
* index information in those variables.
*/
- argc -= 2;
- for (i = 0; i < argc; i++) {
- char *result, info[50];
+ objc -= 2;
+ objv += 2;
+
+ for (i = 0; i < objc; i++) {
+ char *varName, *value;
+ int start, end;
+
+ varName = Tcl_GetString(objv[i]);
- Tcl_RegExpRange(regExpr, i, &start, &end);
- if (start == NULL) {
+ TclRegExpRangeUniChar(regExpr, i, &start, &end);
+ if (start < 0) {
if (indices) {
- result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);
+ value = Tcl_SetVar(interp, varName, "-1 -1", 0);
} else {
- result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
+ value = Tcl_SetVar(interp, varName, "", 0);
}
} else {
if (indices) {
- sprintf(info, "%d %d", (int)(start - string),
- (int)(end - string - 1));
- result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
+ char info[TCL_INTEGER_SPACE * 2];
+
+ sprintf(info, "%d %d", start, end - 1);
+ value = Tcl_SetVar(interp, varName, info, 0);
} else {
- char savedChar, *first, *last;
-
- first = argPtr[1] + (start - string);
- last = argPtr[1] + (end - string);
- if (first == last) { /* don't modify argument */
- result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
- } else {
- savedChar = *last;
- *last = 0;
- result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
- *last = savedChar;
- }
+ value = Tcl_UniCharToUtfDString(wStart + start, end - start,
+ &valueBuffer);
+ value = Tcl_SetVar(interp, varName, value, 0);
+ Tcl_DStringSetLength(&valueBuffer, 0);
}
}
- if (result == NULL) {
+ if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
- argPtr[i+2], "\"", (char *) NULL);
- return TCL_ERROR;
+ varName, "\"", (char *) NULL);
+ result = TCL_ERROR;
+ goto done;
}
}
- Tcl_SetResult(interp, "1", TCL_STATIC);
- return TCL_OK;
+
+ /*
+ * Set the interpreter's object result to an integer object w/ value 1.
+ */
+
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
+
+ done:
+ Tcl_DStringFree(&stringBuffer);
+ Tcl_DStringFree(&valueBuffer);
+ return result;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_RegsubCmd --
+ * Tcl_RegsubObjCmd --
*
* This procedure is invoked to process the "regsub" Tcl command.
* See the user documentation for details on what it does.
@@ -261,81 +315,74 @@ Tcl_RegexpCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_RegsubCmd(dummy, interp, argc, argv)
+Tcl_RegsubObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int noCase = 0, all = 0;
+ int i, result, flags, all, stringLength, numMatches;
Tcl_RegExp regExpr;
- char *string, *pattern, *p, *firstChar, **argPtr;
- int match, code, numMatches;
- char *start, *end, *subStart, *subEnd;
- register char *src, c;
- Tcl_DString stringDString, patternDString, resultDString;
-
- if (argc < 5) {
- wrongNumArgs:
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ?switches? exp string subSpec varName\"", (char *) NULL);
- return TCL_ERROR;
- }
- argPtr = argv+1;
- argc--;
- while (argPtr[0][0] == '-') {
- if (strcmp(argPtr[0], "-nocase") == 0) {
- noCase = 1;
- } else if (strcmp(argPtr[0], "-all") == 0) {
- all = 1;
- } else if (strcmp(argPtr[0], "--") == 0) {
- argPtr++;
- argc--;
+ Tcl_DString resultBuffer, stringBuffer;
+ CONST Tcl_UniChar *w, *wStart, *wEnd;
+ char *string, *subspec, *varname;
+ static char *options[] = {
+ "-all", "-nocase", "--", NULL
+ };
+ enum options {
+ REGSUB_ALL, REGSUB_NOCASE, REGSUB_LAST
+ };
+
+ flags = 0;
+ all = 0;
+
+ for (i = 1; i < objc; i++) {
+ char *name;
+ int index;
+
+ name = Tcl_GetString(objv[i]);
+ if (name[0] != '-') {
break;
- } else {
- Tcl_AppendResult(interp, "bad switch \"", argPtr[0],
- "\": must be -all, -nocase, or --", (char *) NULL);
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
+ &index) != TCL_OK) {
return TCL_ERROR;
}
- argPtr++;
- argc--;
- }
- if (argc != 4) {
- goto wrongNumArgs;
- }
-
- /*
- * Convert the string and pattern to lower case, if desired.
- */
-
- if (noCase) {
- Tcl_DStringInit(&patternDString);
- Tcl_DStringAppend(&patternDString, argPtr[0], -1);
- pattern = Tcl_DStringValue(&patternDString);
- for (p = pattern; *p != 0; p++) {
- if (isupper(UCHAR(*p))) {
- *p = (char)tolower(UCHAR(*p));
+ switch ((enum options) index) {
+ case REGSUB_ALL: {
+ all = 1;
+ break;
}
- }
- Tcl_DStringInit(&stringDString);
- Tcl_DStringAppend(&stringDString, argPtr[1], -1);
- string = Tcl_DStringValue(&stringDString);
- for (p = string; *p != 0; p++) {
- if (isupper(UCHAR(*p))) {
- *p = (char)tolower(UCHAR(*p));
+ case REGSUB_NOCASE: {
+ flags |= REG_ICASE;
+ break;
+ }
+ case REGSUB_LAST: {
+ i++;
+ goto endOfForLoop;
}
}
- } else {
- pattern = argPtr[0];
- string = argPtr[1];
}
- Tcl_DStringInit(&resultDString);
- regExpr = Tcl_RegExpCompile(interp, pattern);
+ endOfForLoop:
+ if (objc - i != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?switches? exp string subSpec varName");
+ return TCL_ERROR;
+ }
+
+ objv += i;
+ regExpr = Tcl_GetRegExpFromObj(interp, objv[0], flags | REG_ADVANCED);
if (regExpr == NULL) {
- code = TCL_ERROR;
- goto done;
+ return TCL_ERROR;
}
+ result = TCL_OK;
+ string = Tcl_GetStringFromObj(objv[1], &stringLength);
+ subspec = Tcl_GetString(objv[2]);
+ varname = Tcl_GetString(objv[3]);
+
+ Tcl_DStringInit(&resultBuffer);
+
/*
* The following loop is to handle multiple matches within the
* same source string; each iteration handles one match and its
@@ -343,25 +390,39 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
* then the loop body only gets executed once.
*/
+ Tcl_DStringInit(&stringBuffer);
+ wStart = Tcl_UtfToUniCharDString(string, stringLength, &stringBuffer);
+ wEnd = wStart + Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar);
+
numMatches = 0;
- for (p = string; *p != 0; ) {
- match = Tcl_RegExpExec(interp, regExpr, p, string);
+ for (w = wStart; w < wEnd; ) {
+ int start, end, subStart, subEnd, match;
+ char *src, *firstChar;
+ char c;
+
+ /*
+ * The flags argument is set if string is part of a larger string,
+ * so that "^" won't match.
+ */
+
+ match = TclRegExpExecUniChar(interp, regExpr, w, wEnd - w, 10,
+ ((w > wStart) ? REG_NOTBOL : 0));
if (match < 0) {
- code = TCL_ERROR;
+ result = TCL_ERROR;
goto done;
}
- if (!match) {
+ if (match == 0) {
break;
}
- numMatches += 1;
+ numMatches++;
/*
* Copy the portion of the source string before the match to the
* result variable.
*/
- Tcl_RegExpRange(regExpr, 0, &start, &end);
- Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), start - p);
+ TclRegExpRangeUniChar(regExpr, 0, &start, &end);
+ Tcl_UniCharToUtfDString(w, start, &resultBuffer);
/*
* Append the subSpec argument to the variable, making appropriate
@@ -369,8 +430,10 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
* conventions and because the code saves up ranges of characters in
* subSpec to reduce the number of calls to Tcl_SetVar.
*/
-
- for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {
+
+ src = subspec;
+ firstChar = subspec;
+ for (c = *src; c != '\0'; src++, c = *src) {
int index;
if (c == '&') {
@@ -380,12 +443,10 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
if ((c >= '0') && (c <= '9')) {
index = c - '0';
} else if ((c == '\\') || (c == '&')) {
- *src = c;
- src[1] = 0;
- Tcl_DStringAppend(&resultDString, firstChar, -1);
- *src = '\\';
- src[1] = c;
- firstChar = src+2;
+ Tcl_DStringAppend(&resultBuffer, firstChar,
+ src - firstChar);
+ Tcl_DStringAppend(&resultBuffer, &c, 1);
+ firstChar = src + 2;
src++;
continue;
} else {
@@ -395,42 +456,31 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
continue;
}
if (firstChar != src) {
- c = *src;
- *src = 0;
- Tcl_DStringAppend(&resultDString, firstChar, -1);
- *src = c;
+ Tcl_DStringAppend(&resultBuffer, firstChar, src - firstChar);
}
- Tcl_RegExpRange(regExpr, index, &subStart, &subEnd);
- if ((subStart != NULL) && (subEnd != NULL)) {
- char *first, *last, saved;
-
- first = argPtr[1] + (subStart - string);
- last = argPtr[1] + (subEnd - string);
- saved = *last;
- *last = 0;
- Tcl_DStringAppend(&resultDString, first, -1);
- *last = saved;
+ TclRegExpRangeUniChar(regExpr, index, &subStart, &subEnd);
+ if ((subStart >= 0) && (subEnd >= 0)) {
+ Tcl_UniCharToUtfDString(w + subStart, subEnd - subStart,
+ &resultBuffer);
}
if (*src == '\\') {
src++;
}
- firstChar = src+1;
+ firstChar = src + 1;
}
if (firstChar != src) {
- Tcl_DStringAppend(&resultDString, firstChar, -1);
+ Tcl_DStringAppend(&resultBuffer, firstChar, src - firstChar);
}
- if (end == p) {
-
+ if (end == 0) {
/*
* Always consume at least one character of the input string
* in order to prevent infinite loops.
*/
- Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), 1);
- p = end + 1;
- } else {
- p = end;
+ Tcl_UniCharToUtfDString(w, 1, &resultBuffer);
+ w++;
}
+ w += end;
if (!all) {
break;
}
@@ -441,30 +491,27 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
* result variable.
*/
- if ((*p != 0) || (numMatches == 0)) {
- Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), -1);
+ if ((w < wEnd) || (numMatches == 0)) {
+ Tcl_UniCharToUtfDString(w, wEnd - w, &resultBuffer);
}
- if (Tcl_SetVar(interp, argPtr[3], Tcl_DStringValue(&resultDString), 0)
- == NULL) {
- Tcl_AppendResult(interp,
- "couldn't set variable \"", argPtr[3], "\"",
+ if (Tcl_SetVar(interp, varname, Tcl_DStringValue(&resultBuffer),
+ 0) == NULL) {
+ Tcl_AppendResult(interp, "couldn't set variable \"", varname, "\"",
(char *) NULL);
- code = TCL_ERROR;
+ result = TCL_ERROR;
} else {
- char buf[40];
+ /*
+ * Set the interpreter's object result to an integer object holding the
+ * number of matches.
+ */
- TclFormatInt(buf, numMatches);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- code = TCL_OK;
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches);
}
done:
- if (noCase) {
- Tcl_DStringFree(&stringDString);
- Tcl_DStringFree(&patternDString);
- }
- Tcl_DStringFree(&resultDString);
- return code;
+ Tcl_DStringFree(&stringBuffer);
+ Tcl_DStringFree(&resultBuffer);
+ return result;
}
/*
@@ -499,8 +546,8 @@ Tcl_RenameObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- oldName = Tcl_GetStringFromObj(objv[1], (int *) NULL);
- newName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ oldName = Tcl_GetString(objv[1]);
+ newName = Tcl_GetString(objv[2]);
return TclRenameCommand(interp, oldName, newName);
}
@@ -541,10 +588,6 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv)
iPtr->errorCode = NULL;
}
code = TCL_OK;
-
- /*
- * THIS FAILS IF AN OBJECT CONTAINS AN EMBEDDED NULL.
- */
for (objv++, objc--; objc > 1; objv += 2, objc -= 2) {
char *option = Tcl_GetStringFromObj(objv[0], &optionLen);
@@ -569,7 +612,7 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv)
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad completion code \"",
- Tcl_GetStringFromObj(objv[1], (int *) NULL),
+ Tcl_GetString(objv[1]),
"\": must be ok, error, return, break, ",
"continue, or an integer", (char *) NULL);
return result;
@@ -607,310 +650,6 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * Tcl_ScanCmd --
- *
- * This procedure is invoked to process the "scan" 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_ScanCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
-{
-# define MAX_FIELDS 20
- typedef struct {
- char fmt; /* Format for field. */
- int size; /* How many bytes to allow for
- * field. */
- char *location; /* Where field will be stored. */
- } Field;
- Field fields[MAX_FIELDS]; /* Info about all the fields in the
- * format string. */
- register Field *curField;
- int numFields = 0; /* Number of fields actually
- * specified. */
- int suppress; /* Current field is assignment-
- * suppressed. */
- int totalSize = 0; /* Number of bytes needed to store
- * all results combined. */
- char *results; /* Where scanned output goes.
- * Malloced; NULL means not allocated
- * yet. */
- int numScanned; /* sscanf's result. */
- register char *fmt;
- int i, widthSpecified, length, code;
- char buf[40];
-
- /*
- * The variables below are used to hold a copy of the format
- * string, so that we can replace format specifiers like "%f"
- * and "%F" with specifiers like "%lf"
- */
-
-# define STATIC_SIZE 5
- char copyBuf[STATIC_SIZE], *fmtCopy;
- register char *dst;
-
- if (argc < 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " string format ?varName varName ...?\"", (char *) NULL);
- return TCL_ERROR;
- }
-
- /*
- * This procedure operates in four stages:
- * 1. Scan the format string, collecting information about each field.
- * 2. Allocate an array to hold all of the scanned fields.
- * 3. Call sscanf to do all the dirty work, and have it store the
- * parsed fields in the array.
- * 4. Pick off the fields from the array and assign them to variables.
- */
-
- code = TCL_OK;
- results = NULL;
- length = strlen(argv[2]) * 2 + 1;
- if (length < STATIC_SIZE) {
- fmtCopy = copyBuf;
- } else {
- fmtCopy = (char *) ckalloc((unsigned) length);
- }
- dst = fmtCopy;
- for (fmt = argv[2]; *fmt != 0; fmt++) {
- *dst = *fmt;
- dst++;
- if (*fmt != '%') {
- continue;
- }
- fmt++;
- if (*fmt == '%') {
- *dst = *fmt;
- dst++;
- continue;
- }
- if (*fmt == '*') {
- suppress = 1;
- *dst = *fmt;
- dst++;
- fmt++;
- } else {
- suppress = 0;
- }
- widthSpecified = 0;
- while (isdigit(UCHAR(*fmt))) {
- widthSpecified = 1;
- *dst = *fmt;
- dst++;
- fmt++;
- }
- if ((*fmt == 'l') || (*fmt == 'h') || (*fmt == 'L')) {
- fmt++;
- }
- *dst = *fmt;
- dst++;
- if (suppress) {
- continue;
- }
- if (numFields == MAX_FIELDS) {
- Tcl_SetResult(interp, "too many fields to scan", TCL_STATIC);
- code = TCL_ERROR;
- goto done;
- }
- curField = &fields[numFields];
- numFields++;
- switch (*fmt) {
- case 'd':
- case 'i':
- case 'o':
- case 'x':
- curField->fmt = 'd';
- curField->size = sizeof(int);
- break;
-
- case 'u':
- curField->fmt = 'u';
- curField->size = sizeof(int);
- break;
-
- case 's':
- curField->fmt = 's';
- curField->size = strlen(argv[1]) + 1;
- break;
-
- case 'c':
- if (widthSpecified) {
- Tcl_SetResult(interp,
- "field width may not be specified in %c conversion",
- TCL_STATIC);
- code = TCL_ERROR;
- goto done;
- }
- curField->fmt = 'c';
- curField->size = sizeof(int);
- break;
-
- case 'e':
- case 'f':
- case 'g':
- dst[-1] = 'l';
- dst[0] = 'f';
- dst++;
- curField->fmt = 'f';
- curField->size = sizeof(double);
- break;
-
- case '[':
- curField->fmt = 's';
- curField->size = strlen(argv[1]) + 1;
- do {
- fmt++;
- if (*fmt == 0) {
- Tcl_SetResult(interp,
- "unmatched [ in format string", TCL_STATIC);
- code = TCL_ERROR;
- goto done;
- }
- *dst = *fmt;
- dst++;
- } while (*fmt != ']');
- break;
-
- default:
- {
- char buf[50];
-
- sprintf(buf, "bad scan conversion character \"%c\"", *fmt);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- code = TCL_ERROR;
- goto done;
- }
- }
- curField->size = TCL_ALIGN(curField->size);
- totalSize += curField->size;
- }
- *dst = 0;
-
- if (numFields != (argc-3)) {
- Tcl_SetResult(interp,
- "different numbers of variable names and field specifiers",
- TCL_STATIC);
- code = TCL_ERROR;
- goto done;
- }
-
- /*
- * Step 2:
- */
-
- results = (char *) ckalloc((unsigned) totalSize);
- for (i = 0, totalSize = 0, curField = fields;
- i < numFields; i++, curField++) {
- curField->location = results + totalSize;
- totalSize += curField->size;
- }
-
- /*
- * Fill in the remaining fields with NULL; the only purpose of
- * this is to keep some memory analyzers, like Purify, from
- * complaining.
- */
-
- for ( ; i < MAX_FIELDS; i++, curField++) {
- curField->location = NULL;
- }
-
- /*
- * Step 3:
- */
-
- numScanned = sscanf(argv[1], fmtCopy,
- fields[0].location, fields[1].location, fields[2].location,
- fields[3].location, fields[4].location, fields[5].location,
- fields[6].location, fields[7].location, fields[8].location,
- fields[9].location, fields[10].location, fields[11].location,
- fields[12].location, fields[13].location, fields[14].location,
- fields[15].location, fields[16].location, fields[17].location,
- fields[18].location, fields[19].location);
-
- /*
- * Step 4:
- */
-
- if (numScanned < numFields) {
- numFields = numScanned;
- }
- for (i = 0, curField = fields; i < numFields; i++, curField++) {
- switch (curField->fmt) {
- char string[TCL_DOUBLE_SPACE];
-
- case 'd':
- TclFormatInt(string, *((int *) curField->location));
- if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
- storeError:
- Tcl_AppendResult(interp,
- "couldn't set variable \"", argv[i+3], "\"",
- (char *) NULL);
- code = TCL_ERROR;
- goto done;
- }
- break;
-
- case 'u':
- sprintf(string, "%u", *((int *) curField->location));
- if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
- goto storeError;
- }
- break;
-
- case 'c':
- TclFormatInt(string, *((char *) curField->location) & 0xff);
- if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
- goto storeError;
- }
- break;
-
- case 's':
- if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)
- == NULL) {
- goto storeError;
- }
- break;
-
- case 'f':
- Tcl_PrintDouble((Tcl_Interp *) NULL,
- *((double *) curField->location), string);
- if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
- goto storeError;
- }
- break;
- }
- }
- TclFormatInt(buf, numScanned);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- done:
- if (results != NULL) {
- ckfree(results);
- }
- if (fmtCopy != copyBuf) {
- ckfree(fmtCopy);
- }
- return code;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_SourceObjCmd --
*
* This procedure is invoked to process the "source" Tcl command.
@@ -941,11 +680,7 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- /*
- * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL.
- */
-
- bytes = Tcl_GetStringFromObj(objv[1], (int *) NULL);
+ bytes = Tcl_GetString(objv[1]);
result = Tcl_EvalFile(interp, bytes);
return result;
}
@@ -975,10 +710,11 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- register char *p, *p2;
- char *splitChars, *string, *elementStart;
- int splitCharLen, stringLen, i, j;
- Tcl_Obj *listPtr;
+ Tcl_UniChar ch;
+ int len;
+ char *splitChars, *string, *end;
+ int splitCharLen, stringLen;
+ Tcl_Obj *listPtr, *objPtr;
if (objc == 2) {
splitChars = " \n\t\r";
@@ -991,41 +727,50 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv)
}
string = Tcl_GetStringFromObj(objv[1], &stringLen);
- listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ end = string + stringLen;
+ listPtr = Tcl_GetObjResult(interp);
- /*
- * Handle the special case of splitting on every character.
- */
+ if (stringLen == 0) {
+ /*
+ * Do nothing.
+ */
+ } else if (splitCharLen == 0) {
+ /*
+ * Handle the special case of splitting on every character.
+ */
- if (splitCharLen == 0) {
- for (i = 0, p = string; i < stringLen; i++, p++) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(p, 1));
+ for ( ; string < end; string += len) {
+ len = Tcl_UtfToUniChar(string, &ch);
+ objPtr = Tcl_NewStringObj(string, len);
+ 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.
*/
- for (i = 0, p = elementStart = string; i < stringLen; i++, p++) {
- for (j = 0, p2 = splitChars; j < splitCharLen; j++, p2++) {
- if (*p2 == *p) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(elementStart, (p-elementStart)));
- elementStart = p+1;
+ 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;
}
}
}
- if (p != string) {
- int remainingChars = stringLen - (elementStart-string);
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(elementStart, remainingChars));
- }
+ objPtr = Tcl_NewStringObj(element, string - element);
+ Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
-
- Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
@@ -1035,7 +780,9 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv)
* Tcl_StringObjCmd --
*
* This procedure is invoked to process the "string" Tcl command.
- * See the user documentation for details on what it does.
+ * See the user documentation for details on what it does. Note
+ * that this command only functions correctly on properly formed
+ * Tcl UTF strings.
*
* Results:
* A standard Tcl result.
@@ -1061,14 +808,14 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
static char *options[] = {
"compare", "first", "index", "last",
"length", "match", "range", "tolower",
- "toupper", "trim", "trimleft", "trimright",
- "wordend", "wordstart", NULL
+ "toupper", "totitle", "trim", "trimleft",
+ "trimright", "wordend", "wordstart", (char *) NULL
};
enum options {
STR_COMPARE, STR_FIRST, STR_INDEX, STR_LAST,
STR_LENGTH, STR_MATCH, STR_RANGE, STR_TOLOWER,
- STR_TOUPPER, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
- STR_WORDEND, STR_WORDSTART
+ STR_TOUPPER, STR_TOTITLE, STR_TRIM, STR_TRIMLEFT,
+ STR_TRIMRIGHT, STR_WORDEND, STR_WORDSTART
};
if (objc < 2) {
@@ -1112,43 +859,67 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
+ /*
+ * This algorithm fails on improperly formed UTF strings.
+ */
+
match = -1;
string1 = Tcl_GetStringFromObj(objv[2], &length1);
string2 = Tcl_GetStringFromObj(objv[3], &length2);
if (length1 > 0) {
end = string2 + length2 - length1 + 1;
for (p = string2; p < end; p++) {
- /*
- * Scan forward to find the first character.
- */
-
- p = memchr(p, *string1, (unsigned) (end - p));
- if (p == NULL) {
- break;
- }
- if (memcmp(string1, p, (unsigned) length1) == 0) {
- match = p - string2;
- break;
- }
+ /*
+ * Scan forward to find the first character.
+ */
+
+ p = memchr(p, *string1, (unsigned) (end - p));
+ if (p == NULL) {
+ break;
+ }
+ if (memcmp(string1, p, (unsigned) length1) == 0) {
+ match = p - string2;
+ break;
+ }
}
}
+
+ /*
+ * Compute the character index of the matching string by counting
+ * the number of characters before the match.
+ */
+
+ if (match != -1) {
+ match = Tcl_NumUtfChars(string2, match);
+ }
Tcl_SetIntObj(resultPtr, match);
break;
}
case STR_INDEX: {
int index;
+ Tcl_UniChar ch;
+ char buf[TCL_UTF_MAX];
+ char *start, *end;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
return TCL_ERROR;
}
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
return TCL_ERROR;
}
- if ((index >= 0) && (index < length1)) {
- Tcl_SetStringObj(resultPtr, string1 + index, 1);
+ if (index >= 0) {
+ start = Tcl_GetStringFromObj(objv[2], &length1);
+ end = start + length1;
+ for ( ; start < end; index--) {
+ start += Tcl_UtfToUniChar(start, &ch);
+ if (index == 0) {
+ Tcl_SetStringObj(resultPtr, buf,
+ Tcl_UniCharToUtf(ch, buf));
+ break;
+ }
+ }
}
break;
}
@@ -1160,6 +931,10 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
goto badFirstLastArgs;
}
+ /*
+ * This algorithm fails on improperly formed UTF strings.
+ */
+
match = -1;
string1 = Tcl_GetStringFromObj(objv[2], &length1);
string2 = Tcl_GetStringFromObj(objv[3], &length2);
@@ -1178,6 +953,15 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
}
}
}
+
+ /*
+ * Compute the character index of the matching string by counting
+ * the number of characters before the match.
+ */
+
+ if (match != -1) {
+ match = Tcl_NumUtfChars(string2, match);
+ }
Tcl_SetIntObj(resultPtr, match);
break;
}
@@ -1187,8 +971,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- (void) Tcl_GetStringFromObj(objv[2], &length1);
- Tcl_SetIntObj(resultPtr, length1);
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ Tcl_SetIntObj(resultPtr, Tcl_NumUtfChars(string1, length1));
break;
}
case STR_MATCH: {
@@ -1211,6 +995,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
}
string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ length1 = Tcl_NumUtfChars(string1, length1);
if (TclGetIntForIndex(interp, objv[3], length1 - 1,
&first) != TCL_OK) {
return TCL_ERROR;
@@ -1226,39 +1011,17 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
last = length1 - 1;
}
if (last >= first) {
- Tcl_SetStringObj(resultPtr, string1 + first, last - first + 1);
- }
- break;
- }
- case STR_TOLOWER: {
- register char *p, *end;
+ char *start, *end;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "string");
- return TCL_ERROR;
- }
-
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
-
- /*
- * Since I know resultPtr is not a shared object, I can reach
- * in and diddle the bytes in its string rep to convert them in
- * place to lower case.
- */
-
- Tcl_SetStringObj(resultPtr, string1, length1);
- string1 = Tcl_GetStringFromObj(resultPtr, &length1);
- end = string1 + length1;
- for (p = string1; p < end; p++) {
- if (isupper(UCHAR(*p))) {
- *p = (char) tolower(UCHAR(*p));
- }
+ start = Tcl_UtfAtIndex(string1, first);
+ end = Tcl_UtfAtIndex(start, last - first + 1);
+ Tcl_SetStringObj(resultPtr, start, end - start);
}
break;
}
- case STR_TOUPPER: {
- register char *p, *end;
-
+ case STR_TOLOWER:
+ case STR_TOUPPER:
+ case STR_TOTITLE:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "string");
return TCL_ERROR;
@@ -1267,30 +1030,33 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
string1 = Tcl_GetStringFromObj(objv[2], &length1);
/*
- * Since I know resultPtr is not a shared object, I can reach
- * in and diddle the bytes in its string rep to convert them in
- * place to upper case.
+ * 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);
- string1 = Tcl_GetStringFromObj(resultPtr, &length1);
- end = string1 + length1;
- for (p = string1; p < end; p++) {
- if (islower(UCHAR(*p))) {
- *p = (char) toupper(UCHAR(*p));
- }
+ if ((enum options) index == STR_TOLOWER) {
+ length1 = Tcl_UtfToLower(Tcl_GetStringFromObj(resultPtr, NULL));
+ } else if ((enum options) index == STR_TOUPPER) {
+ length1 = Tcl_UtfToUpper(Tcl_GetStringFromObj(resultPtr, NULL));
+ } else {
+ length1 = Tcl_UtfToTitle(Tcl_GetStringFromObj(resultPtr, NULL));
}
+ Tcl_SetObjLength(resultPtr, length1);
break;
- }
+
case STR_TRIM: {
- char ch;
+ Tcl_UniChar ch, trim;
register char *p, *end;
char *check, *checkEnd;
+ int offset;
left = 1;
right = 1;
- trim:
+ dotrim:
if (objc == 4) {
string2 = Tcl_GetStringFromObj(objv[3], &length2);
} else if (objc == 3) {
@@ -1305,16 +1071,26 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
if (left) {
end = string1 + length1;
- for (p = string1; p < end; p++) {
- ch = *p;
- for (check = string2; ; check++) {
+ /*
+ * 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 = Tcl_UtfToUniChar(p, &ch);
+
+ for (check = string2; ; ) {
if (check >= checkEnd) {
p = end;
break;
}
- if (ch == *check) {
- length1--;
- string1++;
+ check += Tcl_UtfToUniChar(check, &trim);
+ if (ch == trim) {
+ length1 -= offset;
+ string1 += offset;
break;
}
}
@@ -1322,16 +1098,25 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
}
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--;
- ch = *p;
- for (check = string2; ; check++) {
+ p = Tcl_UtfPrev(p, string1);
+ offset = Tcl_UtfToUniChar(p, &ch);
+ for (check = string2; ; ) {
if (check >= checkEnd) {
p = end;
break;
}
- if (ch == *check) {
- length1--;
+ check += Tcl_UtfToUniChar(check, &trim);
+ if (ch == trim) {
+ length1 -= offset;
break;
}
}
@@ -1343,15 +1128,18 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
case STR_TRIMLEFT: {
left = 1;
right = 0;
- goto trim;
+ goto dotrim;
}
case STR_TRIMRIGHT: {
left = 0;
right = 1;
- goto trim;
+ goto dotrim;
}
case STR_WORDEND: {
- int cur, c;
+ int cur;
+ Tcl_UniChar ch;
+ char *p, *end;
+ int numChars;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string index");
@@ -1365,23 +1153,30 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
if (index < 0) {
index = 0;
}
- cur = length1;
- if (index < length1) {
- for (cur = index; cur < length1; cur++) {
- c = UCHAR(string1[cur]);
- if (!isalnum(c) && (c != '_')) {
+ numChars = Tcl_NumUtfChars(string1, length1);
+ 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 = index + 1;
+ cur++;
}
+ } else {
+ cur = numChars;
}
Tcl_SetIntObj(resultPtr, cur);
break;
}
case STR_WORDSTART: {
- int cur, c;
+ int cur;
+ Tcl_UniChar ch;
+ char *p;
+ int numChars;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string index");
@@ -1392,16 +1187,19 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
return TCL_ERROR;
}
- if (index >= length1) {
- index = length1 - 1;
+ numChars = Tcl_NumUtfChars(string1, length1);
+ if (index >= numChars) {
+ index = numChars - 1;
}
cur = 0;
if (index > 0) {
+ p = Tcl_UtfAtIndex(string1, index);
for (cur = index; cur >= 0; cur--) {
- c = UCHAR(string1[cur]);
- if (!isalnum(c) && (c != '_')) {
+ Tcl_UtfToUniChar(p, &ch);
+ if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
+ p = Tcl_UtfPrev(p, string1);
}
if (cur != index) {
cur += 1;
@@ -1417,7 +1215,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * Tcl_SubstCmd --
+ * Tcl_SubstObjCmd --
*
* This procedure is invoked to process the "subst" Tcl command.
* See the user documentation for details on what it does. This
@@ -1435,51 +1233,59 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
/* ARGSUSED */
int
-Tcl_SubstCmd(dummy, interp, argc, argv)
+Tcl_SubstObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
+ static char *substOptions[] = {
+ "-nobackslashes", "-nocommands", "-novariables", (char *) NULL
+ };
+ enum substOptions {
+ SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
+ };
Interp *iPtr = (Interp *) interp;
Tcl_DString result;
char *p, *old, *value;
- int code, count, doVars, doCmds, doBackslashes, i;
- size_t length;
- char c;
+ int optionIndex, code, count, doVars, doCmds, doBackslashes, i;
/*
* Parse command-line options.
*/
doVars = doCmds = doBackslashes = 1;
- for (i = 1; i < (argc-1); i++) {
- p = argv[i];
+ for (i = 1; i < (objc-1); i++) {
+ p = Tcl_GetString(objv[i]);
if (*p != '-') {
break;
}
- length = strlen(p);
- if (length < 4) {
- badSwitch:
- Tcl_AppendResult(interp, "bad switch \"", p,
- "\": must be -nobackslashes, -nocommands, ",
- "or -novariables", (char *) NULL);
+ if (Tcl_GetIndexFromObj(interp, objv[i], substOptions,
+ "switch", 0, &optionIndex) != TCL_OK) {
+
return TCL_ERROR;
}
- if ((p[3] == 'b') && (strncmp(p, "-nobackslashes", length) == 0)) {
- doBackslashes = 0;
- } else if ((p[3] == 'c') && (strncmp(p, "-nocommands", length) == 0)) {
- doCmds = 0;
- } else if ((p[3] == 'v') && (strncmp(p, "-novariables", length) == 0)) {
- doVars = 0;
- } else {
- goto badSwitch;
+ switch (optionIndex) {
+ case SUBST_NOBACKSLASHES: {
+ doBackslashes = 0;
+ break;
+ }
+ case SUBST_NOCOMMANDS: {
+ doCmds = 0;
+ break;
+ }
+ case SUBST_NOVARS: {
+ doVars = 0;
+ break;
+ }
+ default: {
+ panic("Tcl_SubstObjCmd: bad option index to SubstOptions");
+ }
}
}
- if (i != (argc-1)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ?-nobackslashes? ?-nocommands? ?-novariables? string\"",
- (char *) NULL);
+ if (i != (objc-1)) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?-nobackslashes? ?-nocommands? ?-novariables? string");
return TCL_ERROR;
}
@@ -1489,16 +1295,18 @@ Tcl_SubstCmd(dummy, interp, argc, argv)
*/
Tcl_DStringInit(&result);
- old = p = argv[i];
+ old = p = Tcl_GetString(objv[i]);
while (*p != 0) {
switch (*p) {
case '\\':
if (doBackslashes) {
+ char buf[TCL_UTF_MAX];
+
if (p != old) {
Tcl_DStringAppend(&result, old, p-old);
}
- c = Tcl_Backslash(p, &count);
- Tcl_DStringAppend(&result, &c, 1);
+ Tcl_DStringAppend(&result, buf,
+ Tcl_UtfBackslash(p, &count, buf));
p += count;
old = p;
} else {
@@ -1579,122 +1387,92 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
-#define EXACT 0
-#define GLOB 1
-#define REGEXP 2
- int switchObjc, index;
- Tcl_Obj *CONST *switchObjv;
- Tcl_Obj *patternObj, *bodyObj;
- char *string, *pattern, *body;
- int splitObjs, length, patternLen, i, code, mode, matched, bodyIdx;
- static char *switches[] =
- {"-exact", "-glob", "-regexp", "--", (char *) NULL};
-
- switchObjc = objc-1;
- switchObjv = objv+1;
- mode = EXACT;
-
- while (switchObjc > 0) {
- string = Tcl_GetStringFromObj(switchObjv[0], &length);
- if (*string != '-') {
+ int i, j, index, mode, matched, result;
+ char *string, *pattern;
+ static 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, switchObjv[0], switches,
- "option", 0, &index) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
+ &index) != TCL_OK) {
return TCL_ERROR;
}
- switch (index) {
- case 0: /* -exact */
- mode = EXACT;
- break;
- case 1: /* -glob */
- mode = GLOB;
- break;
- case 2: /* -regexp */
- mode = REGEXP;
- break;
- case 3: /* -- */
- switchObjc--;
- switchObjv++;
- goto doneWithSwitches;
+ if (index == OPT_LAST) {
+ i++;
+ break;
}
- switchObjc--;
- switchObjv++;
+ mode = index;
}
- doneWithSwitches:
- if (switchObjc < 2) {
+ if (objc - i < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
"?switches? string pattern body ... ?default body?");
return TCL_ERROR;
}
-
- string = Tcl_GetStringFromObj(switchObjv[0], &length);
- switchObjc--;
- switchObjv++;
+
+ string = Tcl_GetString(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 (switchObjc == 1) {
- code = Tcl_ListObjLength(interp, switchObjv[0], &switchObjc);
- if (code != TCL_OK) {
- return code;
+ if (objc == 1) {
+ Tcl_Obj **listv;
+
+ if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
+ return TCL_ERROR;
}
- splitObjs = 1;
+ objv = listv;
}
- for (i = 0; i < switchObjc; i += 2) {
- if (i == (switchObjc-1)) {
+ for (i = 0; i < objc; i += 2) {
+ if (i == objc - 1) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"extra switch pattern with no body", -1);
- code = TCL_ERROR;
- goto done;
+ return TCL_ERROR;
}
/*
* See if the pattern matches the string.
*/
- if (splitObjs) {
- code = Tcl_ListObjIndex(interp, switchObjv[0], i, &patternObj);
- if (code != TCL_OK) {
- return code;
- }
- pattern = Tcl_GetStringFromObj(patternObj, &patternLen);
- } else {
- pattern = Tcl_GetStringFromObj(switchObjv[i], &patternLen);
- }
-
+ pattern = Tcl_GetString(objv[i]);
matched = 0;
- if ((*pattern == 'd') && (i == switchObjc-2)
+ if ((i == objc - 2)
+ && (*pattern == 'd')
&& (strcmp(pattern, "default") == 0)) {
matched = 1;
} else {
- /*
- * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL.
- */
switch (mode) {
- case EXACT:
+ case OPT_EXACT:
matched = (strcmp(string, pattern) == 0);
break;
- case GLOB:
+ case OPT_GLOB:
matched = Tcl_StringMatch(string, pattern);
break;
- case REGEXP:
- matched = Tcl_RegExpMatch(interp, string, pattern);
+ case OPT_REGEXP:
+ matched = TclRegExpMatchObj(interp, string, objv[i]);
if (matched < 0) {
- code = TCL_ERROR;
- goto done;
+ return TCL_ERROR;
}
break;
}
}
- if (!matched) {
+ if (matched == 0) {
continue;
}
@@ -1703,53 +1481,28 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
* that are "-".
*/
- for (bodyIdx = i+1; ; bodyIdx += 2) {
- if (bodyIdx >= switchObjc) {
+ for (j = i + 1; ; j += 2) {
+ if (j >= objc) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"no body specified for pattern \"", pattern,
"\"", (char *) NULL);
- code = TCL_ERROR;
- goto done;
- }
-
- if (splitObjs) {
- code = Tcl_ListObjIndex(interp, switchObjv[0], bodyIdx,
- &bodyObj);
- if (code != TCL_OK) {
- return code;
- }
- } else {
- bodyObj = switchObjv[bodyIdx];
+ return TCL_ERROR;
}
- /*
- * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL.
- */
- body = Tcl_GetStringFromObj(bodyObj, &length);
- if ((length != 1) || (body[0] != '-')) {
+ if (strcmp(Tcl_GetString(objv[j]), "-") != 0) {
break;
}
}
- code = Tcl_EvalObj(interp, bodyObj);
- if (code == TCL_ERROR) {
- char msg[100];
+ 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);
}
- goto done;
+ return result;
}
-
- /*
- * Nothing matched: return nothing.
- */
-
- code = TCL_OK;
-
- done:
- return code;
-#undef EXACT
-#undef GLOB
-#undef REGEXP
+ return TCL_OK;
}
/*
@@ -1800,7 +1553,7 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv)
i = count;
TclpGetTime(&start);
while (i-- > 0) {
- result = Tcl_EvalObj(interp, objPtr);
+ result = Tcl_EvalObjEx(interp, objPtr, 0);
if (result != TCL_OK) {
return result;
}
@@ -1819,7 +1572,7 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * Tcl_TraceCmd --
+ * Tcl_TraceObjCmd --
*
* This procedure is invoked to process the "trace" Tcl command.
* See the user documentation for details on what it does.
@@ -1835,160 +1588,186 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv)
/* ARGSUSED */
int
-Tcl_TraceCmd(dummy, interp, argc, argv)
+Tcl_TraceObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int c;
+ int optionIndex, commandLength;
+ char *name, *rwuOps, *command, *p;
size_t length;
+ static char *traceOptions[] = {
+ "variable", "vdelete", "vinfo", (char *) NULL
+ };
+ enum traceOptions {
+ TRACE_VARIABLE, TRACE_VDELETE, TRACE_VINFO
+ };
- if (argc < 2) {
- Tcl_AppendResult(interp, "too few args: should be \"",
- argv[0], " option [arg arg ...]\"", (char *) NULL);
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option [arg arg ...]");
return TCL_ERROR;
}
- c = argv[1][1];
- length = strlen(argv[1]);
- if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)
- && (length >= 2)) {
- char *p;
- int flags, length;
- TraceVarInfo *tvarPtr;
-
- if (argc != 5) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " variable name ops command\"", (char *) NULL);
- return TCL_ERROR;
- }
- flags = 0;
- for (p = argv[3] ; *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 {
- goto badOps;
- }
- }
- if (flags == 0) {
- goto badOps;
- }
+ if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions,
+ "option", 0, &optionIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum traceOptions) optionIndex) {
+ case TRACE_VARIABLE: {
+ int flags;
+ TraceVarInfo *tvarPtr;
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
+ return TCL_ERROR;
+ }
- length = strlen(argv[4]);
- tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
- (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));
- tvarPtr->flags = flags;
- tvarPtr->errMsg = NULL;
- tvarPtr->length = length;
- flags |= TCL_TRACE_UNSETS;
- strcpy(tvarPtr->command, argv[4]);
- if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,
- (ClientData) tvarPtr) != TCL_OK) {
- ckfree((char *) tvarPtr);
- return TCL_ERROR;
- }
- } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)
- && (length >= 2)) == 0) {
- char *p;
- int flags, length;
- TraceVarInfo *tvarPtr;
- ClientData clientData;
-
- if (argc != 5) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " vdelete name ops command\"", (char *) NULL);
- return TCL_ERROR;
- }
+ flags = 0;
+ rwuOps = Tcl_GetString(objv[3]);
+ for (p = rwuOps; *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 {
+ goto badOps;
+ }
+ }
+ if (flags == 0) {
+ goto badOps;
+ }
- flags = 0;
- for (p = argv[3] ; *p != 0; p++) {
- if (*p == 'r') {
- flags |= TCL_TRACE_READS;
- } else if (*p == 'w') {
- flags |= TCL_TRACE_WRITES;
- } else if (*p == 'u') {
+ 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->errMsg = NULL;
+ tvarPtr->length = length;
flags |= TCL_TRACE_UNSETS;
- } else {
- goto badOps;
+ 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;
}
- }
- if (flags == 0) {
- goto badOps;
- }
+ case TRACE_VDELETE: {
+ int flags;
+ TraceVarInfo *tvarPtr;
+ ClientData clientData;
+
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
+ return TCL_ERROR;
+ }
- /*
- * Search through all of our traces on this variable to
- * see if there's one with the given command. If so, then
- * delete the first one that matches.
- */
+ flags = 0;
+ rwuOps = Tcl_GetString(objv[3]);
+ for (p = rwuOps; *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 {
+ goto badOps;
+ }
+ }
+ if (flags == 0) {
+ goto badOps;
+ }
- length = strlen(argv[4]);
- clientData = 0;
- while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
- TraceVarProc, clientData)) != 0) {
- tvarPtr = (TraceVarInfo *) clientData;
- if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
- && (strncmp(argv[4], tvarPtr->command,
- (size_t) length) == 0)) {
- Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
- TraceVarProc, clientData);
- if (tvarPtr->errMsg != NULL) {
- ckfree(tvarPtr->errMsg);
+ /*
+ * Search through all of our traces on this variable to
+ * see if there's one with the given command. If so, then
+ * delete the first one that matches.
+ */
+
+ 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_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS,
+ TraceVarProc, clientData);
+ if (tvarPtr->errMsg != NULL) {
+ ckfree(tvarPtr->errMsg);
+ }
+ ckfree((char *) tvarPtr);
+ break;
+ }
}
- ckfree((char *) tvarPtr);
break;
}
- }
- } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)
- && (length >= 2)) {
- ClientData clientData;
- char ops[4], *p;
- char *prefix = "{";
-
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " vinfo name\"", (char *) NULL);
- return TCL_ERROR;
- }
- clientData = 0;
- while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
- TraceVarProc, clientData)) != 0) {
- TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
- p = ops;
- if (tvarPtr->flags & TCL_TRACE_READS) {
- *p = 'r';
- p++;
- }
- if (tvarPtr->flags & TCL_TRACE_WRITES) {
- *p = 'w';
- p++;
+ case TRACE_VINFO: {
+ ClientData clientData;
+ char ops[4];
+ 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++;
+ }
+ *p = '\0';
+
+ /*
+ * Build a pair (2-item list) with the ops string as
+ * the first obj element and the tvarPtr->command string
+ * as the second obj element. Append the pair (as an
+ * element) to the end of the result object list.
+ */
+
+ elemObjPtr = Tcl_NewStringObj(ops, -1);
+ Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
+ elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
+ Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
+ Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr);
+ }
+ Tcl_SetObjResult(interp, resultListPtr);
+ break;
}
- if (tvarPtr->flags & TCL_TRACE_UNSETS) {
- *p = 'u';
- p++;
+ default: {
+ panic("Tcl_TraceObjCmd: bad option index to TraceOptions");
}
- *p = '\0';
- Tcl_AppendResult(interp, prefix, (char *) NULL);
- Tcl_AppendElement(interp, ops);
- Tcl_AppendElement(interp, tvarPtr->command);
- Tcl_AppendResult(interp, "}", (char *) NULL);
- prefix = " {";
- }
- } else {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": should be variable, vdelete, or vinfo",
- (char *) NULL);
- return TCL_ERROR;
}
return TCL_OK;
badOps:
- Tcl_AppendResult(interp, "bad operations \"", argv[3],
+ Tcl_AppendResult(interp, "bad operations \"", rwuOps,
"\": should be one or more of rwu", (char *) NULL);
return TCL_ERROR;
}
@@ -2022,13 +1801,11 @@ TraceVarProc(clientData, interp, name1, name2, flags)
int flags; /* OR-ed bits giving operation and other
* information. */
{
- Interp *iPtr = (Interp *) interp;
+ Tcl_SavedResult state;
TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
char *result;
int code;
- Interp dummy;
Tcl_DString cmd;
- Tcl_Obj *saveObjPtr, *oldObjResultPtr;
result = NULL;
if (tvarPtr->errMsg != NULL) {
@@ -2048,7 +1825,7 @@ TraceVarProc(clientData, interp, name1, name2, flags)
name2 = "";
}
Tcl_DStringInit(&cmd);
- Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length);
+ Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);
Tcl_DStringAppendElement(&cmd, name1);
Tcl_DStringAppendElement(&cmd, name2);
if (flags & TCL_TRACE_READS) {
@@ -2060,53 +1837,25 @@ TraceVarProc(clientData, interp, name1, name2, flags)
}
/*
- * Execute the command. Be careful to save and restore both the
- * string and object results from the interpreter used for
+ * Execute the command. Save the interp's result used for
* the command. We discard any object result the command returns.
*/
- dummy.objResultPtr = Tcl_NewObj();
- Tcl_IncrRefCount(dummy.objResultPtr);
- if (interp->freeProc == 0) {
- dummy.freeProc = (Tcl_FreeProc *) 0;
- dummy.result = "";
- Tcl_SetResult((Tcl_Interp *) &dummy, interp->result,
- TCL_VOLATILE);
- } else {
- dummy.freeProc = interp->freeProc;
- dummy.result = interp->result;
- interp->freeProc = (Tcl_FreeProc *) 0;
- }
-
- saveObjPtr = Tcl_GetObjResult(interp);
- Tcl_IncrRefCount(saveObjPtr);
-
+ Tcl_SaveResult(interp, &state);
+
code = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
if (code != TCL_OK) { /* copy error msg to result */
- tvarPtr->errMsg = (char *)
- ckalloc((unsigned) (strlen(interp->result) + 1));
- strcpy(tvarPtr->errMsg, interp->result);
+ char *string;
+ int length;
+
+ string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
+ tvarPtr->errMsg = (char *) ckalloc((unsigned) (length + 1));
+ memcpy(tvarPtr->errMsg, string, (size_t) (length + 1));
result = tvarPtr->errMsg;
- Tcl_ResetResult(interp); /* must clear error state. */
}
- /*
- * Restore the interpreter's string result.
- */
-
- Tcl_SetResult(interp, dummy.result,
- (dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc);
+ Tcl_RestoreResult(interp, &state);
- /*
- * Restore the interpreter's object result from saveObjPtr.
- */
-
- oldObjResultPtr = iPtr->objResultPtr;
- iPtr->objResultPtr = saveObjPtr; /* was incremented above */
- Tcl_DecrRefCount(oldObjResultPtr);
-
- Tcl_DecrRefCount(dummy.objResultPtr);
- dummy.objResultPtr = NULL;
Tcl_DStringFree(&cmd);
}
if (flags & TCL_TRACE_DESTROYED) {
@@ -2122,7 +1871,7 @@ TraceVarProc(clientData, interp, name1, name2, flags)
/*
*----------------------------------------------------------------------
*
- * Tcl_WhileCmd --
+ * Tcl_WhileObjCmd --
*
* This procedure is invoked to process the "while" Tcl command.
* See the user documentation for details on what it does.
@@ -2142,32 +1891,32 @@ TraceVarProc(clientData, interp, name1, name2, flags)
/* ARGSUSED */
int
-Tcl_WhileCmd(dummy, interp, argc, argv)
+Tcl_WhileObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result, value;
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " test command\"", (char *) NULL);
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "test command");
return TCL_ERROR;
}
while (1) {
- result = Tcl_ExprBoolean(interp, argv[1], &value);
+ result = Tcl_ExprBooleanObj(interp, objv[1], &value);
if (result != TCL_OK) {
return result;
}
if (!value) {
break;
}
- result = Tcl_Eval(interp, argv[2]);
+ result = Tcl_EvalObjEx(interp, objv[2], 0);
if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
if (result == TCL_ERROR) {
- char msg[60];
+ char msg[32 + TCL_INTEGER_SPACE];
+
sprintf(msg, "\n (\"while\" body line %d)",
interp->errorLine);
Tcl_AddErrorInfo(interp, msg);