diff options
author | stanton <stanton> | 1999-04-16 00:46:29 (GMT) |
---|---|---|
committer | stanton <stanton> | 1999-04-16 00:46:29 (GMT) |
commit | 97464e6cba8eb0008cf2727c15718671992b913f (patch) | |
tree | ce9959f2747257d98d52ec8d18bf3b0de99b9535 /generic/tclCmdMZ.c | |
parent | a8c96ddb94d1483a9de5e340b740cb74ef6cafa7 (diff) | |
download | tcl-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.c | 1715 |
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); |