Parent Directory
| 
Revision Log
| 
Patch
| projs/trunk/shared_source/tcl_base/tclcmdmz.c revision 42 by dashley, Fri Oct 14 01:50:00 2016 UTC | projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcmdmz.c revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC | |
|---|---|---|
| # | Line 1 | Line 1 |
| /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclcmdmz.c,v 1.1.1.1 2001/06/13 04:35:16 dtashley Exp $ */ | ||
| /* | ||
| * tclCmdMZ.c -- | ||
| * | ||
| * This file contains the top-level command routines for most of | ||
| * the Tcl built-in commands whose names begin with the letters | ||
| * M to Z. It contains only commands in the generic core (i.e. | ||
| * those that don't depend much upon UNIX facilities). | ||
| * | ||
| * Copyright (c) 1987-1993 The Regents of the University of California. | ||
| * Copyright (c) 1994-1997 Sun Microsystems, Inc. | ||
| * Copyright (c) 1998-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.1.1.1 2001/06/13 04:35:16 dtashley 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: | ||
| */ | ||
| typedef struct { | ||
| int flags; /* Operations for which Tcl command is | ||
| * to be invoked. */ | ||
| char *errMsg; /* Error message returned from Tcl command, | ||
| * or NULL. Malloc'ed. */ | ||
| size_t length; /* Number of non-NULL chars. in command. */ | ||
| char command[4]; /* Space for Tcl command to invoke. Actual | ||
| * size will be as large as necessary to | ||
| * hold command. This field must be the | ||
| * last in the structure, so that it can | ||
| * be larger than 4 bytes. */ | ||
| } TraceVarInfo; | ||
| /* | ||
| * Forward declarations for procedures defined in this file: | ||
| */ | ||
| static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, | ||
| Tcl_Interp *interp, char *name1, char *name2, | ||
| int flags)); | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_PwdObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "pwd" Tcl command. | ||
| * See the user documentation for details on what it does. | ||
| * | ||
| * Results: | ||
| * A standard Tcl result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_PwdObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| Tcl_DString ds; | ||
| if (objc != 1) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| if (Tcl_GetCwd(interp, &ds) == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| Tcl_DStringResult(interp, &ds); | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_RegexpObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "regexp" Tcl command. | ||
| * See the user documentation for details on what it does. | ||
| * | ||
| * Results: | ||
| * A standard Tcl result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_RegexpObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| int i, indices, match, about, offset, all, doinline, numMatchesSaved; | ||
| int cflags, eflags, stringLength; | ||
| Tcl_RegExp regExpr; | ||
| Tcl_Obj *objPtr, *resultPtr; | ||
| Tcl_RegExpInfo info; | ||
| static char *options[] = { | ||
| "-all", "-about", "-indices", "-inline", | ||
| "-expanded", "-line", "-linestop", "-lineanchor", | ||
| "-nocase", "-start", "--", (char *) NULL | ||
| }; | ||
| enum options { | ||
| REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE, | ||
| REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR, | ||
| REGEXP_NOCASE, REGEXP_START, REGEXP_LAST | ||
| }; | ||
| indices = 0; | ||
| about = 0; | ||
| cflags = TCL_REG_ADVANCED; | ||
| eflags = 0; | ||
| offset = 0; | ||
| all = 0; | ||
| doinline = 0; | ||
| for (i = 1; i < objc; i++) { | ||
| char *name; | ||
| int index; | ||
| name = Tcl_GetString(objv[i]); | ||
| if (name[0] != '-') { | ||
| break; | ||
| } | ||
| if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, | ||
| &index) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| switch ((enum options) index) { | ||
| case REGEXP_ALL: { | ||
| all = 1; | ||
| break; | ||
| } | ||
| case REGEXP_INDICES: { | ||
| indices = 1; | ||
| break; | ||
| } | ||
| case REGEXP_INLINE: { | ||
| doinline = 1; | ||
| break; | ||
| } | ||
| case REGEXP_NOCASE: { | ||
| cflags |= TCL_REG_NOCASE; | ||
| break; | ||
| } | ||
| case REGEXP_ABOUT: { | ||
| about = 1; | ||
| break; | ||
| } | ||
| case REGEXP_EXPANDED: { | ||
| cflags |= TCL_REG_EXPANDED; | ||
| break; | ||
| } | ||
| case REGEXP_LINE: { | ||
| cflags |= TCL_REG_NEWLINE; | ||
| break; | ||
| } | ||
| case REGEXP_LINESTOP: { | ||
| cflags |= TCL_REG_NLSTOP; | ||
| break; | ||
| } | ||
| case REGEXP_LINEANCHOR: { | ||
| cflags |= TCL_REG_NLANCH; | ||
| break; | ||
| } | ||
| case REGEXP_START: { | ||
| if (++i >= objc) { | ||
| goto endOfForLoop; | ||
| } | ||
| if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (offset < 0) { | ||
| offset = 0; | ||
| } | ||
| break; | ||
| } | ||
| case REGEXP_LAST: { | ||
| i++; | ||
| goto endOfForLoop; | ||
| } | ||
| } | ||
| } | ||
| endOfForLoop: | ||
| if ((objc - i) < (2 - about)) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); | ||
| return TCL_ERROR; | ||
| } | ||
| objc -= i; | ||
| objv += i; | ||
| if (doinline && ((objc - 2) != 0)) { | ||
| /* | ||
| * User requested -inline, but specified match variables - a no-no. | ||
| */ | ||
| Tcl_AppendResult(interp, "regexp match variables not allowed", | ||
| " when using -inline", (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); | ||
| if (regExpr == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| objPtr = objv[1]; | ||
| if (about) { | ||
| if (TclRegAbout(interp, regExpr) < 0) { | ||
| return TCL_ERROR; | ||
| } | ||
| return TCL_OK; | ||
| } | ||
| if (offset > 0) { | ||
| /* | ||
| * Add flag if using offset (string is part of a larger string), | ||
| * so that "^" won't match. | ||
| */ | ||
| eflags |= TCL_REG_NOTBOL; | ||
| } | ||
| objc -= 2; | ||
| objv += 2; | ||
| resultPtr = Tcl_GetObjResult(interp); | ||
| if (doinline) { | ||
| /* | ||
| * Save all the subexpressions, as we will return them as a list | ||
| */ | ||
| numMatchesSaved = -1; | ||
| } else { | ||
| /* | ||
| * Save only enough subexpressions for matches we want to keep, | ||
| * expect in the case of -all, where we need to keep at least | ||
| * one to know where to move the offset. | ||
| */ | ||
| numMatchesSaved = (objc == 0) ? all : objc; | ||
| } | ||
| /* | ||
| * Get the length of the string that we are matching against so | ||
| * we can do the termination test for -all matches. | ||
| */ | ||
| stringLength = Tcl_GetCharLength(objPtr); | ||
| /* | ||
| * The following loop is to handle multiple matches within the | ||
| * same source string; each iteration handles one match. If "-all" | ||
| * hasn't been specified then the loop body only gets executed once. | ||
| * We terminate the loop when the starting offset is past the end of the | ||
| * string. | ||
| */ | ||
| while (1) { | ||
| match = Tcl_RegExpExecObj(interp, regExpr, objPtr, | ||
| offset /* offset */, numMatchesSaved, eflags); | ||
| if (match < 0) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (match == 0) { | ||
| /* | ||
| * We want to set the value of the intepreter result only when | ||
| * this is the first time through the loop. | ||
| */ | ||
| if (all <= 1) { | ||
| /* | ||
| * If inlining, set the interpreter's object result to an | ||
| * empty list, otherwise set it to an integer object w/ | ||
| * value 0. | ||
| */ | ||
| if (doinline) { | ||
| Tcl_SetListObj(resultPtr, 0, NULL); | ||
| } else { | ||
| Tcl_SetIntObj(resultPtr, 0); | ||
| } | ||
| return TCL_OK; | ||
| } | ||
| break; | ||
| } | ||
| /* | ||
| * If additional variable names have been specified, return | ||
| * index information in those variables. | ||
| */ | ||
| Tcl_RegExpGetInfo(regExpr, &info); | ||
| if (doinline) { | ||
| /* | ||
| * It's the number of substitutions, plus one for the matchVar | ||
| * at index 0 | ||
| */ | ||
| objc = info.nsubs + 1; | ||
| } | ||
| for (i = 0; i < objc; i++) { | ||
| Tcl_Obj *newPtr; | ||
| if (indices) { | ||
| int start, end; | ||
| Tcl_Obj *objs[2]; | ||
| if (i <= info.nsubs) { | ||
| start = offset + info.matches[i].start; | ||
| end = offset + info.matches[i].end; | ||
| /* | ||
| * Adjust index so it refers to the last character in the | ||
| * match instead of the first character after the match. | ||
| */ | ||
| if (end >= offset) { | ||
| end--; | ||
| } | ||
| } else { | ||
| start = -1; | ||
| end = -1; | ||
| } | ||
| objs[0] = Tcl_NewLongObj(start); | ||
| objs[1] = Tcl_NewLongObj(end); | ||
| newPtr = Tcl_NewListObj(2, objs); | ||
| } else { | ||
| if (i <= info.nsubs) { | ||
| newPtr = Tcl_GetRange(objPtr, | ||
| offset + info.matches[i].start, | ||
| offset + info.matches[i].end - 1); | ||
| } else { | ||
| newPtr = Tcl_NewObj(); | ||
| } | ||
| } | ||
| if (doinline) { | ||
| if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr) | ||
| != TCL_OK) { | ||
| Tcl_DecrRefCount(newPtr); | ||
| return TCL_ERROR; | ||
| } | ||
| } else { | ||
| Tcl_Obj *valuePtr; | ||
| valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); | ||
| if (valuePtr == NULL) { | ||
| Tcl_DecrRefCount(newPtr); | ||
| Tcl_AppendResult(interp, "couldn't set variable \"", | ||
| Tcl_GetString(objv[i]), "\"", (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| } | ||
| } | ||
| if (all == 0) { | ||
| break; | ||
| } | ||
| /* | ||
| * Adjust the offset to the character just after the last one | ||
| * in the matchVar and increment all to count how many times | ||
| * we are making a match. We always increment the offset by at least | ||
| * one to prevent endless looping (as in the case: | ||
| * regexp -all {a*} a). Otherwise, when we match the NULL string at | ||
| * the end of the input string, we will loop indefinately (because the | ||
| * length of the match is 0, so offset never changes). | ||
| */ | ||
| if (info.matches[0].end == 0) { | ||
| offset++; | ||
| } | ||
| offset += info.matches[0].end; | ||
| all++; | ||
| if (offset >= stringLength) { | ||
| break; | ||
| } | ||
| } | ||
| /* | ||
| * Set the interpreter's object result to an integer object | ||
| * with value 1 if -all wasn't specified, otherwise it's all-1 | ||
| * (the number of times through the while - 1). | ||
| */ | ||
| if (!doinline) { | ||
| Tcl_SetIntObj(resultPtr, (all ? all-1 : 1)); | ||
| } | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_RegsubObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "regsub" Tcl command. | ||
| * See the user documentation for details on what it does. | ||
| * | ||
| * Results: | ||
| * A standard Tcl result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_RegsubObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| int i, result, cflags, all, wlen, numMatches, offset; | ||
| Tcl_RegExp regExpr; | ||
| Tcl_Obj *resultPtr, *varPtr, *objPtr; | ||
| Tcl_UniChar *wstring; | ||
| char *subspec; | ||
| static char *options[] = { | ||
| "-all", "-nocase", "-expanded", | ||
| "-line", "-linestop", "-lineanchor", "-start", | ||
| "--", NULL | ||
| }; | ||
| enum options { | ||
| REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED, | ||
| REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START, | ||
| REGSUB_LAST | ||
| }; | ||
| cflags = TCL_REG_ADVANCED; | ||
| all = 0; | ||
| offset = 0; | ||
| for (i = 1; i < objc; i++) { | ||
| char *name; | ||
| int index; | ||
| name = Tcl_GetString(objv[i]); | ||
| if (name[0] != '-') { | ||
| break; | ||
| } | ||
| if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, | ||
| &index) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| switch ((enum options) index) { | ||
| case REGSUB_ALL: { | ||
| all = 1; | ||
| break; | ||
| } | ||
| case REGSUB_NOCASE: { | ||
| cflags |= TCL_REG_NOCASE; | ||
| break; | ||
| } | ||
| case REGSUB_EXPANDED: { | ||
| cflags |= TCL_REG_EXPANDED; | ||
| break; | ||
| } | ||
| case REGSUB_LINE: { | ||
| cflags |= TCL_REG_NEWLINE; | ||
| break; | ||
| } | ||
| case REGSUB_LINESTOP: { | ||
| cflags |= TCL_REG_NLSTOP; | ||
| break; | ||
| } | ||
| case REGSUB_LINEANCHOR: { | ||
| cflags |= TCL_REG_NLANCH; | ||
| break; | ||
| } | ||
| case REGSUB_START: { | ||
| if (++i >= objc) { | ||
| goto endOfForLoop; | ||
| } | ||
| if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (offset < 0) { | ||
| offset = 0; | ||
| } | ||
| break; | ||
| } | ||
| case REGSUB_LAST: { | ||
| i++; | ||
| goto endOfForLoop; | ||
| } | ||
| } | ||
| } | ||
| 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], cflags); | ||
| if (regExpr == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| result = TCL_OK; | ||
| resultPtr = Tcl_NewObj(); | ||
| Tcl_IncrRefCount(resultPtr); | ||
| objPtr = objv[1]; | ||
| wlen = Tcl_GetCharLength(objPtr); | ||
| wstring = Tcl_GetUnicode(objPtr); | ||
| subspec = Tcl_GetString(objv[2]); | ||
| varPtr = objv[3]; | ||
| /* | ||
| * The following loop is to handle multiple matches within the | ||
| * same source string; each iteration handles one match and its | ||
| * corresponding substitution. If "-all" hasn't been specified | ||
| * then the loop body only gets executed once. | ||
| */ | ||
| numMatches = 0; | ||
| for ( ; offset < wlen; ) { | ||
| int start, end, subStart, subEnd, match; | ||
| char *src, *firstChar; | ||
| char c; | ||
| Tcl_RegExpInfo info; | ||
| /* | ||
| * The flags argument is set if string is part of a larger string, | ||
| * so that "^" won't match. | ||
| */ | ||
| match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset, | ||
| 10 /* matches */, ((offset > 0) ? TCL_REG_NOTBOL : 0)); | ||
| if (match < 0) { | ||
| result = TCL_ERROR; | ||
| goto done; | ||
| } | ||
| if (match == 0) { | ||
| break; | ||
| } | ||
| if ((numMatches == 0) && (offset > 0)) { | ||
| /* Copy the initial portion of the string in if an offset | ||
| * was specified. | ||
| */ | ||
| Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); | ||
| } | ||
| numMatches++; | ||
| /* | ||
| * Copy the portion of the source string before the match to the | ||
| * result variable. | ||
| */ | ||
| Tcl_RegExpGetInfo(regExpr, &info); | ||
| start = info.matches[0].start; | ||
| end = info.matches[0].end; | ||
| Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); | ||
| /* | ||
| * Append the subSpec argument to the variable, making appropriate | ||
| * substitutions. This code is a bit hairy because of the backslash | ||
| * conventions and because the code saves up ranges of characters in | ||
| * subSpec to reduce the number of calls to Tcl_SetVar. | ||
| */ | ||
| src = subspec; | ||
| firstChar = subspec; | ||
| for (c = *src; c != '\0'; src++, c = *src) { | ||
| int index; | ||
| if (c == '&') { | ||
| index = 0; | ||
| } else if (c == '\\') { | ||
| c = src[1]; | ||
| if ((c >= '0') && (c <= '9')) { | ||
| index = c - '0'; | ||
| } else if ((c == '\\') || (c == '&')) { | ||
| Tcl_AppendToObj(resultPtr, firstChar, src - firstChar); | ||
| Tcl_AppendToObj(resultPtr, &c, 1); | ||
| firstChar = src + 2; | ||
| src++; | ||
| continue; | ||
| } else { | ||
| continue; | ||
| } | ||
| } else { | ||
| continue; | ||
| } | ||
| if (firstChar != src) { | ||
| Tcl_AppendToObj(resultPtr, firstChar, src - firstChar); | ||
| } | ||
| if (index <= info.nsubs) { | ||
| subStart = info.matches[index].start; | ||
| subEnd = info.matches[index].end; | ||
| if ((subStart >= 0) && (subEnd >= 0)) { | ||
| Tcl_AppendUnicodeToObj(resultPtr, | ||
| wstring + offset + subStart, subEnd - subStart); | ||
| } | ||
| } | ||
| if (*src == '\\') { | ||
| src++; | ||
| } | ||
| firstChar = src + 1; | ||
| } | ||
| if (firstChar != src) { | ||
| Tcl_AppendToObj(resultPtr, firstChar, src - firstChar); | ||
| } | ||
| if (end == 0) { | ||
| /* | ||
| * Always consume at least one character of the input string | ||
| * in order to prevent infinite loops. | ||
| */ | ||
| Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); | ||
| offset++; | ||
| } | ||
| offset += end; | ||
| if (!all) { | ||
| break; | ||
| } | ||
| } | ||
| /* | ||
| * Copy the portion of the source string after the last match to the | ||
| * result variable. | ||
| */ | ||
| if (numMatches == 0) { | ||
| /* | ||
| * On zero matches, just ignore the offset, since it shouldn't | ||
| * matter to us in this case, and the user may have skewed it. | ||
| */ | ||
| Tcl_AppendUnicodeToObj(resultPtr, wstring, wlen); | ||
| } else if (offset < wlen) { | ||
| Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); | ||
| } | ||
| if (Tcl_ObjSetVar2(interp, varPtr, NULL, resultPtr, 0) == NULL) { | ||
| Tcl_AppendResult(interp, "couldn't set variable \"", | ||
| Tcl_GetString(varPtr), "\"", (char *) NULL); | ||
| result = TCL_ERROR; | ||
| } else { | ||
| /* | ||
| * Set the interpreter's object result to an integer object holding the | ||
| * number of matches. | ||
| */ | ||
| Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches); | ||
| } | ||
| done: | ||
| Tcl_DecrRefCount(resultPtr); | ||
| return result; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_RenameObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "rename" Tcl command. | ||
| * See the user documentation for details on what it does. | ||
| * | ||
| * Results: | ||
| * A standard Tcl object result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_RenameObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Arbitrary value passed to the command. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| char *oldName, *newName; | ||
| if (objc != 3) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); | ||
| return TCL_ERROR; | ||
| } | ||
| oldName = Tcl_GetString(objv[1]); | ||
| newName = Tcl_GetString(objv[2]); | ||
| return TclRenameCommand(interp, oldName, newName); | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_ReturnObjCmd -- | ||
| * | ||
| * This object-based procedure is invoked to process the "return" Tcl | ||
| * command. See the user documentation for details on what it does. | ||
| * | ||
| * Results: | ||
| * A standard Tcl object result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_ReturnObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| Interp *iPtr = (Interp *) interp; | ||
| int optionLen, argLen, code, result; | ||
| if (iPtr->errorInfo != NULL) { | ||
| ckfree(iPtr->errorInfo); | ||
| iPtr->errorInfo = NULL; | ||
| } | ||
| if (iPtr->errorCode != NULL) { | ||
| ckfree(iPtr->errorCode); | ||
| iPtr->errorCode = NULL; | ||
| } | ||
| code = TCL_OK; | ||
| for (objv++, objc--; objc > 1; objv += 2, objc -= 2) { | ||
| char *option = Tcl_GetStringFromObj(objv[0], &optionLen); | ||
| char *arg = Tcl_GetStringFromObj(objv[1], &argLen); | ||
| if (strcmp(option, "-code") == 0) { | ||
| register int c = arg[0]; | ||
| if ((c == 'o') && (strcmp(arg, "ok") == 0)) { | ||
| code = TCL_OK; | ||
| } else if ((c == 'e') && (strcmp(arg, "error") == 0)) { | ||
| code = TCL_ERROR; | ||
| } else if ((c == 'r') && (strcmp(arg, "return") == 0)) { | ||
| code = TCL_RETURN; | ||
| } else if ((c == 'b') && (strcmp(arg, "break") == 0)) { | ||
| code = TCL_BREAK; | ||
| } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) { | ||
| code = TCL_CONTINUE; | ||
| } else { | ||
| result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1], | ||
| &code); | ||
| if (result != TCL_OK) { | ||
| Tcl_ResetResult(interp); | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | ||
| "bad completion code \"", | ||
| Tcl_GetString(objv[1]), | ||
| "\": must be ok, error, return, break, ", | ||
| "continue, or an integer", (char *) NULL); | ||
| return result; | ||
| } | ||
| } | ||
| } else if (strcmp(option, "-errorinfo") == 0) { | ||
| iPtr->errorInfo = | ||
| (char *) ckalloc((unsigned) (strlen(arg) + 1)); | ||
| strcpy(iPtr->errorInfo, arg); | ||
| } else if (strcmp(option, "-errorcode") == 0) { | ||
| iPtr->errorCode = | ||
| (char *) ckalloc((unsigned) (strlen(arg) + 1)); | ||
| strcpy(iPtr->errorCode, arg); | ||
| } else { | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | ||
| "bad option \"", option, | ||
| "\": must be -code, -errorcode, or -errorinfo", | ||
| (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| } | ||
| if (objc == 1) { | ||
| /* | ||
| * Set the interpreter's object result. An inline version of | ||
| * Tcl_SetObjResult. | ||
| */ | ||
| Tcl_SetObjResult(interp, objv[0]); | ||
| } | ||
| iPtr->returnCode = code; | ||
| return TCL_RETURN; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_SourceObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "source" Tcl command. | ||
| * See the user documentation for details on what it does. | ||
| * | ||
| * Results: | ||
| * A standard Tcl object result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_SourceObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| char *bytes; | ||
| int result; | ||
| if (objc != 2) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, "fileName"); | ||
| return TCL_ERROR; | ||
| } | ||
| bytes = Tcl_GetString(objv[1]); | ||
| result = Tcl_EvalFile(interp, bytes); | ||
| return result; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_SplitObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "split" Tcl command. | ||
| * See the user documentation for details on what it does. | ||
| * | ||
| * Results: | ||
| * A standard Tcl result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_SplitObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| Tcl_UniChar ch; | ||
| int len; | ||
| char *splitChars, *string, *end; | ||
| int splitCharLen, stringLen; | ||
| Tcl_Obj *listPtr, *objPtr; | ||
| if (objc == 2) { | ||
| splitChars = " \n\t\r"; | ||
| splitCharLen = 4; | ||
| } else if (objc == 3) { | ||
| splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen); | ||
| } else { | ||
| Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?"); | ||
| return TCL_ERROR; | ||
| } | ||
| string = Tcl_GetStringFromObj(objv[1], &stringLen); | ||
| end = string + stringLen; | ||
| listPtr = Tcl_GetObjResult(interp); | ||
| if (stringLen == 0) { | ||
| /* | ||
| * Do nothing. | ||
| */ | ||
| } else if (splitCharLen == 0) { | ||
| /* | ||
| * Handle the special case of splitting on every character. | ||
| */ | ||
| 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. | ||
| */ | ||
| splitEnd = splitChars + splitCharLen; | ||
| for (element = string; string < end; string += len) { | ||
| len = Tcl_UtfToUniChar(string, &ch); | ||
| for (p = splitChars; p < splitEnd; p += splitLen) { | ||
| splitLen = Tcl_UtfToUniChar(p, &splitChar); | ||
| if (ch == splitChar) { | ||
| objPtr = Tcl_NewStringObj(element, string - element); | ||
| Tcl_ListObjAppendElement(NULL, listPtr, objPtr); | ||
| element = string + len; | ||
| break; | ||
| } | ||
| } | ||
| } | ||
| objPtr = Tcl_NewStringObj(element, string - element); | ||
| Tcl_ListObjAppendElement(NULL, listPtr, objPtr); | ||
| } | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_StringObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "string" Tcl command. | ||
| * See the user documentation for details on what it does. Note | ||
| * that this command only functions correctly on properly formed | ||
| * Tcl UTF strings. | ||
| * | ||
| * Results: | ||
| * A standard Tcl result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_StringObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| int index, left, right; | ||
| Tcl_Obj *resultPtr; | ||
| char *string1, *string2; | ||
| int length1, length2; | ||
| static char *options[] = { | ||
| "bytelength", "compare", "equal", "first", | ||
| "index", "is", "last", "length", | ||
| "map", "match", "range", "repeat", | ||
| "replace", "tolower", "toupper", "totitle", | ||
| "trim", "trimleft", "trimright", | ||
| "wordend", "wordstart", (char *) NULL | ||
| }; | ||
| enum options { | ||
| STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST, | ||
| STR_INDEX, STR_IS, STR_LAST, STR_LENGTH, | ||
| STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT, | ||
| STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE, | ||
| STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, | ||
| STR_WORDEND, STR_WORDSTART | ||
| }; | ||
| if (objc < 2) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); | ||
| return TCL_ERROR; | ||
| } | ||
| if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, | ||
| &index) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| resultPtr = Tcl_GetObjResult(interp); | ||
| switch ((enum options) index) { | ||
| case STR_EQUAL: | ||
| case STR_COMPARE: { | ||
| int i, match, length, nocase = 0, reqlength = -1; | ||
| if (objc < 4 || objc > 7) { | ||
| str_cmp_args: | ||
| Tcl_WrongNumArgs(interp, 2, objv, | ||
| "?-nocase? ?-length int? string1 string2"); | ||
| return TCL_ERROR; | ||
| } | ||
| for (i = 2; i < objc-2; i++) { | ||
| string2 = Tcl_GetStringFromObj(objv[i], &length2); | ||
| if ((length2 > 1) | ||
| && strncmp(string2, "-nocase", (size_t) length2) == 0) { | ||
| nocase = 1; | ||
| } else if ((length2 > 1) | ||
| && strncmp(string2, "-length", (size_t) length2) == 0) { | ||
| if (i+1 >= objc-2) { | ||
| goto str_cmp_args; | ||
| } | ||
| if (Tcl_GetIntFromObj(interp, objv[++i], | ||
| &reqlength) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| } else { | ||
| Tcl_AppendStringsToObj(resultPtr, "bad option \"", | ||
| string2, "\": must be -nocase or -length", | ||
| (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| } | ||
| string1 = Tcl_GetStringFromObj(objv[objc-2], &length1); | ||
| string2 = Tcl_GetStringFromObj(objv[objc-1], &length2); | ||
| /* | ||
| * This is the min length IN BYTES of the two strings | ||
| */ | ||
| length = (length1 < length2) ? length1 : length2; | ||
| if (reqlength == 0) { | ||
| /* | ||
| * Anything matches at 0 chars, right? | ||
| */ | ||
| match = 0; | ||
| } else if (nocase || ((reqlength > 0) && (reqlength <= length))) { | ||
| /* | ||
| * with -nocase or -length we have to check true char length | ||
| * as it could be smaller than expected | ||
| */ | ||
| length1 = Tcl_NumUtfChars(string1, length1); | ||
| length2 = Tcl_NumUtfChars(string2, length2); | ||
| length = (length1 < length2) ? length1 : length2; | ||
| /* | ||
| * Do the reqlength check again, against 0 as well for | ||
| * the benfit of nocase | ||
| */ | ||
| if ((reqlength > 0) && (reqlength < length)) { | ||
| length = reqlength; | ||
| } else if (reqlength < 0) { | ||
| /* | ||
| * The requested length is negative, so we ignore it by | ||
| * setting it to the longer of the two lengths. | ||
| */ | ||
| reqlength = (length1 > length2) ? length1 : length2; | ||
| } | ||
| if (nocase) { | ||
| match = Tcl_UtfNcasecmp(string1, string2, | ||
| (unsigned) length); | ||
| } else { | ||
| match = Tcl_UtfNcmp(string1, string2, (unsigned) length); | ||
| } | ||
| if ((match == 0) && (reqlength > length)) { | ||
| match = length1 - length2; | ||
| } | ||
| } else { | ||
| match = memcmp(string1, string2, (unsigned) length); | ||
| if (match == 0) { | ||
| match = length1 - length2; | ||
| } | ||
| } | ||
| if ((enum options) index == STR_EQUAL) { | ||
| Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1); | ||
| } else { | ||
| Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 : | ||
| (match < 0) ? -1 : 0)); | ||
| } | ||
| break; | ||
| } | ||
| case STR_FIRST: { | ||
| register char *p, *end; | ||
| int match, utflen, start; | ||
| if (objc < 4 || objc > 5) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, | ||
| "string1 string2 ?startIndex?"); | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * This algorithm fails on improperly formed UTF strings. | ||
| * We are searching string2 for the sequence string1. | ||
| */ | ||
| match = -1; | ||
| start = 0; | ||
| utflen = -1; | ||
| string1 = Tcl_GetStringFromObj(objv[2], &length1); | ||
| string2 = Tcl_GetStringFromObj(objv[3], &length2); | ||
| if (objc == 5) { | ||
| /* | ||
| * If a startIndex is specified, we will need to fast forward | ||
| * to that point in the string before we think about a match | ||
| */ | ||
| utflen = Tcl_NumUtfChars(string2, length2); | ||
| if (TclGetIntForIndex(interp, objv[4], utflen-1, | ||
| &start) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (start >= utflen) { | ||
| goto str_first_done; | ||
| } else if (start > 0) { | ||
| if (length2 == utflen) { | ||
| /* no unicode chars */ | ||
| string2 += start; | ||
| length2 -= start; | ||
| } else { | ||
| char *s = Tcl_UtfAtIndex(string2, start); | ||
| length2 -= s - string2; | ||
| string2 = s; | ||
| } | ||
| } | ||
| } | ||
| 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; | ||
| } | ||
| } | ||
| } | ||
| /* | ||
| * Compute the character index of the matching string by | ||
| * counting the number of characters before the match. | ||
| */ | ||
| str_first_done: | ||
| if (match != -1) { | ||
| if (objc == 4) { | ||
| match = Tcl_NumUtfChars(string2, match); | ||
| } else if (length2 == utflen) { | ||
| /* no unicode chars */ | ||
| match += start; | ||
| } else { | ||
| match = start + Tcl_NumUtfChars(string2, match); | ||
| } | ||
| } | ||
| Tcl_SetIntObj(resultPtr, match); | ||
| break; | ||
| } | ||
| case STR_INDEX: { | ||
| char buf[TCL_UTF_MAX]; | ||
| Tcl_UniChar unichar; | ||
| if (objc != 4) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * If we have a ByteArray object, avoid indexing in the | ||
| * Utf string since the byte array contains one byte per | ||
| * character. Otherwise, use the Unicode string rep to | ||
| * get the index'th char. | ||
| */ | ||
| if (objv[2]->typePtr == &tclByteArrayType) { | ||
| string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1); | ||
| if (TclGetIntForIndex(interp, objv[3], length1 - 1, | ||
| &index) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| Tcl_SetByteArrayObj(resultPtr, | ||
| (unsigned char *)(&string1[index]), 1); | ||
| } else { | ||
| string1 = Tcl_GetStringFromObj(objv[2], &length1); | ||
| /* | ||
| * convert to Unicode internal rep to calulate what | ||
| * 'end' really means. | ||
| */ | ||
| length2 = Tcl_GetCharLength(objv[2]); | ||
| if (TclGetIntForIndex(interp, objv[3], length2 - 1, | ||
| &index) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if ((index >= 0) && (index < length2)) { | ||
| unichar = Tcl_GetUniChar(objv[2], index); | ||
| length2 = Tcl_UniCharToUtf((int)unichar, buf); | ||
| Tcl_SetStringObj(resultPtr, buf, length2); | ||
| } | ||
| } | ||
| break; | ||
| } | ||
| case STR_IS: { | ||
| char *end; | ||
| Tcl_UniChar ch; | ||
| /* | ||
| * The UniChar comparison function | ||
| */ | ||
| int (*chcomp)_ANSI_ARGS_((int)) = NULL; | ||
| int i, failat = 0, result = 1, strict = 0; | ||
| Tcl_Obj *objPtr, *failVarObj = NULL; | ||
| static char *isOptions[] = { | ||
| "alnum", "alpha", "ascii", "control", | ||
| "boolean", "digit", "double", "false", | ||
| "graph", "integer", "lower", "print", | ||
| "punct", "space", "true", "upper", | ||
| "wordchar", "xdigit", (char *) NULL | ||
| }; | ||
| enum isOptions { | ||
| STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, | ||
| STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE, | ||
| STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT, | ||
| STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, | ||
| STR_IS_WORD, STR_IS_XDIGIT | ||
| }; | ||
| if (objc < 4 || objc > 7) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, | ||
| "class ?-strict? ?-failindex var? str"); | ||
| return TCL_ERROR; | ||
| } | ||
| if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0, | ||
| &index) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (objc != 4) { | ||
| for (i = 3; i < objc-1; i++) { | ||
| string2 = Tcl_GetStringFromObj(objv[i], &length2); | ||
| if ((length2 > 1) && | ||
| strncmp(string2, "-strict", (size_t) length2) == 0) { | ||
| strict = 1; | ||
| } else if ((length2 > 1) && | ||
| strncmp(string2, "-failindex", (size_t) length2) == 0) { | ||
| if (i+1 >= objc-1) { | ||
| Tcl_WrongNumArgs(interp, 3, objv, | ||
| "?-strict? ?-failindex var? str"); | ||
| return TCL_ERROR; | ||
| } | ||
| failVarObj = objv[++i]; | ||
| } else { | ||
| Tcl_AppendStringsToObj(resultPtr, "bad option \"", | ||
| string2, "\": must be -strict or -failindex", | ||
| (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| } | ||
| } | ||
| /* | ||
| * We get the objPtr so that we can short-cut for some classes | ||
| * by checking the object type (int and double), but we need | ||
| * the string otherwise, because we don't want any conversion | ||
| * of type occuring (as, for example, Tcl_Get*FromObj would do | ||
| */ | ||
| objPtr = objv[objc-1]; | ||
| string1 = Tcl_GetStringFromObj(objPtr, &length1); | ||
| if (length1 == 0) { | ||
| if (strict) { | ||
| result = 0; | ||
| } | ||
| goto str_is_done; | ||
| } | ||
| end = string1 + length1; | ||
| /* | ||
| * When entering here, result == 1 and failat == 0 | ||
| */ | ||
| switch ((enum isOptions) index) { | ||
| case STR_IS_ALNUM: | ||
| chcomp = Tcl_UniCharIsAlnum; | ||
| break; | ||
| case STR_IS_ALPHA: | ||
| chcomp = Tcl_UniCharIsAlpha; | ||
| break; | ||
| case STR_IS_ASCII: | ||
| for (; string1 < end; string1++, failat++) { | ||
| /* | ||
| * This is a valid check in unicode, because all | ||
| * bytes < 0xC0 are single byte chars (but isascii | ||
| * limits that def'n to 0x80). | ||
| */ | ||
| if (*((unsigned char *)string1) >= 0x80) { | ||
| result = 0; | ||
| break; | ||
| } | ||
| } | ||
| break; | ||
| case STR_IS_BOOL: | ||
| case STR_IS_TRUE: | ||
| case STR_IS_FALSE: | ||
| if (objPtr->typePtr == &tclBooleanType) { | ||
| if ((((enum isOptions) index == STR_IS_TRUE) && | ||
| objPtr->internalRep.longValue == 0) || | ||
| (((enum isOptions) index == STR_IS_FALSE) && | ||
| objPtr->internalRep.longValue != 0)) { | ||
| result = 0; | ||
| } | ||
| } else if ((Tcl_GetBoolean(NULL, string1, &i) | ||
| == TCL_ERROR) || | ||
| (((enum isOptions) index == STR_IS_TRUE) && | ||
| i == 0) || | ||
| (((enum isOptions) index == STR_IS_FALSE) && | ||
| i != 0)) { | ||
| result = 0; | ||
| } | ||
| break; | ||
| case STR_IS_CONTROL: | ||
| chcomp = Tcl_UniCharIsControl; | ||
| break; | ||
| case STR_IS_DIGIT: | ||
| chcomp = Tcl_UniCharIsDigit; | ||
| break; | ||
| case STR_IS_DOUBLE: { | ||
| char *stop; | ||
| if ((objPtr->typePtr == &tclDoubleType) || | ||
| (objPtr->typePtr == &tclIntType)) { | ||
| break; | ||
| } | ||
| /* | ||
| * This is adapted from Tcl_GetDouble | ||
| * | ||
| * The danger in this function is that | ||
| * "12345678901234567890" is an acceptable 'double', | ||
| * but will later be interp'd as an int by something | ||
| * like [expr]. Therefore, we check to see if it looks | ||
| * like an int, and if so we do a range check on it. | ||
| * If strtoul gets to the end, we know we either | ||
| * received an acceptable int, or over/underflow | ||
| */ | ||
| if (TclLooksLikeInt(string1, length1)) { | ||
| errno = 0; | ||
| strtoul(string1, &stop, 0); | ||
| if (stop == end) { | ||
| if (errno == ERANGE) { | ||
| result = 0; | ||
| failat = -1; | ||
| } | ||
| break; | ||
| } | ||
| } | ||
| errno = 0; | ||
| strtod(string1, &stop); /* INTL: Tcl source. */ | ||
| if (errno == ERANGE) { | ||
| /* | ||
| * if (errno == ERANGE), then it was an over/underflow | ||
| * problem, but in this method, we only want to know | ||
| * yes or no, so bad flow returns 0 (false) and sets | ||
| * the failVarObj to the string length. | ||
| */ | ||
| result = 0; | ||
| failat = -1; | ||
| } else if (stop == string1) { | ||
| /* | ||
| * In this case, nothing like a number was found | ||
| */ | ||
| result = 0; | ||
| failat = 0; | ||
| } else { | ||
| /* | ||
| * Assume we sucked up one char per byte | ||
| * and then we go onto SPACE, since we are | ||
| * allowed trailing whitespace | ||
| */ | ||
| failat = stop - string1; | ||
| string1 = stop; | ||
| chcomp = Tcl_UniCharIsSpace; | ||
| } | ||
| break; | ||
| } | ||
| case STR_IS_GRAPH: | ||
| chcomp = Tcl_UniCharIsGraph; | ||
| break; | ||
| case STR_IS_INT: { | ||
| char *stop; | ||
| if ((objPtr->typePtr == &tclIntType) || | ||
| (Tcl_GetInt(NULL, string1, &i) == TCL_OK)) { | ||
| break; | ||
| } | ||
| /* | ||
| * Like STR_IS_DOUBLE, but we use strtoul. | ||
| * Since Tcl_GetInt already failed, we set result to 0. | ||
| */ | ||
| result = 0; | ||
| errno = 0; | ||
| strtoul(string1, &stop, 0); /* INTL: Tcl source. */ | ||
| if (errno == ERANGE) { | ||
| /* | ||
| * if (errno == ERANGE), then it was an over/underflow | ||
| * problem, but in this method, we only want to know | ||
| * yes or no, so bad flow returns 0 (false) and sets | ||
| * the failVarObj to the string length. | ||
| */ | ||
| failat = -1; | ||
| } else if (stop == string1) { | ||
| /* | ||
| * In this case, nothing like a number was found | ||
| */ | ||
| failat = 0; | ||
| } else { | ||
| /* | ||
| * Assume we sucked up one char per byte | ||
| * and then we go onto SPACE, since we are | ||
| * allowed trailing whitespace | ||
| */ | ||
| failat = stop - string1; | ||
| string1 = stop; | ||
| chcomp = Tcl_UniCharIsSpace; | ||
| } | ||
| break; | ||
| } | ||
| case STR_IS_LOWER: | ||
| chcomp = Tcl_UniCharIsLower; | ||
| break; | ||
| case STR_IS_PRINT: | ||
| chcomp = Tcl_UniCharIsPrint; | ||
| break; | ||
| case STR_IS_PUNCT: | ||
| chcomp = Tcl_UniCharIsPunct; | ||
| break; | ||
| case STR_IS_SPACE: | ||
| chcomp = Tcl_UniCharIsSpace; | ||
| break; | ||
| case STR_IS_UPPER: | ||
| chcomp = Tcl_UniCharIsUpper; | ||
| break; | ||
| case STR_IS_WORD: | ||
| chcomp = Tcl_UniCharIsWordChar; | ||
| break; | ||
| case STR_IS_XDIGIT: { | ||
| for (; string1 < end; string1++, failat++) { | ||
| /* INTL: We assume unicode is bad for this class */ | ||
| if ((*((unsigned char *)string1) >= 0xC0) || | ||
| !isxdigit(*(unsigned char *)string1)) { | ||
| result = 0; | ||
| break; | ||
| } | ||
| } | ||
| break; | ||
| } | ||
| } | ||
| if (chcomp != NULL) { | ||
| for (; string1 < end; string1 += length2, failat++) { | ||
| length2 = Tcl_UtfToUniChar(string1, &ch); | ||
| if (!chcomp(ch)) { | ||
| result = 0; | ||
| break; | ||
| } | ||
| } | ||
| } | ||
| str_is_done: | ||
| /* | ||
| * Only set the failVarObj when we will return 0 | ||
| * and we have indicated a valid fail index (>= 0) | ||
| */ | ||
| if ((result == 0) && (failVarObj != NULL) && | ||
| Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), | ||
| TCL_LEAVE_ERR_MSG) == NULL) { | ||
| return TCL_ERROR; | ||
| } | ||
| Tcl_SetBooleanObj(resultPtr, result); | ||
| break; | ||
| } | ||
| case STR_LAST: { | ||
| register char *p; | ||
| int match, utflen, start; | ||
| if (objc < 4 || objc > 5) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, | ||
| "string1 string2 ?startIndex?"); | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * This algorithm fails on improperly formed UTF strings. | ||
| */ | ||
| match = -1; | ||
| start = 0; | ||
| utflen = -1; | ||
| string1 = Tcl_GetStringFromObj(objv[2], &length1); | ||
| string2 = Tcl_GetStringFromObj(objv[3], &length2); | ||
| if (objc == 5) { | ||
| /* | ||
| * If a startIndex is specified, we will need to restrict | ||
| * the string range to that char index in the string | ||
| */ | ||
| utflen = Tcl_NumUtfChars(string2, length2); | ||
| if (TclGetIntForIndex(interp, objv[4], utflen-1, | ||
| &start) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (start < 0) { | ||
| goto str_last_done; | ||
| } else if (start < utflen) { | ||
| if (length2 == utflen) { | ||
| /* no unicode chars */ | ||
| p = string2 + start + 1 - length1; | ||
| } else { | ||
| p = Tcl_UtfAtIndex(string2, start+1) - length1; | ||
| } | ||
| } else { | ||
| p = string2 + length2 - length1; | ||
| } | ||
| } else { | ||
| p = string2 + length2 - length1; | ||
| } | ||
| if (length1 > 0) { | ||
| for (; p >= string2; p--) { | ||
| /* | ||
| * Scan backwards to find the first character. | ||
| */ | ||
| while ((p != string2) && (*p != *string1)) { | ||
| p--; | ||
| } | ||
| 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. | ||
| */ | ||
| str_last_done: | ||
| if (match != -1) { | ||
| if ((objc == 4) || (length2 != utflen)) { | ||
| /* only check when we've got unicode chars */ | ||
| match = Tcl_NumUtfChars(string2, match); | ||
| } | ||
| } | ||
| Tcl_SetIntObj(resultPtr, match); | ||
| break; | ||
| } | ||
| case STR_BYTELENGTH: | ||
| case STR_LENGTH: { | ||
| if (objc != 3) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, "string"); | ||
| return TCL_ERROR; | ||
| } | ||
| if ((enum options) index == STR_BYTELENGTH) { | ||
| (void) Tcl_GetStringFromObj(objv[2], &length1); | ||
| Tcl_SetIntObj(resultPtr, length1); | ||
| } else { | ||
| /* | ||
| * If we have a ByteArray object, avoid recomputing the | ||
| * string since the byte array contains one byte per | ||
| * character. Otherwise, use the Unicode string rep to | ||
| * calculate the length. | ||
| */ | ||
| if (objv[2]->typePtr == &tclByteArrayType) { | ||
| (void) Tcl_GetByteArrayFromObj(objv[2], &length1); | ||
| Tcl_SetIntObj(resultPtr, length1); | ||
| } else { | ||
| Tcl_SetIntObj(resultPtr, | ||
| Tcl_GetCharLength(objv[2])); | ||
| } | ||
| } | ||
| break; | ||
| } | ||
| case STR_MAP: { | ||
| int uselen, mapElemc, len, nocase = 0; | ||
| Tcl_Obj **mapElemv; | ||
| char *end; | ||
| Tcl_UniChar ch; | ||
| int (*str_comp_fn)(); | ||
| if (objc < 4 || objc > 5) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string"); | ||
| return TCL_ERROR; | ||
| } | ||
| if (objc == 5) { | ||
| string2 = Tcl_GetStringFromObj(objv[2], &length2); | ||
| if ((length2 > 1) && | ||
| strncmp(string2, "-nocase", (size_t) length2) == 0) { | ||
| nocase = 1; | ||
| } else { | ||
| Tcl_AppendStringsToObj(resultPtr, "bad option \"", | ||
| string2, "\": must be -nocase", | ||
| (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| } | ||
| if (Tcl_ListObjGetElements(interp, objv[objc-2], &mapElemc, | ||
| &mapElemv) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (mapElemc == 0) { | ||
| /* | ||
| * empty charMap, just return whatever string was given | ||
| */ | ||
| Tcl_SetObjResult(interp, objv[objc-1]); | ||
| } else if (mapElemc & 1) { | ||
| /* | ||
| * The charMap must be an even number of key/value items | ||
| */ | ||
| Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1); | ||
| return TCL_ERROR; | ||
| } | ||
| string1 = Tcl_GetStringFromObj(objv[objc-1], &length1); | ||
| if (length1 == 0) { | ||
| break; | ||
| } | ||
| end = string1 + length1; | ||
| if (nocase) { | ||
| length1 = Tcl_NumUtfChars(string1, length1); | ||
| str_comp_fn = Tcl_UtfNcasecmp; | ||
| } else { | ||
| str_comp_fn = memcmp; | ||
| } | ||
| for ( ; string1 < end; string1 += len) { | ||
| len = Tcl_UtfToUniChar(string1, &ch); | ||
| for (index = 0; index < mapElemc; index +=2) { | ||
| /* | ||
| * Get the key string to match on | ||
| */ | ||
| string2 = Tcl_GetStringFromObj(mapElemv[index], | ||
| &length2); | ||
| if (nocase) { | ||
| uselen = Tcl_NumUtfChars(string2, length2); | ||
| } else { | ||
| uselen = length2; | ||
| } | ||
| if ((uselen > 0) && (uselen <= length1) && | ||
| (str_comp_fn(string2, string1, uselen) == 0)) { | ||
| /* | ||
| * Adjust len to be full length of matched string | ||
| * it has to be the BYTE length | ||
| */ | ||
| len = length2; | ||
| /* | ||
| * Change string2 and length2 to the map value | ||
| */ | ||
| string2 = Tcl_GetStringFromObj(mapElemv[index+1], | ||
| &length2); | ||
| Tcl_AppendToObj(resultPtr, string2, length2); | ||
| break; | ||
| } | ||
| } | ||
| if (index == mapElemc) { | ||
| /* | ||
| * No match was found, put the char onto result | ||
| */ | ||
| Tcl_AppendToObj(resultPtr, string1, len); | ||
| } | ||
| /* | ||
| * in nocase, length1 is in chars | ||
| * otherwise it is in bytes | ||
| */ | ||
| if (nocase) { | ||
| length1--; | ||
| } else { | ||
| length1 -= len; | ||
| } | ||
| } | ||
| break; | ||
| } | ||
| case STR_MATCH: { | ||
| int nocase = 0; | ||
| if (objc < 4 || objc > 5) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string"); | ||
| return TCL_ERROR; | ||
| } | ||
| if (objc == 5) { | ||
| string2 = Tcl_GetStringFromObj(objv[2], &length2); | ||
| if ((length2 > 1) && | ||
| strncmp(string2, "-nocase", (size_t) length2) == 0) { | ||
| nocase = 1; | ||
| } else { | ||
| Tcl_AppendStringsToObj(resultPtr, "bad option \"", | ||
| string2, "\": must be -nocase", | ||
| (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| } | ||
| Tcl_SetBooleanObj(resultPtr, | ||
| Tcl_StringCaseMatch(Tcl_GetString(objv[objc-1]), | ||
| Tcl_GetString(objv[objc-2]), | ||
| nocase)); | ||
| break; | ||
| } | ||
| case STR_RANGE: { | ||
| int first, last; | ||
| if (objc != 5) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, "string first last"); | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * If we have a ByteArray object, avoid indexing in the | ||
| * Utf string since the byte array contains one byte per | ||
| * character. Otherwise, use the Unicode string rep to | ||
| * get the range. | ||
| */ | ||
| if (objv[2]->typePtr == &tclByteArrayType) { | ||
| string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1); | ||
| if (TclGetIntForIndex(interp, objv[3], length1 - 1, | ||
| &first) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (TclGetIntForIndex(interp, objv[4], length1 - 1, | ||
| &last) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (first < 0) { | ||
| first = 0; | ||
| } | ||
| if (last >= length1 - 1) { | ||
| last = length1 - 1; | ||
| } | ||
| if (last >= first) { | ||
| int numBytes = last - first + 1; | ||
| resultPtr = Tcl_NewByteArrayObj( | ||
| (unsigned char *) &string1[first], numBytes); | ||
| Tcl_SetObjResult(interp, resultPtr); | ||
| } | ||
| } else { | ||
| string1 = Tcl_GetStringFromObj(objv[2], &length1); | ||
| /* | ||
| * Convert to Unicode internal rep to calulate length and | ||
| * create a result object. | ||
| */ | ||
| length2 = Tcl_GetCharLength(objv[2]) - 1; | ||
| if (TclGetIntForIndex(interp, objv[3], length2, | ||
| &first) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (TclGetIntForIndex(interp, objv[4], length2, | ||
| &last) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (first < 0) { | ||
| first = 0; | ||
| } | ||
| if (last >= length2) { | ||
| last = length2; | ||
| } | ||
| if (last >= first) { | ||
| resultPtr = Tcl_GetRange(objv[2], first, last); | ||
| Tcl_SetObjResult(interp, resultPtr); | ||
| } | ||
| } | ||
| break; | ||
| } | ||
| case STR_REPEAT: { | ||
| int count; | ||
| if (objc != 4) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, "string count"); | ||
| return TCL_ERROR; | ||
| } | ||
| if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| string1 = Tcl_GetStringFromObj(objv[2], &length1); | ||
| if (length1 > 0) { | ||
| for (index = 0; index < count; index++) { | ||
| Tcl_AppendToObj(resultPtr, string1, length1); | ||
| } | ||
| } | ||
| break; | ||
| } | ||
| case STR_REPLACE: { | ||
| int first, last; | ||
| if (objc < 5 || objc > 6) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, | ||
| "string first last ?string?"); | ||
| return TCL_ERROR; | ||
| } | ||
| string1 = Tcl_GetStringFromObj(objv[2], &length1); | ||
| length1 = Tcl_NumUtfChars(string1, length1) - 1; | ||
| if (TclGetIntForIndex(interp, objv[3], length1, | ||
| &first) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (TclGetIntForIndex(interp, objv[4], length1, | ||
| &last) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if ((last < first) || (first > length1) || (last < 0)) { | ||
| Tcl_SetObjResult(interp, objv[2]); | ||
| } else { | ||
| char *start, *end; | ||
| if (first < 0) { | ||
| first = 0; | ||
| } | ||
| start = Tcl_UtfAtIndex(string1, first); | ||
| end = Tcl_UtfAtIndex(start, ((last > length1) ? length1 : last) | ||
| - first + 1); | ||
| Tcl_SetStringObj(resultPtr, string1, start - string1); | ||
| if (objc == 6) { | ||
| Tcl_AppendObjToObj(resultPtr, objv[5]); | ||
| } | ||
| if (last < length1) { | ||
| Tcl_AppendToObj(resultPtr, end, -1); | ||
| } | ||
| } | ||
| break; | ||
| } | ||
| case STR_TOLOWER: | ||
| case STR_TOUPPER: | ||
| case STR_TOTITLE: | ||
| if (objc < 3 || objc > 5) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?"); | ||
| return TCL_ERROR; | ||
| } | ||
| string1 = Tcl_GetStringFromObj(objv[2], &length1); | ||
| if (objc == 3) { | ||
| /* | ||
| * Since the result object is not a shared object, it is | ||
| * safe to copy the string into the result and do the | ||
| * conversion in place. The conversion may change the length | ||
| * of the string, so reset the length after conversion. | ||
| */ | ||
| Tcl_SetStringObj(resultPtr, string1, length1); | ||
| if ((enum options) index == STR_TOLOWER) { | ||
| length1 = Tcl_UtfToLower(Tcl_GetString(resultPtr)); | ||
| } else if ((enum options) index == STR_TOUPPER) { | ||
| length1 = Tcl_UtfToUpper(Tcl_GetString(resultPtr)); | ||
| } else { | ||
| length1 = Tcl_UtfToTitle(Tcl_GetString(resultPtr)); | ||
| } | ||
| Tcl_SetObjLength(resultPtr, length1); | ||
| } else { | ||
| int first, last; | ||
| char *start, *end; | ||
| length1 = Tcl_NumUtfChars(string1, length1) - 1; | ||
| if (TclGetIntForIndex(interp, objv[3], length1, | ||
| &first) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (first < 0) { | ||
| first = 0; | ||
| } | ||
| last = first; | ||
| if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1, | ||
| &last) != TCL_OK)) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (last >= length1) { | ||
| last = length1; | ||
| } | ||
| if (last < first) { | ||
| Tcl_SetObjResult(interp, objv[2]); | ||
| break; | ||
| } | ||
| start = Tcl_UtfAtIndex(string1, first); | ||
| end = Tcl_UtfAtIndex(start, last - first + 1); | ||
| length2 = end-start; | ||
| string2 = ckalloc((size_t) length2+1); | ||
| memcpy(string2, start, (size_t) length2); | ||
| string2[length2] = '\0'; | ||
| if ((enum options) index == STR_TOLOWER) { | ||
| length2 = Tcl_UtfToLower(string2); | ||
| } else if ((enum options) index == STR_TOUPPER) { | ||
| length2 = Tcl_UtfToUpper(string2); | ||
| } else { | ||
| length2 = Tcl_UtfToTitle(string2); | ||
| } | ||
| Tcl_SetStringObj(resultPtr, string1, start - string1); | ||
| Tcl_AppendToObj(resultPtr, string2, length2); | ||
| Tcl_AppendToObj(resultPtr, end, -1); | ||
| ckfree(string2); | ||
| } | ||
| break; | ||
| case STR_TRIM: { | ||
| Tcl_UniChar ch, trim; | ||
| register char *p, *end; | ||
| char *check, *checkEnd; | ||
| int offset; | ||
| left = 1; | ||
| right = 1; | ||
| dotrim: | ||
| if (objc == 4) { | ||
| string2 = Tcl_GetStringFromObj(objv[3], &length2); | ||
| } else if (objc == 3) { | ||
| string2 = " \t\n\r"; | ||
| length2 = strlen(string2); | ||
| } else { | ||
| Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?"); | ||
| return TCL_ERROR; | ||
| } | ||
| string1 = Tcl_GetStringFromObj(objv[2], &length1); | ||
| checkEnd = string2 + length2; | ||
| if (left) { | ||
| end = string1 + length1; | ||
| /* | ||
| * The outer loop iterates over the string. The inner | ||
| * loop iterates over the trim characters. The loops | ||
| * terminate as soon as a non-trim character is discovered | ||
| * and string1 is left pointing at the first non-trim | ||
| * character. | ||
| */ | ||
| for (p = string1; p < end; p += offset) { | ||
| offset = Tcl_UtfToUniChar(p, &ch); | ||
| for (check = string2; ; ) { | ||
| if (check >= checkEnd) { | ||
| p = end; | ||
| break; | ||
| } | ||
| check += Tcl_UtfToUniChar(check, &trim); | ||
| if (ch == trim) { | ||
| length1 -= offset; | ||
| string1 += offset; | ||
| break; | ||
| } | ||
| } | ||
| } | ||
| } | ||
| if (right) { | ||
| end = string1; | ||
| /* | ||
| * The outer loop iterates over the string. The inner | ||
| * loop iterates over the trim characters. The loops | ||
| * terminate as soon as a non-trim character is discovered | ||
| * and length1 marks the last non-trim character. | ||
| */ | ||
| for (p = string1 + length1; p > end; ) { | ||
| p = Tcl_UtfPrev(p, string1); | ||
| offset = Tcl_UtfToUniChar(p, &ch); | ||
| for (check = string2; ; ) { | ||
| if (check >= checkEnd) { | ||
| p = end; | ||
| break; | ||
| } | ||
| check += Tcl_UtfToUniChar(check, &trim); | ||
| if (ch == trim) { | ||
| length1 -= offset; | ||
| break; | ||
| } | ||
| } | ||
| } | ||
| } | ||
| Tcl_SetStringObj(resultPtr, string1, length1); | ||
| break; | ||
| } | ||
| case STR_TRIMLEFT: { | ||
| left = 1; | ||
| right = 0; | ||
| goto dotrim; | ||
| } | ||
| case STR_TRIMRIGHT: { | ||
| left = 0; | ||
| right = 1; | ||
| goto dotrim; | ||
| } | ||
| case STR_WORDEND: { | ||
| int cur; | ||
| Tcl_UniChar ch; | ||
| char *p, *end; | ||
| int numChars; | ||
| if (objc != 4) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, "string index"); | ||
| return TCL_ERROR; | ||
| } | ||
| string1 = Tcl_GetStringFromObj(objv[2], &length1); | ||
| numChars = Tcl_NumUtfChars(string1, length1); | ||
| if (TclGetIntForIndex(interp, objv[3], numChars-1, | ||
| &index) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (index < 0) { | ||
| index = 0; | ||
| } | ||
| if (index < numChars) { | ||
| p = Tcl_UtfAtIndex(string1, index); | ||
| end = string1+length1; | ||
| for (cur = index; p < end; cur++) { | ||
| p += Tcl_UtfToUniChar(p, &ch); | ||
| if (!Tcl_UniCharIsWordChar(ch)) { | ||
| break; | ||
| } | ||
| } | ||
| if (cur == index) { | ||
| cur++; | ||
| } | ||
| } else { | ||
| cur = numChars; | ||
| } | ||
| Tcl_SetIntObj(resultPtr, cur); | ||
| break; | ||
| } | ||
| case STR_WORDSTART: { | ||
| int cur; | ||
| Tcl_UniChar ch; | ||
| char *p; | ||
| int numChars; | ||
| if (objc != 4) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, "string index"); | ||
| return TCL_ERROR; | ||
| } | ||
| string1 = Tcl_GetStringFromObj(objv[2], &length1); | ||
| numChars = Tcl_NumUtfChars(string1, length1); | ||
| if (TclGetIntForIndex(interp, objv[3], numChars-1, | ||
| &index) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (index >= numChars) { | ||
| index = numChars - 1; | ||
| } | ||
| cur = 0; | ||
| if (index > 0) { | ||
| p = Tcl_UtfAtIndex(string1, index); | ||
| for (cur = index; cur >= 0; cur--) { | ||
| Tcl_UtfToUniChar(p, &ch); | ||
| if (!Tcl_UniCharIsWordChar(ch)) { | ||
| break; | ||
| } | ||
| p = Tcl_UtfPrev(p, string1); | ||
| } | ||
| if (cur != index) { | ||
| cur += 1; | ||
| } | ||
| } | ||
| Tcl_SetIntObj(resultPtr, cur); | ||
| break; | ||
| } | ||
| } | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_SubstObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "subst" Tcl command. | ||
| * See the user documentation for details on what it does. This | ||
| * command is an almost direct copy of an implementation by | ||
| * Andrew Payne. | ||
| * | ||
| * Results: | ||
| * A standard Tcl result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_SubstObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| static 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 optionIndex, code, count, doVars, doCmds, doBackslashes, i; | ||
| /* | ||
| * Parse command-line options. | ||
| */ | ||
| doVars = doCmds = doBackslashes = 1; | ||
| for (i = 1; i < (objc-1); i++) { | ||
| p = Tcl_GetString(objv[i]); | ||
| if (*p != '-') { | ||
| break; | ||
| } | ||
| if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, | ||
| "switch", 0, &optionIndex) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| 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 != (objc-1)) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, | ||
| "?-nobackslashes? ?-nocommands? ?-novariables? string"); | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * Scan through the string one character at a time, performing | ||
| * command, variable, and backslash substitutions. | ||
| */ | ||
| Tcl_DStringInit(&result); | ||
| 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); | ||
| } | ||
| Tcl_DStringAppend(&result, buf, | ||
| Tcl_UtfBackslash(p, &count, buf)); | ||
| p += count; | ||
| old = p; | ||
| } else { | ||
| p++; | ||
| } | ||
| break; | ||
| case '$': | ||
| if (doVars) { | ||
| if (p != old) { | ||
| Tcl_DStringAppend(&result, old, p-old); | ||
| } | ||
| value = Tcl_ParseVar(interp, p, &p); | ||
| if (value == NULL) { | ||
| Tcl_DStringFree(&result); | ||
| return TCL_ERROR; | ||
| } | ||
| Tcl_DStringAppend(&result, value, -1); | ||
| old = p; | ||
| } else { | ||
| p++; | ||
| } | ||
| break; | ||
| case '[': | ||
| if (doCmds) { | ||
| if (p != old) { | ||
| Tcl_DStringAppend(&result, old, p-old); | ||
| } | ||
| iPtr->evalFlags = TCL_BRACKET_TERM; | ||
| code = Tcl_Eval(interp, p+1); | ||
| if (code == TCL_ERROR) { | ||
| Tcl_DStringFree(&result); | ||
| return code; | ||
| } | ||
| old = p = (p+1 + iPtr->termOffset+1); | ||
| Tcl_DStringAppend(&result, iPtr->result, -1); | ||
| Tcl_ResetResult(interp); | ||
| } else { | ||
| p++; | ||
| } | ||
| break; | ||
| default: | ||
| p++; | ||
| break; | ||
| } | ||
| } | ||
| if (p != old) { | ||
| Tcl_DStringAppend(&result, old, p-old); | ||
| } | ||
| Tcl_DStringResult(interp, &result); | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_SwitchObjCmd -- | ||
| * | ||
| * This object-based procedure is invoked to process the "switch" Tcl | ||
| * command. See the user documentation for details on what it does. | ||
| * | ||
| * Results: | ||
| * A standard Tcl object result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_SwitchObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| int i, j, index, mode, matched, result, splitObjs, seenComment; | ||
| char *string, *pattern; | ||
| Tcl_Obj *stringObj; | ||
| 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, objv[i], options, "option", 0, | ||
| &index) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| if (index == OPT_LAST) { | ||
| i++; | ||
| break; | ||
| } | ||
| mode = index; | ||
| } | ||
| if (objc - i < 2) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, | ||
| "?switches? string pattern body ... ?default body?"); | ||
| return TCL_ERROR; | ||
| } | ||
| stringObj = objv[i]; | ||
| objc -= i + 1; | ||
| objv += i + 1; | ||
| /* | ||
| * If all of the pattern/command pairs are lumped into a single | ||
| * argument, split them out again. | ||
| */ | ||
| splitObjs = 0; | ||
| if (objc == 1) { | ||
| Tcl_Obj **listv; | ||
| if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| objv = listv; | ||
| splitObjs = 1; | ||
| } | ||
| seenComment = 0; | ||
| 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); | ||
| /* | ||
| * Check if this can be due to a badly placed comment | ||
| * in the switch block | ||
| */ | ||
| if (splitObjs && seenComment) { | ||
| Tcl_AppendToObj(Tcl_GetObjResult(interp), | ||
| ", this may be due to a comment incorrectly placed outside of a switch body - see the \"switch\" documentation", -1); | ||
| } | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| * See if the pattern matches the string. | ||
| */ | ||
| pattern = Tcl_GetString(objv[i]); | ||
| /* | ||
| * The following is an heuristic to detect the infamous | ||
| * "comment in switch" error: just check if a pattern | ||
| * begins with '#'. | ||
| */ | ||
| if (splitObjs && *pattern == '#') { | ||
| seenComment = 1; | ||
| } | ||
| matched = 0; | ||
| if ((i == objc - 2) | ||
| && (*pattern == 'd') | ||
| && (strcmp(pattern, "default") == 0)) { | ||
| matched = 1; | ||
| } else { | ||
| switch (mode) { | ||
| case OPT_EXACT: | ||
| matched = (strcmp(Tcl_GetString(stringObj), pattern) == 0); | ||
| break; | ||
| case OPT_GLOB: | ||
| matched = Tcl_StringMatch(Tcl_GetString(stringObj), | ||
| pattern); | ||
| break; | ||
| case OPT_REGEXP: | ||
| matched = Tcl_RegExpMatchObj(interp, stringObj, objv[i]); | ||
| if (matched < 0) { | ||
| return TCL_ERROR; | ||
| } | ||
| break; | ||
| } | ||
| } | ||
| if (matched == 0) { | ||
| continue; | ||
| } | ||
| /* | ||
| * We've got a match. Find a body to execute, skipping bodies | ||
| * that are "-". | ||
| */ | ||
| for (j = i + 1; ; j += 2) { | ||
| if (j >= objc) { | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | ||
| "no body specified for pattern \"", pattern, | ||
| "\"", (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| if (strcmp(Tcl_GetString(objv[j]), "-") != 0) { | ||
| break; | ||
| } | ||
| } | ||
| result = Tcl_EvalObjEx(interp, objv[j], 0); | ||
| if (result == TCL_ERROR) { | ||
| char msg[100 + TCL_INTEGER_SPACE]; | ||
| sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern, | ||
| interp->errorLine); | ||
| Tcl_AddObjErrorInfo(interp, msg, -1); | ||
| } | ||
| return result; | ||
| } | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_TimeObjCmd -- | ||
| * | ||
| * This object-based procedure is invoked to process the "time" Tcl | ||
| * command. See the user documentation for details on what it does. | ||
| * | ||
| * Results: | ||
| * A standard Tcl object result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_TimeObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| register Tcl_Obj *objPtr; | ||
| register int i, result; | ||
| int count; | ||
| double totalMicroSec; | ||
| Tcl_Time start, stop; | ||
| char buf[100]; | ||
| if (objc == 2) { | ||
| count = 1; | ||
| } else if (objc == 3) { | ||
| result = Tcl_GetIntFromObj(interp, objv[2], &count); | ||
| if (result != TCL_OK) { | ||
| return result; | ||
| } | ||
| } else { | ||
| Tcl_WrongNumArgs(interp, 1, objv, "command ?count?"); | ||
| return TCL_ERROR; | ||
| } | ||
| objPtr = objv[1]; | ||
| i = count; | ||
| TclpGetTime(&start); | ||
| while (i-- > 0) { | ||
| result = Tcl_EvalObjEx(interp, objPtr, 0); | ||
| if (result != TCL_OK) { | ||
| return result; | ||
| } | ||
| } | ||
| TclpGetTime(&stop); | ||
| totalMicroSec = | ||
| (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); | ||
| sprintf(buf, "%.0f microseconds per iteration", | ||
| ((count <= 0) ? 0 : totalMicroSec/count)); | ||
| Tcl_ResetResult(interp); | ||
| Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_TraceObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "trace" 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_TraceObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| int 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 (objc < 2) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, "option [arg arg ...]"); | ||
| return TCL_ERROR; | ||
| } | ||
| if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, | ||
| "option", 0, &optionIndex) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| switch ((enum traceOptions) optionIndex) { | ||
| case TRACE_VARIABLE: { | ||
| int flags; | ||
| TraceVarInfo *tvarPtr; | ||
| if (objc != 5) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); | ||
| 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; | ||
| } | ||
| 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; | ||
| strcpy(tvarPtr->command, command); | ||
| name = Tcl_GetString(objv[2]); | ||
| if (Tcl_TraceVar(interp, name, flags, TraceVarProc, | ||
| (ClientData) tvarPtr) != TCL_OK) { | ||
| ckfree((char *) tvarPtr); | ||
| return TCL_ERROR; | ||
| } | ||
| break; | ||
| } | ||
| case TRACE_VDELETE: { | ||
| int flags; | ||
| TraceVarInfo *tvarPtr; | ||
| ClientData clientData; | ||
| if (objc != 5) { | ||
| Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); | ||
| 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; | ||
| } | ||
| /* | ||
| * 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; | ||
| } | ||
| } | ||
| break; | ||
| } | ||
| 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; | ||
| } | ||
| default: { | ||
| panic("Tcl_TraceObjCmd: bad option index to TraceOptions"); | ||
| } | ||
| } | ||
| return TCL_OK; | ||
| badOps: | ||
| Tcl_AppendResult(interp, "bad operations \"", rwuOps, | ||
| "\": should be one or more of rwu", (char *) NULL); | ||
| return TCL_ERROR; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * TraceVarProc -- | ||
| * | ||
| * This procedure is called to handle variable accesses that have | ||
| * been traced using the "trace" command. | ||
| * | ||
| * Results: | ||
| * Normally returns NULL. If the trace command returns an error, | ||
| * then this procedure returns an error string. | ||
| * | ||
| * Side effects: | ||
| * Depends on the command associated with the trace. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| static char * | ||
| TraceVarProc(clientData, interp, name1, name2, flags) | ||
| ClientData clientData; /* Information about the variable trace. */ | ||
| Tcl_Interp *interp; /* Interpreter containing variable. */ | ||
| char *name1; /* Name of variable or array. */ | ||
| char *name2; /* Name of element within array; NULL means | ||
| * scalar variable is being referenced. */ | ||
| int flags; /* OR-ed bits giving operation and other | ||
| * information. */ | ||
| { | ||
| Tcl_SavedResult state; | ||
| TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; | ||
| char *result; | ||
| int code; | ||
| Tcl_DString cmd; | ||
| result = NULL; | ||
| if (tvarPtr->errMsg != NULL) { | ||
| ckfree(tvarPtr->errMsg); | ||
| tvarPtr->errMsg = NULL; | ||
| } | ||
| if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { | ||
| /* | ||
| * Generate a command to execute by appending list elements | ||
| * for the two variable names and the operation. The five | ||
| * extra characters are for three space, the opcode character, | ||
| * and the terminating null. | ||
| */ | ||
| if (name2 == NULL) { | ||
| name2 = ""; | ||
| } | ||
| Tcl_DStringInit(&cmd); | ||
| Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); | ||
| Tcl_DStringAppendElement(&cmd, name1); | ||
| Tcl_DStringAppendElement(&cmd, name2); | ||
| if (flags & TCL_TRACE_READS) { | ||
| Tcl_DStringAppend(&cmd, " r", 2); | ||
| } else if (flags & TCL_TRACE_WRITES) { | ||
| Tcl_DStringAppend(&cmd, " w", 2); | ||
| } else if (flags & TCL_TRACE_UNSETS) { | ||
| Tcl_DStringAppend(&cmd, " u", 2); | ||
| } | ||
| /* | ||
| * Execute the command. Save the interp's result used for | ||
| * the command. We discard any object result the command returns. | ||
| */ | ||
| Tcl_SaveResult(interp, &state); | ||
| code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); | ||
| if (code != TCL_OK) { /* copy error msg to 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_RestoreResult(interp, &state); | ||
| Tcl_DStringFree(&cmd); | ||
| } | ||
| if (flags & TCL_TRACE_DESTROYED) { | ||
| result = NULL; | ||
| if (tvarPtr->errMsg != NULL) { | ||
| ckfree(tvarPtr->errMsg); | ||
| } | ||
| ckfree((char *) tvarPtr); | ||
| } | ||
| return result; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_WhileObjCmd -- | ||
| * | ||
| * This procedure is invoked to process the "while" Tcl command. | ||
| * See the user documentation for details on what it does. | ||
| * | ||
| * With the bytecode compiler, this procedure is only called when | ||
| * a command name is computed at runtime, and is "while" or the name | ||
| * to which "while" was renamed: e.g., "set z while; $z {$i<100} {}" | ||
| * | ||
| * Results: | ||
| * A standard Tcl result. | ||
| * | ||
| * Side effects: | ||
| * See the user documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| /* ARGSUSED */ | ||
| int | ||
| Tcl_WhileObjCmd(dummy, interp, objc, objv) | ||
| ClientData dummy; /* Not used. */ | ||
| Tcl_Interp *interp; /* Current interpreter. */ | ||
| int objc; /* Number of arguments. */ | ||
| Tcl_Obj *CONST objv[]; /* Argument objects. */ | ||
| { | ||
| int result, value; | ||
| if (objc != 3) { | ||
| Tcl_WrongNumArgs(interp, 1, objv, "test command"); | ||
| return TCL_ERROR; | ||
| } | ||
| while (1) { | ||
| result = Tcl_ExprBooleanObj(interp, objv[1], &value); | ||
| if (result != TCL_OK) { | ||
| return result; | ||
| } | ||
| if (!value) { | ||
| break; | ||
| } | ||
| result = Tcl_EvalObjEx(interp, objv[2], 0); | ||
| if ((result != TCL_OK) && (result != TCL_CONTINUE)) { | ||
| if (result == TCL_ERROR) { | ||
| char msg[32 + TCL_INTEGER_SPACE]; | ||
| sprintf(msg, "\n (\"while\" body line %d)", | ||
| interp->errorLine); | ||
| Tcl_AddErrorInfo(interp, msg); | ||
| } | ||
| break; | ||
| } | ||
| } | ||
| if (result == TCL_BREAK) { | ||
| result = TCL_OK; | ||
| } | ||
| if (result == TCL_OK) { | ||
| Tcl_ResetResult(interp); | ||
| } | ||
| return result; | ||
| } | ||
| /* $History: tclcmdmz.c $ | ||
| * | ||
| * ***************** Version 1 ***************** | ||
| * User: Dtashley Date: 1/02/01 Time: 1:28a | ||
| * Created in $/IjuScripter, IjuConsole/Source/Tcl Base | ||
| * Initial check-in. | ||
| */ | ||
| /* End of TCLCMDMZ.C */ | ||
| 1 | /* $Header$ */ | |
| 2 | /* | |
| 3 | * tclCmdMZ.c -- | |
| 4 | * | |
| 5 | * This file contains the top-level command routines for most of | |
| 6 | * the Tcl built-in commands whose names begin with the letters | |
| 7 | * M to Z. It contains only commands in the generic core (i.e. | |
| 8 | * those that don't depend much upon UNIX facilities). | |
| 9 | * | |
| 10 | * Copyright (c) 1987-1993 The Regents of the University of California. | |
| 11 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. | |
| 12 | * Copyright (c) 1998-1999 by Scriptics Corporation. | |
| 13 | * | |
| 14 | * See the file "license.terms" for information on usage and redistribution | |
| 15 | * of this file, and for a DISCLAIMER OF ALL WARRANTIES. | |
| 16 | * | |
| 17 | * RCS: @(#) $Id: tclcmdmz.c,v 1.1.1.1 2001/06/13 04:35:16 dtashley Exp $ | |
| 18 | */ | |
| 19 | ||
| 20 | #include "tclInt.h" | |
| 21 | #include "tclPort.h" | |
| 22 | #include "tclCompile.h" | |
| 23 | #include "tclRegexp.h" | |
| 24 | ||
| 25 | /* | |
| 26 | * Flag values used by Tcl_ScanObjCmd. | |
| 27 | */ | |
| 28 | ||
| 29 | #define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ | |
| 30 | #define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ | |
| 31 | #define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */ | |
| 32 | #define SCAN_WIDTH 0x8 /* A width value was supplied. */ | |
| 33 | ||
| 34 | #define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */ | |
| 35 | #define SCAN_NODIGITS 0x20 /* No digits have been scanned. */ | |
| 36 | #define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */ | |
| 37 | #define SCAN_XOK 0x80 /* An 'x' is allowed. */ | |
| 38 | #define SCAN_PTOK 0x100 /* Decimal point is allowed. */ | |
| 39 | #define SCAN_EXPOK 0x200 /* An exponent is allowed. */ | |
| 40 | ||
| 41 | /* | |
| 42 | * Structure used to hold information about variable traces: | |
| 43 | */ | |
| 44 | ||
| 45 | typedef struct { | |
| 46 | int flags; /* Operations for which Tcl command is | |
| 47 | * to be invoked. */ | |
| 48 | char *errMsg; /* Error message returned from Tcl command, | |
| 49 | * or NULL. Malloc'ed. */ | |
| 50 | size_t length; /* Number of non-NULL chars. in command. */ | |
| 51 | char command[4]; /* Space for Tcl command to invoke. Actual | |
| 52 | * size will be as large as necessary to | |
| 53 | * hold command. This field must be the | |
| 54 | * last in the structure, so that it can | |
| 55 | * be larger than 4 bytes. */ | |
| 56 | } TraceVarInfo; | |
| 57 | ||
| 58 | /* | |
| 59 | * Forward declarations for procedures defined in this file: | |
| 60 | */ | |
| 61 | ||
| 62 | static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, | |
| 63 | Tcl_Interp *interp, char *name1, char *name2, | |
| 64 | int flags)); | |
| 65 | ||
| 66 | /* | |
| 67 | *---------------------------------------------------------------------- | |
| 68 | * | |
| 69 | * Tcl_PwdObjCmd -- | |
| 70 | * | |
| 71 | * This procedure is invoked to process the "pwd" Tcl command. | |
| 72 | * See the user documentation for details on what it does. | |
| 73 | * | |
| 74 | * Results: | |
| 75 | * A standard Tcl result. | |
| 76 | * | |
| 77 | * Side effects: | |
| 78 | * See the user documentation. | |
| 79 | * | |
| 80 | *---------------------------------------------------------------------- | |
| 81 | */ | |
| 82 | ||
| 83 | /* ARGSUSED */ | |
| 84 | int | |
| 85 | Tcl_PwdObjCmd(dummy, interp, objc, objv) | |
| 86 | ClientData dummy; /* Not used. */ | |
| 87 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 88 | int objc; /* Number of arguments. */ | |
| 89 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 90 | { | |
| 91 | Tcl_DString ds; | |
| 92 | ||
| 93 | if (objc != 1) { | |
| 94 | Tcl_WrongNumArgs(interp, 1, objv, NULL); | |
| 95 | return TCL_ERROR; | |
| 96 | } | |
| 97 | ||
| 98 | if (Tcl_GetCwd(interp, &ds) == NULL) { | |
| 99 | return TCL_ERROR; | |
| 100 | } | |
| 101 | Tcl_DStringResult(interp, &ds); | |
| 102 | return TCL_OK; | |
| 103 | } | |
| 104 | ||
| 105 | /* | |
| 106 | *---------------------------------------------------------------------- | |
| 107 | * | |
| 108 | * Tcl_RegexpObjCmd -- | |
| 109 | * | |
| 110 | * This procedure is invoked to process the "regexp" Tcl command. | |
| 111 | * See the user documentation for details on what it does. | |
| 112 | * | |
| 113 | * Results: | |
| 114 | * A standard Tcl result. | |
| 115 | * | |
| 116 | * Side effects: | |
| 117 | * See the user documentation. | |
| 118 | * | |
| 119 | *---------------------------------------------------------------------- | |
| 120 | */ | |
| 121 | ||
| 122 | /* ARGSUSED */ | |
| 123 | int | |
| 124 | Tcl_RegexpObjCmd(dummy, interp, objc, objv) | |
| 125 | ClientData dummy; /* Not used. */ | |
| 126 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 127 | int objc; /* Number of arguments. */ | |
| 128 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 129 | { | |
| 130 | int i, indices, match, about, offset, all, doinline, numMatchesSaved; | |
| 131 | int cflags, eflags, stringLength; | |
| 132 | Tcl_RegExp regExpr; | |
| 133 | Tcl_Obj *objPtr, *resultPtr; | |
| 134 | Tcl_RegExpInfo info; | |
| 135 | static char *options[] = { | |
| 136 | "-all", "-about", "-indices", "-inline", | |
| 137 | "-expanded", "-line", "-linestop", "-lineanchor", | |
| 138 | "-nocase", "-start", "--", (char *) NULL | |
| 139 | }; | |
| 140 | enum options { | |
| 141 | REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE, | |
| 142 | REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR, | |
| 143 | REGEXP_NOCASE, REGEXP_START, REGEXP_LAST | |
| 144 | }; | |
| 145 | ||
| 146 | indices = 0; | |
| 147 | about = 0; | |
| 148 | cflags = TCL_REG_ADVANCED; | |
| 149 | eflags = 0; | |
| 150 | offset = 0; | |
| 151 | all = 0; | |
| 152 | doinline = 0; | |
| 153 | ||
| 154 | for (i = 1; i < objc; i++) { | |
| 155 | char *name; | |
| 156 | int index; | |
| 157 | ||
| 158 | name = Tcl_GetString(objv[i]); | |
| 159 | if (name[0] != '-') { | |
| 160 | break; | |
| 161 | } | |
| 162 | if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, | |
| 163 | &index) != TCL_OK) { | |
| 164 | return TCL_ERROR; | |
| 165 | } | |
| 166 | switch ((enum options) index) { | |
| 167 | case REGEXP_ALL: { | |
| 168 | all = 1; | |
| 169 | break; | |
| 170 | } | |
| 171 | case REGEXP_INDICES: { | |
| 172 | indices = 1; | |
| 173 | break; | |
| 174 | } | |
| 175 | case REGEXP_INLINE: { | |
| 176 | doinline = 1; | |
| 177 | break; | |
| 178 | } | |
| 179 | case REGEXP_NOCASE: { | |
| 180 | cflags |= TCL_REG_NOCASE; | |
| 181 | break; | |
| 182 | } | |
| 183 | case REGEXP_ABOUT: { | |
| 184 | about = 1; | |
| 185 | break; | |
| 186 | } | |
| 187 | case REGEXP_EXPANDED: { | |
| 188 | cflags |= TCL_REG_EXPANDED; | |
| 189 | break; | |
| 190 | } | |
| 191 | case REGEXP_LINE: { | |
| 192 | cflags |= TCL_REG_NEWLINE; | |
| 193 | break; | |
| 194 | } | |
| 195 | case REGEXP_LINESTOP: { | |
| 196 | cflags |= TCL_REG_NLSTOP; | |
| 197 | break; | |
| 198 | } | |
| 199 | case REGEXP_LINEANCHOR: { | |
| 200 | cflags |= TCL_REG_NLANCH; | |
| 201 | break; | |
| 202 | } | |
| 203 | case REGEXP_START: { | |
| 204 | if (++i >= objc) { | |
| 205 | goto endOfForLoop; | |
| 206 | } | |
| 207 | if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) { | |
| 208 | return TCL_ERROR; | |
| 209 | } | |
| 210 | if (offset < 0) { | |
| 211 | offset = 0; | |
| 212 | } | |
| 213 | break; | |
| 214 | } | |
| 215 | case REGEXP_LAST: { | |
| 216 | i++; | |
| 217 | goto endOfForLoop; | |
| 218 | } | |
| 219 | } | |
| 220 | } | |
| 221 | ||
| 222 | endOfForLoop: | |
| 223 | if ((objc - i) < (2 - about)) { | |
| 224 | Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); | |
| 225 | return TCL_ERROR; | |
| 226 | } | |
| 227 | objc -= i; | |
| 228 | objv += i; | |
| 229 | ||
| 230 | if (doinline && ((objc - 2) != 0)) { | |
| 231 | /* | |
| 232 | * User requested -inline, but specified match variables - a no-no. | |
| 233 | */ | |
| 234 | Tcl_AppendResult(interp, "regexp match variables not allowed", | |
| 235 | " when using -inline", (char *) NULL); | |
| 236 | return TCL_ERROR; | |
| 237 | } | |
| 238 | ||
| 239 | regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); | |
| 240 | if (regExpr == NULL) { | |
| 241 | return TCL_ERROR; | |
| 242 | } | |
| 243 | objPtr = objv[1]; | |
| 244 | ||
| 245 | if (about) { | |
| 246 | if (TclRegAbout(interp, regExpr) < 0) { | |
| 247 | return TCL_ERROR; | |
| 248 | } | |
| 249 | return TCL_OK; | |
| 250 | } | |
| 251 | ||
| 252 | if (offset > 0) { | |
| 253 | /* | |
| 254 | * Add flag if using offset (string is part of a larger string), | |
| 255 | * so that "^" won't match. | |
| 256 | */ | |
| 257 | eflags |= TCL_REG_NOTBOL; | |
| 258 | } | |
| 259 | ||
| 260 | objc -= 2; | |
| 261 | objv += 2; | |
| 262 | resultPtr = Tcl_GetObjResult(interp); | |
| 263 | ||
| 264 | if (doinline) { | |
| 265 | /* | |
| 266 | * Save all the subexpressions, as we will return them as a list | |
| 267 | */ | |
| 268 | numMatchesSaved = -1; | |
| 269 | } else { | |
| 270 | /* | |
| 271 | * Save only enough subexpressions for matches we want to keep, | |
| 272 | * expect in the case of -all, where we need to keep at least | |
| 273 | * one to know where to move the offset. | |
| 274 | */ | |
| 275 | numMatchesSaved = (objc == 0) ? all : objc; | |
| 276 | } | |
| 277 | ||
| 278 | /* | |
| 279 | * Get the length of the string that we are matching against so | |
| 280 | * we can do the termination test for -all matches. | |
| 281 | */ | |
| 282 | stringLength = Tcl_GetCharLength(objPtr); | |
| 283 | ||
| 284 | /* | |
| 285 | * The following loop is to handle multiple matches within the | |
| 286 | * same source string; each iteration handles one match. If "-all" | |
| 287 | * hasn't been specified then the loop body only gets executed once. | |
| 288 | * We terminate the loop when the starting offset is past the end of the | |
| 289 | * string. | |
| 290 | */ | |
| 291 | ||
| 292 | while (1) { | |
| 293 | match = Tcl_RegExpExecObj(interp, regExpr, objPtr, | |
| 294 | offset /* offset */, numMatchesSaved, eflags); | |
| 295 | ||
| 296 | if (match < 0) { | |
| 297 | return TCL_ERROR; | |
| 298 | } | |
| 299 | ||
| 300 | if (match == 0) { | |
| 301 | /* | |
| 302 | * We want to set the value of the intepreter result only when | |
| 303 | * this is the first time through the loop. | |
| 304 | */ | |
| 305 | if (all <= 1) { | |
| 306 | /* | |
| 307 | * If inlining, set the interpreter's object result to an | |
| 308 | * empty list, otherwise set it to an integer object w/ | |
| 309 | * value 0. | |
| 310 | */ | |
| 311 | if (doinline) { | |
| 312 | Tcl_SetListObj(resultPtr, 0, NULL); | |
| 313 | } else { | |
| 314 | Tcl_SetIntObj(resultPtr, 0); | |
| 315 | } | |
| 316 | return TCL_OK; | |
| 317 | } | |
| 318 | break; | |
| 319 | } | |
| 320 | ||
| 321 | /* | |
| 322 | * If additional variable names have been specified, return | |
| 323 | * index information in those variables. | |
| 324 | */ | |
| 325 | ||
| 326 | Tcl_RegExpGetInfo(regExpr, &info); | |
| 327 | if (doinline) { | |
| 328 | /* | |
| 329 | * It's the number of substitutions, plus one for the matchVar | |
| 330 | * at index 0 | |
| 331 | */ | |
| 332 | objc = info.nsubs + 1; | |
| 333 | } | |
| 334 | for (i = 0; i < objc; i++) { | |
| 335 | Tcl_Obj *newPtr; | |
| 336 | ||
| 337 | if (indices) { | |
| 338 | int start, end; | |
| 339 | Tcl_Obj *objs[2]; | |
| 340 | ||
| 341 | if (i <= info.nsubs) { | |
| 342 | start = offset + info.matches[i].start; | |
| 343 | end = offset + info.matches[i].end; | |
| 344 | ||
| 345 | /* | |
| 346 | * Adjust index so it refers to the last character in the | |
| 347 | * match instead of the first character after the match. | |
| 348 | */ | |
| 349 | ||
| 350 | if (end >= offset) { | |
| 351 | end--; | |
| 352 | } | |
| 353 | } else { | |
| 354 | start = -1; | |
| 355 | end = -1; | |
| 356 | } | |
| 357 | ||
| 358 | objs[0] = Tcl_NewLongObj(start); | |
| 359 | objs[1] = Tcl_NewLongObj(end); | |
| 360 | ||
| 361 | newPtr = Tcl_NewListObj(2, objs); | |
| 362 | } else { | |
| 363 | if (i <= info.nsubs) { | |
| 364 | newPtr = Tcl_GetRange(objPtr, | |
| 365 | offset + info.matches[i].start, | |
| 366 | offset + info.matches[i].end - 1); | |
| 367 | } else { | |
| 368 | newPtr = Tcl_NewObj(); | |
| 369 | } | |
| 370 | } | |
| 371 | if (doinline) { | |
| 372 | if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr) | |
| 373 | != TCL_OK) { | |
| 374 | Tcl_DecrRefCount(newPtr); | |
| 375 | return TCL_ERROR; | |
| 376 | } | |
| 377 | } else { | |
| 378 | Tcl_Obj *valuePtr; | |
| 379 | valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); | |
| 380 | if (valuePtr == NULL) { | |
| 381 | Tcl_DecrRefCount(newPtr); | |
| 382 | Tcl_AppendResult(interp, "couldn't set variable \"", | |
| 383 | Tcl_GetString(objv[i]), "\"", (char *) NULL); | |
| 384 | return TCL_ERROR; | |
| 385 | } | |
| 386 | } | |
| 387 | } | |
| 388 | ||
| 389 | if (all == 0) { | |
| 390 | break; | |
| 391 | } | |
| 392 | /* | |
| 393 | * Adjust the offset to the character just after the last one | |
| 394 | * in the matchVar and increment all to count how many times | |
| 395 | * we are making a match. We always increment the offset by at least | |
| 396 | * one to prevent endless looping (as in the case: | |
| 397 | * regexp -all {a*} a). Otherwise, when we match the NULL string at | |
| 398 | * the end of the input string, we will loop indefinately (because the | |
| 399 | * length of the match is 0, so offset never changes). | |
| 400 | */ | |
| 401 | if (info.matches[0].end == 0) { | |
| 402 | offset++; | |
| 403 | } | |
| 404 | offset += info.matches[0].end; | |
| 405 | all++; | |
| 406 | if (offset >= stringLength) { | |
| 407 | break; | |
| 408 | } | |
| 409 | } | |
| 410 | ||
| 411 | /* | |
| 412 | * Set the interpreter's object result to an integer object | |
| 413 | * with value 1 if -all wasn't specified, otherwise it's all-1 | |
| 414 | * (the number of times through the while - 1). | |
| 415 | */ | |
| 416 | ||
| 417 | if (!doinline) { | |
| 418 | Tcl_SetIntObj(resultPtr, (all ? all-1 : 1)); | |
| 419 | } | |
| 420 | return TCL_OK; | |
| 421 | } | |
| 422 | ||
| 423 | /* | |
| 424 | *---------------------------------------------------------------------- | |
| 425 | * | |
| 426 | * Tcl_RegsubObjCmd -- | |
| 427 | * | |
| 428 | * This procedure is invoked to process the "regsub" Tcl command. | |
| 429 | * See the user documentation for details on what it does. | |
| 430 | * | |
| 431 | * Results: | |
| 432 | * A standard Tcl result. | |
| 433 | * | |
| 434 | * Side effects: | |
| 435 | * See the user documentation. | |
| 436 | * | |
| 437 | *---------------------------------------------------------------------- | |
| 438 | */ | |
| 439 | ||
| 440 | /* ARGSUSED */ | |
| 441 | int | |
| 442 | Tcl_RegsubObjCmd(dummy, interp, objc, objv) | |
| 443 | ClientData dummy; /* Not used. */ | |
| 444 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 445 | int objc; /* Number of arguments. */ | |
| 446 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 447 | { | |
| 448 | int i, result, cflags, all, wlen, numMatches, offset; | |
| 449 | Tcl_RegExp regExpr; | |
| 450 | Tcl_Obj *resultPtr, *varPtr, *objPtr; | |
| 451 | Tcl_UniChar *wstring; | |
| 452 | char *subspec; | |
| 453 | ||
| 454 | static char *options[] = { | |
| 455 | "-all", "-nocase", "-expanded", | |
| 456 | "-line", "-linestop", "-lineanchor", "-start", | |
| 457 | "--", NULL | |
| 458 | }; | |
| 459 | enum options { | |
| 460 | REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED, | |
| 461 | REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START, | |
| 462 | REGSUB_LAST | |
| 463 | }; | |
| 464 | ||
| 465 | cflags = TCL_REG_ADVANCED; | |
| 466 | all = 0; | |
| 467 | offset = 0; | |
| 468 | ||
| 469 | for (i = 1; i < objc; i++) { | |
| 470 | char *name; | |
| 471 | int index; | |
| 472 | ||
| 473 | name = Tcl_GetString(objv[i]); | |
| 474 | if (name[0] != '-') { | |
| 475 | break; | |
| 476 | } | |
| 477 | if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, | |
| 478 | &index) != TCL_OK) { | |
| 479 | return TCL_ERROR; | |
| 480 | } | |
| 481 | switch ((enum options) index) { | |
| 482 | case REGSUB_ALL: { | |
| 483 | all = 1; | |
| 484 | break; | |
| 485 | } | |
| 486 | case REGSUB_NOCASE: { | |
| 487 | cflags |= TCL_REG_NOCASE; | |
| 488 | break; | |
| 489 | } | |
| 490 | case REGSUB_EXPANDED: { | |
| 491 | cflags |= TCL_REG_EXPANDED; | |
| 492 | break; | |
| 493 | } | |
| 494 | case REGSUB_LINE: { | |
| 495 | cflags |= TCL_REG_NEWLINE; | |
| 496 | break; | |
| 497 | } | |
| 498 | case REGSUB_LINESTOP: { | |
| 499 | cflags |= TCL_REG_NLSTOP; | |
| 500 | break; | |
| 501 | } | |
| 502 | case REGSUB_LINEANCHOR: { | |
| 503 | cflags |= TCL_REG_NLANCH; | |
| 504 | break; | |
| 505 | } | |
| 506 | case REGSUB_START: { | |
| 507 | if (++i >= objc) { | |
| 508 | goto endOfForLoop; | |
| 509 | } | |
| 510 | if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) { | |
| 511 | return TCL_ERROR; | |
| 512 | } | |
| 513 | if (offset < 0) { | |
| 514 | offset = 0; | |
| 515 | } | |
| 516 | break; | |
| 517 | } | |
| 518 | case REGSUB_LAST: { | |
| 519 | i++; | |
| 520 | goto endOfForLoop; | |
| 521 | } | |
| 522 | } | |
| 523 | } | |
| 524 | endOfForLoop: | |
| 525 | if (objc - i != 4) { | |
| 526 | Tcl_WrongNumArgs(interp, 1, objv, | |
| 527 | "?switches? exp string subSpec varName"); | |
| 528 | return TCL_ERROR; | |
| 529 | } | |
| 530 | ||
| 531 | objv += i; | |
| 532 | ||
| 533 | regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); | |
| 534 | if (regExpr == NULL) { | |
| 535 | return TCL_ERROR; | |
| 536 | } | |
| 537 | ||
| 538 | result = TCL_OK; | |
| 539 | resultPtr = Tcl_NewObj(); | |
| 540 | Tcl_IncrRefCount(resultPtr); | |
| 541 | ||
| 542 | objPtr = objv[1]; | |
| 543 | wlen = Tcl_GetCharLength(objPtr); | |
| 544 | wstring = Tcl_GetUnicode(objPtr); | |
| 545 | subspec = Tcl_GetString(objv[2]); | |
| 546 | varPtr = objv[3]; | |
| 547 | ||
| 548 | /* | |
| 549 | * The following loop is to handle multiple matches within the | |
| 550 | * same source string; each iteration handles one match and its | |
| 551 | * corresponding substitution. If "-all" hasn't been specified | |
| 552 | * then the loop body only gets executed once. | |
| 553 | */ | |
| 554 | ||
| 555 | numMatches = 0; | |
| 556 | for ( ; offset < wlen; ) { | |
| 557 | int start, end, subStart, subEnd, match; | |
| 558 | char *src, *firstChar; | |
| 559 | char c; | |
| 560 | Tcl_RegExpInfo info; | |
| 561 | ||
| 562 | /* | |
| 563 | * The flags argument is set if string is part of a larger string, | |
| 564 | * so that "^" won't match. | |
| 565 | */ | |
| 566 | ||
| 567 | match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset, | |
| 568 | 10 /* matches */, ((offset > 0) ? TCL_REG_NOTBOL : 0)); | |
| 569 | ||
| 570 | if (match < 0) { | |
| 571 | result = TCL_ERROR; | |
| 572 | goto done; | |
| 573 | } | |
| 574 | if (match == 0) { | |
| 575 | break; | |
| 576 | } | |
| 577 | if ((numMatches == 0) && (offset > 0)) { | |
| 578 | /* Copy the initial portion of the string in if an offset | |
| 579 | * was specified. | |
| 580 | */ | |
| 581 | Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); | |
| 582 | } | |
| 583 | numMatches++; | |
| 584 | ||
| 585 | /* | |
| 586 | * Copy the portion of the source string before the match to the | |
| 587 | * result variable. | |
| 588 | */ | |
| 589 | ||
| 590 | Tcl_RegExpGetInfo(regExpr, &info); | |
| 591 | start = info.matches[0].start; | |
| 592 | end = info.matches[0].end; | |
| 593 | Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); | |
| 594 | ||
| 595 | /* | |
| 596 | * Append the subSpec argument to the variable, making appropriate | |
| 597 | * substitutions. This code is a bit hairy because of the backslash | |
| 598 | * conventions and because the code saves up ranges of characters in | |
| 599 | * subSpec to reduce the number of calls to Tcl_SetVar. | |
| 600 | */ | |
| 601 | ||
| 602 | src = subspec; | |
| 603 | firstChar = subspec; | |
| 604 | for (c = *src; c != '\0'; src++, c = *src) { | |
| 605 | int index; | |
| 606 | ||
| 607 | if (c == '&') { | |
| 608 | index = 0; | |
| 609 | } else if (c == '\\') { | |
| 610 | c = src[1]; | |
| 611 | if ((c >= '0') && (c <= '9')) { | |
| 612 | index = c - '0'; | |
| 613 | } else if ((c == '\\') || (c == '&')) { | |
| 614 | Tcl_AppendToObj(resultPtr, firstChar, src - firstChar); | |
| 615 | Tcl_AppendToObj(resultPtr, &c, 1); | |
| 616 | firstChar = src + 2; | |
| 617 | src++; | |
| 618 | continue; | |
| 619 | } else { | |
| 620 | continue; | |
| 621 | } | |
| 622 | } else { | |
| 623 | continue; | |
| 624 | } | |
| 625 | if (firstChar != src) { | |
| 626 | Tcl_AppendToObj(resultPtr, firstChar, src - firstChar); | |
| 627 | } | |
| 628 | if (index <= info.nsubs) { | |
| 629 | subStart = info.matches[index].start; | |
| 630 | subEnd = info.matches[index].end; | |
| 631 | if ((subStart >= 0) && (subEnd >= 0)) { | |
| 632 | Tcl_AppendUnicodeToObj(resultPtr, | |
| 633 | wstring + offset + subStart, subEnd - subStart); | |
| 634 | } | |
| 635 | } | |
| 636 | if (*src == '\\') { | |
| 637 | src++; | |
| 638 | } | |
| 639 | firstChar = src + 1; | |
| 640 | } | |
| 641 | if (firstChar != src) { | |
| 642 | Tcl_AppendToObj(resultPtr, firstChar, src - firstChar); | |
| 643 | } | |
| 644 | if (end == 0) { | |
| 645 | /* | |
| 646 | * Always consume at least one character of the input string | |
| 647 | * in order to prevent infinite loops. | |
| 648 | */ | |
| 649 | ||
| 650 | Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); | |
| 651 | offset++; | |
| 652 | } | |
| 653 | offset += end; | |
| 654 | if (!all) { | |
| 655 | break; | |
| 656 | } | |
| 657 | } | |
| 658 | ||
| 659 | /* | |
| 660 | * Copy the portion of the source string after the last match to the | |
| 661 | * result variable. | |
| 662 | */ | |
| 663 | ||
| 664 | if (numMatches == 0) { | |
| 665 | /* | |
| 666 | * On zero matches, just ignore the offset, since it shouldn't | |
| 667 | * matter to us in this case, and the user may have skewed it. | |
| 668 | */ | |
| 669 | Tcl_AppendUnicodeToObj(resultPtr, wstring, wlen); | |
| 670 | } else if (offset < wlen) { | |
| 671 | Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); | |
| 672 | } | |
| 673 | if (Tcl_ObjSetVar2(interp, varPtr, NULL, resultPtr, 0) == NULL) { | |
| 674 | Tcl_AppendResult(interp, "couldn't set variable \"", | |
| 675 | Tcl_GetString(varPtr), "\"", (char *) NULL); | |
| 676 | result = TCL_ERROR; | |
| 677 | } else { | |
| 678 | /* | |
| 679 | * Set the interpreter's object result to an integer object holding the | |
| 680 | * number of matches. | |
| 681 | */ | |
| 682 | ||
| 683 | Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches); | |
| 684 | } | |
| 685 | ||
| 686 | done: | |
| 687 | Tcl_DecrRefCount(resultPtr); | |
| 688 | return result; | |
| 689 | } | |
| 690 | ||
| 691 | /* | |
| 692 | *---------------------------------------------------------------------- | |
| 693 | * | |
| 694 | * Tcl_RenameObjCmd -- | |
| 695 | * | |
| 696 | * This procedure is invoked to process the "rename" Tcl command. | |
| 697 | * See the user documentation for details on what it does. | |
| 698 | * | |
| 699 | * Results: | |
| 700 | * A standard Tcl object result. | |
| 701 | * | |
| 702 | * Side effects: | |
| 703 | * See the user documentation. | |
| 704 | * | |
| 705 | *---------------------------------------------------------------------- | |
| 706 | */ | |
| 707 | ||
| 708 | /* ARGSUSED */ | |
| 709 | int | |
| 710 | Tcl_RenameObjCmd(dummy, interp, objc, objv) | |
| 711 | ClientData dummy; /* Arbitrary value passed to the command. */ | |
| 712 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 713 | int objc; /* Number of arguments. */ | |
| 714 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 715 | { | |
| 716 | char *oldName, *newName; | |
| 717 | ||
| 718 | if (objc != 3) { | |
| 719 | Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); | |
| 720 | return TCL_ERROR; | |
| 721 | } | |
| 722 | ||
| 723 | oldName = Tcl_GetString(objv[1]); | |
| 724 | newName = Tcl_GetString(objv[2]); | |
| 725 | return TclRenameCommand(interp, oldName, newName); | |
| 726 | } | |
| 727 | ||
| 728 | /* | |
| 729 | *---------------------------------------------------------------------- | |
| 730 | * | |
| 731 | * Tcl_ReturnObjCmd -- | |
| 732 | * | |
| 733 | * This object-based procedure is invoked to process the "return" Tcl | |
| 734 | * command. See the user documentation for details on what it does. | |
| 735 | * | |
| 736 | * Results: | |
| 737 | * A standard Tcl object result. | |
| 738 | * | |
| 739 | * Side effects: | |
| 740 | * See the user documentation. | |
| 741 | * | |
| 742 | *---------------------------------------------------------------------- | |
| 743 | */ | |
| 744 | ||
| 745 | /* ARGSUSED */ | |
| 746 | int | |
| 747 | Tcl_ReturnObjCmd(dummy, interp, objc, objv) | |
| 748 | ClientData dummy; /* Not used. */ | |
| 749 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 750 | int objc; /* Number of arguments. */ | |
| 751 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 752 | { | |
| 753 | Interp *iPtr = (Interp *) interp; | |
| 754 | int optionLen, argLen, code, result; | |
| 755 | ||
| 756 | if (iPtr->errorInfo != NULL) { | |
| 757 | ckfree(iPtr->errorInfo); | |
| 758 | iPtr->errorInfo = NULL; | |
| 759 | } | |
| 760 | if (iPtr->errorCode != NULL) { | |
| 761 | ckfree(iPtr->errorCode); | |
| 762 | iPtr->errorCode = NULL; | |
| 763 | } | |
| 764 | code = TCL_OK; | |
| 765 | ||
| 766 | for (objv++, objc--; objc > 1; objv += 2, objc -= 2) { | |
| 767 | char *option = Tcl_GetStringFromObj(objv[0], &optionLen); | |
| 768 | char *arg = Tcl_GetStringFromObj(objv[1], &argLen); | |
| 769 | ||
| 770 | if (strcmp(option, "-code") == 0) { | |
| 771 | register int c = arg[0]; | |
| 772 | if ((c == 'o') && (strcmp(arg, "ok") == 0)) { | |
| 773 | code = TCL_OK; | |
| 774 | } else if ((c == 'e') && (strcmp(arg, "error") == 0)) { | |
| 775 | code = TCL_ERROR; | |
| 776 | } else if ((c == 'r') && (strcmp(arg, "return") == 0)) { | |
| 777 | code = TCL_RETURN; | |
| 778 | } else if ((c == 'b') && (strcmp(arg, "break") == 0)) { | |
| 779 | code = TCL_BREAK; | |
| 780 | } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) { | |
| 781 | code = TCL_CONTINUE; | |
| 782 | } else { | |
| 783 | result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1], | |
| 784 | &code); | |
| 785 | if (result != TCL_OK) { | |
| 786 | Tcl_ResetResult(interp); | |
| 787 | Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | |
| 788 | "bad completion code \"", | |
| 789 | Tcl_GetString(objv[1]), | |
| 790 | "\": must be ok, error, return, break, ", | |
| 791 | "continue, or an integer", (char *) NULL); | |
| 792 | return result; | |
| 793 | } | |
| 794 | } | |
| 795 | } else if (strcmp(option, "-errorinfo") == 0) { | |
| 796 | iPtr->errorInfo = | |
| 797 | (char *) ckalloc((unsigned) (strlen(arg) + 1)); | |
| 798 | strcpy(iPtr->errorInfo, arg); | |
| 799 | } else if (strcmp(option, "-errorcode") == 0) { | |
| 800 | iPtr->errorCode = | |
| 801 | (char *) ckalloc((unsigned) (strlen(arg) + 1)); | |
| 802 | strcpy(iPtr->errorCode, arg); | |
| 803 | } else { | |
| 804 | Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | |
| 805 | "bad option \"", option, | |
| 806 | "\": must be -code, -errorcode, or -errorinfo", | |
| 807 | (char *) NULL); | |
| 808 | return TCL_ERROR; | |
| 809 | } | |
| 810 | } | |
| 811 | ||
| 812 | if (objc == 1) { | |
| 813 | /* | |
| 814 | * Set the interpreter's object result. An inline version of | |
| 815 | * Tcl_SetObjResult. | |
| 816 | */ | |
| 817 | ||
| 818 | Tcl_SetObjResult(interp, objv[0]); | |
| 819 | } | |
| 820 | iPtr->returnCode = code; | |
| 821 | return TCL_RETURN; | |
| 822 | } | |
| 823 | ||
| 824 | /* | |
| 825 | *---------------------------------------------------------------------- | |
| 826 | * | |
| 827 | * Tcl_SourceObjCmd -- | |
| 828 | * | |
| 829 | * This procedure is invoked to process the "source" Tcl command. | |
| 830 | * See the user documentation for details on what it does. | |
| 831 | * | |
| 832 | * Results: | |
| 833 | * A standard Tcl object result. | |
| 834 | * | |
| 835 | * Side effects: | |
| 836 | * See the user documentation. | |
| 837 | * | |
| 838 | *---------------------------------------------------------------------- | |
| 839 | */ | |
| 840 | ||
| 841 | /* ARGSUSED */ | |
| 842 | int | |
| 843 | Tcl_SourceObjCmd(dummy, interp, objc, objv) | |
| 844 | ClientData dummy; /* Not used. */ | |
| 845 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 846 | int objc; /* Number of arguments. */ | |
| 847 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 848 | { | |
| 849 | char *bytes; | |
| 850 | int result; | |
| 851 | ||
| 852 | if (objc != 2) { | |
| 853 | Tcl_WrongNumArgs(interp, 1, objv, "fileName"); | |
| 854 | return TCL_ERROR; | |
| 855 | } | |
| 856 | ||
| 857 | bytes = Tcl_GetString(objv[1]); | |
| 858 | result = Tcl_EvalFile(interp, bytes); | |
| 859 | return result; | |
| 860 | } | |
| 861 | ||
| 862 | /* | |
| 863 | *---------------------------------------------------------------------- | |
| 864 | * | |
| 865 | * Tcl_SplitObjCmd -- | |
| 866 | * | |
| 867 | * This procedure is invoked to process the "split" Tcl command. | |
| 868 | * See the user documentation for details on what it does. | |
| 869 | * | |
| 870 | * Results: | |
| 871 | * A standard Tcl result. | |
| 872 | * | |
| 873 | * Side effects: | |
| 874 | * See the user documentation. | |
| 875 | * | |
| 876 | *---------------------------------------------------------------------- | |
| 877 | */ | |
| 878 | ||
| 879 | /* ARGSUSED */ | |
| 880 | int | |
| 881 | Tcl_SplitObjCmd(dummy, interp, objc, objv) | |
| 882 | ClientData dummy; /* Not used. */ | |
| 883 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 884 | int objc; /* Number of arguments. */ | |
| 885 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 886 | { | |
| 887 | Tcl_UniChar ch; | |
| 888 | int len; | |
| 889 | char *splitChars, *string, *end; | |
| 890 | int splitCharLen, stringLen; | |
| 891 | Tcl_Obj *listPtr, *objPtr; | |
| 892 | ||
| 893 | if (objc == 2) { | |
| 894 | splitChars = " \n\t\r"; | |
| 895 | splitCharLen = 4; | |
| 896 | } else if (objc == 3) { | |
| 897 | splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen); | |
| 898 | } else { | |
| 899 | Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?"); | |
| 900 | return TCL_ERROR; | |
| 901 | } | |
| 902 | ||
| 903 | string = Tcl_GetStringFromObj(objv[1], &stringLen); | |
| 904 | end = string + stringLen; | |
| 905 | listPtr = Tcl_GetObjResult(interp); | |
| 906 | ||
| 907 | if (stringLen == 0) { | |
| 908 | /* | |
| 909 | * Do nothing. | |
| 910 | */ | |
| 911 | } else if (splitCharLen == 0) { | |
| 912 | /* | |
| 913 | * Handle the special case of splitting on every character. | |
| 914 | */ | |
| 915 | ||
| 916 | for ( ; string < end; string += len) { | |
| 917 | len = Tcl_UtfToUniChar(string, &ch); | |
| 918 | objPtr = Tcl_NewStringObj(string, len); | |
| 919 | Tcl_ListObjAppendElement(NULL, listPtr, objPtr); | |
| 920 | } | |
| 921 | } else { | |
| 922 | char *element, *p, *splitEnd; | |
| 923 | int splitLen; | |
| 924 | Tcl_UniChar splitChar; | |
| 925 | ||
| 926 | /* | |
| 927 | * Normal case: split on any of a given set of characters. | |
| 928 | * Discard instances of the split characters. | |
| 929 | */ | |
| 930 | ||
| 931 | splitEnd = splitChars + splitCharLen; | |
| 932 | ||
| 933 | for (element = string; string < end; string += len) { | |
| 934 | len = Tcl_UtfToUniChar(string, &ch); | |
| 935 | for (p = splitChars; p < splitEnd; p += splitLen) { | |
| 936 | splitLen = Tcl_UtfToUniChar(p, &splitChar); | |
| 937 | if (ch == splitChar) { | |
| 938 | objPtr = Tcl_NewStringObj(element, string - element); | |
| 939 | Tcl_ListObjAppendElement(NULL, listPtr, objPtr); | |
| 940 | element = string + len; | |
| 941 | break; | |
| 942 | } | |
| 943 | } | |
| 944 | } | |
| 945 | objPtr = Tcl_NewStringObj(element, string - element); | |
| 946 | Tcl_ListObjAppendElement(NULL, listPtr, objPtr); | |
| 947 | } | |
| 948 | return TCL_OK; | |
| 949 | } | |
| 950 | ||
| 951 | /* | |
| 952 | *---------------------------------------------------------------------- | |
| 953 | * | |
| 954 | * Tcl_StringObjCmd -- | |
| 955 | * | |
| 956 | * This procedure is invoked to process the "string" Tcl command. | |
| 957 | * See the user documentation for details on what it does. Note | |
| 958 | * that this command only functions correctly on properly formed | |
| 959 | * Tcl UTF strings. | |
| 960 | * | |
| 961 | * Results: | |
| 962 | * A standard Tcl result. | |
| 963 | * | |
| 964 | * Side effects: | |
| 965 | * See the user documentation. | |
| 966 | * | |
| 967 | *---------------------------------------------------------------------- | |
| 968 | */ | |
| 969 | ||
| 970 | /* ARGSUSED */ | |
| 971 | int | |
| 972 | Tcl_StringObjCmd(dummy, interp, objc, objv) | |
| 973 | ClientData dummy; /* Not used. */ | |
| 974 | Tcl_Interp *interp; /* Current interpreter. */ | |
| 975 | int objc; /* Number of arguments. */ | |
| 976 | Tcl_Obj *CONST objv[]; /* Argument objects. */ | |
| 977 | { | |
| 978 | int index, left, right; | |
| 979 | Tcl_Obj *resultPtr; | |
| 980 | char *string1, *string2; | |
| 981 | int length1, length2; | |
| 982 | static char *options[] = { | |
| 983 | "bytelength", "compare", "equal", "first", | |
| 984 | "index", "is", "last", "length", | |
| 985 | "map", "match", "range", "repeat", | |
| 986 | "replace", "tolower", "toupper", "totitle", | |
| 987 | "trim", "trimleft", "trimright", | |
| 988 | "wordend", "wordstart", (char *) NULL | |
| 989 | }; | |
| 990 | enum options { | |
| 991 | STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST, | |
| 992 | STR_INDEX, STR_IS, STR_LAST, STR_LENGTH, | |
| 993 | STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT, | |
| 994 | STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE, | |
| 995 | STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, | |
| 996 | STR_WORDEND, STR_WORDSTART | |
| 997 | }; | |
| 998 | ||
| 999 | if (objc < 2) { | |
| 1000 | Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); | |
| 1001 | return TCL_ERROR; | |
| 1002 | } | |
| 1003 | ||
| 1004 | if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, | |
| 1005 | &index) != TCL_OK) { | |
| 1006 | return TCL_ERROR; | |
| 1007 | } | |
| 1008 | ||
| 1009 | resultPtr = Tcl_GetObjResult(interp); | |
| 1010 | switch ((enum options) index) { | |
| 1011 | case STR_EQUAL: | |
| 1012 | case STR_COMPARE: { | |
| 1013 | int i, match, length, nocase = 0, reqlength = -1; | |
| 1014 | ||
| 1015 | if (objc < 4 || objc > 7) { | |
| 1016 | str_cmp_args: | |
| 1017 | Tcl_WrongNumArgs(interp, 2, objv, | |
| 1018 | "?-nocase? ?-length int? string1 string2"); | |
| 1019 | return TCL_ERROR; | |
| 1020 | } | |
| 1021 | ||
| 1022 | for (i = 2; i < objc-2; i++) { | |
| 1023 | string2 = Tcl_GetStringFromObj(objv[i], &length2); | |
| 1024 | if ((length2 > 1) | |
| 1025 | && strncmp(string2, "-nocase", (size_t) length2) == 0) { | |
| 1026 | nocase = 1; | |
| 1027 | } else if ((length2 > 1) | |
| 1028 | && strncmp(string2, "-length", (size_t) length2) == 0) { | |
| 1029 | if (i+1 >= objc-2) { | |
| 1030 | goto str_cmp_args; | |
| 1031 | } | |
| 1032 | if (Tcl_GetIntFromObj(interp, objv[++i], | |
| 1033 | &reqlength) != TCL_OK) { | |
| 1034 | return TCL_ERROR; | |
| 1035 | } | |
| 1036 | } else { | |
| 1037 | Tcl_AppendStringsToObj(resultPtr, "bad option \"", | |
| 1038 | string2, "\": must be -nocase or -length", | |
| 1039 | (char *) NULL); | |
| 1040 | return TCL_ERROR; | |
| 1041 | } | |
| 1042 | } | |
| 1043 | ||
| 1044 | string1 = Tcl_GetStringFromObj(objv[objc-2], &length1); | |
| 1045 | string2 = Tcl_GetStringFromObj(objv[objc-1], &length2); | |
| 1046 | /* | |
| 1047 | * This is the min length IN BYTES of the two strings | |
| 1048 | */ | |
| 1049 | length = (length1 < length2) ? length1 : length2; | |
| 1050 | ||
| 1051 | if (reqlength == 0) { | |
| 1052 | /* | |
| 1053 | * Anything matches at 0 chars, right? | |
| 1054 | */ | |
| 1055 | ||
| 1056 | match = 0; | |
| 1057 | } else if (nocase || ((reqlength > 0) && (reqlength <= length))) { | |
| 1058 | /* | |
| 1059 | * with -nocase or -length we have to check true char length | |
| 1060 | * as it could be smaller than expected | |
| 1061 | */ | |
| 1062 | ||
| 1063 | length1 = Tcl_NumUtfChars(string1, length1); | |
| 1064 | length2 = Tcl_NumUtfChars(string2, length2); | |
| 1065 | length = (length1 < length2) ? length1 : length2; | |
| 1066 | ||
| 1067 | /* | |
| 1068 | * Do the reqlength check again, against 0 as well for | |
| 1069 | * the benfit of nocase | |
| 1070 | */ | |
| 1071 | ||
| 1072 | if ((reqlength > 0) && (reqlength < length)) { | |
| 1073 | length = reqlength; | |
| 1074 | } else if (reqlength < 0) { | |
| 1075 | /* | |
| 1076 | * The requested length is negative, so we ignore it by | |
| 1077 | * setting it to the longer of the two lengths. | |
| 1078 | */ | |
| 1079 | ||
| 1080 | reqlength = (length1 > length2) ? length1 : length2; | |
| 1081 | } | |
| 1082 | if (nocase) { | |
| 1083 | match = Tcl_UtfNcasecmp(string1, string2, | |
| 1084 | (unsigned) length); | |
| 1085 | } else { | |
| 1086 | match = Tcl_UtfNcmp(string1, string2, (unsigned) length); | |
| 1087 | } | |
| 1088 | if ((match == 0) && (reqlength > length)) { | |
| 1089 | match = length1 - length2; | |
| 1090 | } | |
| 1091 | } else { | |
| 1092 | match = memcmp(string1, string2, (unsigned) length); | |
| 1093 | if (match == 0) { | |
| 1094 | match = length1 - length2; | |
| 1095 | } | |
| 1096 | } | |
| 1097 | ||
| 1098 | if ((enum options) index == STR_EQUAL) { | |
| 1099 | Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1); | |
| 1100 | } else { | |
| 1101 | Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 : | |
| 1102 | (match < 0) ? -1 : 0)); | |
| 1103 | } | |
| 1104 | break; | |
| 1105 | } | |
| 1106 | case STR_FIRST: { | |
| 1107 | register char *p, *end; | |
| 1108 | int match, utflen, start; | |
| 1109 | ||
| 1110 | if (objc < 4 || objc > 5) { | |
| 1111 | Tcl_WrongNumArgs(interp, 2, objv, | |
| 1112 | "string1 string2 ?startIndex?"); | |
| 1113 | return TCL_ERROR; | |
| 1114 | } | |
| 1115 | ||
| 1116 | /* | |
| 1117 | * This algorithm fails on improperly formed UTF strings. | |
| 1118 | * We are searching string2 for the sequence string1. | |
| 1119 | */ | |
| 1120 | ||
| 1121 | match = -1; | |
| 1122 | start = 0; | |
| 1123 | utflen = -1; | |
| 1124 | string1 = Tcl_GetStringFromObj(objv[2], &length1); | |
| 1125 | string2 = Tcl_GetStringFromObj(objv[3], &length2); | |
| 1126 | ||
| 1127 | if (objc == 5) { | |
| 1128 | /* | |
| 1129 | * If a startIndex is specified, we will need to fast forward | |
| 1130 | * to that point in the string before we think about a match | |
| 1131 | */ | |
| 1132 | utflen = Tcl_NumUtfChars(string2, length2); | |
| 1133 | if (TclGetIntForIndex(interp, objv[4], utflen-1, | |
| 1134 | &start) != TCL_OK) { | |
| 1135 | return TCL_ERROR; | |
| 1136 | } | |
| 1137 | if (start >= utflen) { | |
| 1138 | goto str_first_done; | |
| 1139 | } else if (start > 0) { | |
| 1140 | if (length2 == utflen) { | |
| 1141 | /* no unicode chars */ | |
| 1142 | string2 += start; | |
| 1143 | length2 -= start; | |
| 1144 | } else { | |
| 1145 | char *s = Tcl_UtfAtIndex(string2, start); | |
| 1146 | length2 -= s - string2; | |
| 1147 | string2 = s; | |
| 1148 | } | |
| 1149 | } | |
| 1150 | } | |
| 1151 | ||
| 1152 | if (length1 > 0) { | |
| 1153 | end = string2 + length2 - length1 + 1; | |
| 1154 | for (p = string2; p < end; p++) { | |
| 1155 | /* | |
| 1156 | * Scan forward to find the first character. | |
| 1157 | */ | |
| 1158 | ||
| 1159 | p = memchr(p, *string1, (unsigned) (end - p)); | |
| 1160 | if (p == NULL) { | |
| 1161 | break; | |
| 1162 | } | |
| 1163 | if (memcmp(string1, p, (unsigned) length1) == 0) { | |
| 1164 | match = p - string2; | |
| 1165 | break; | |
| 1166 | } | |
| 1167 | } | |
| 1168 | } | |
| 1169 | ||
| 1170 | /* | |
| 1171 | * Compute the character index of the matching string by | |
| 1172 | * counting the number of characters before the match. | |
| 1173 | */ | |
| 1174 | str_first_done: | |
| 1175 | if (match != -1) { | |
| 1176 | if (objc == 4) { | |
| 1177 | match = Tcl_NumUtfChars(string2, match); | |
| 1178 | } else if (length2 == utflen) { | |
| 1179 | /* no unicode chars */ | |
| 1180 | match += start; | |
| 1181 | } else { | |
| 1182 | match = start + Tcl_NumUtfChars(string2, match); | |
| 1183 | } | |
| 1184 | } | |
| 1185 | Tcl_SetIntObj(resultPtr, match); | |
| 1186 | break; | |
| 1187 | } | |
| 1188 | case STR_INDEX: { | |
| 1189 | char buf[TCL_UTF_MAX]; | |
| 1190 | Tcl_UniChar unichar; | |
| 1191 | ||
| 1192 | if (objc != 4) { | |
| 1193 | Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); | |
| 1194 | return TCL_ERROR; | |
| 1195 | } | |
| 1196 | ||
| 1197 | /* | |
| 1198 | * If we have a ByteArray object, avoid indexing in the | |
| 1199 | * Utf string since the byte array contains one byte per | |
| 1200 | * character. Otherwise, use the Unicode string rep to | |
| 1201 | * get the index'th char. | |
| 1202 | */ | |
| 1203 | ||
| 1204 | if (objv[2]->typePtr == &tclByteArrayType) { | |
| 1205 | ||
| 1206 | string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1); | |
| 1207 | ||
| 1208 | if (TclGetIntForIndex(interp, objv[3], length1 - 1, | |
| 1209 | &index) != TCL_OK) { | |
| 1210 | return TCL_ERROR; | |
| 1211 | } | |
| 1212 | Tcl_SetByteArrayObj(resultPtr, | |
| 1213 | (unsigned char *)(&string1[index]), 1); | |
| 1214 | } else { | |
| 1215 | string1 = Tcl_GetStringFromObj(objv[2], &length1); | |
| 1216 | ||
| 1217 | /* | |
| 1218 | * convert to Unicode internal rep to calulate what | |
| 1219 | * 'end' really means. | |
| 1220 | */ | |
| 1221 | ||
| 1222 | length2 = Tcl_GetCharLength(objv[2]); | |
| 1223 | ||
| 1224 | if (TclGetIntForIndex(interp, objv[3], length2 - 1, | |
| 1225 | &index) != TCL_OK) { | |
| 1226 | return TCL_ERROR; | |
| 1227 | } | |
| 1228 | if ((index >= 0) && (index < length2)) { | |
| 1229 | unichar = Tcl_GetUniChar(objv[2], index); | |
| 1230 | length2 = Tcl_UniCharToUtf((int)unichar, buf); | |
| 1231 | Tcl_SetStringObj(resultPtr, buf, length2); | |
| 1232 | } | |
| 1233 | } | |
| 1234 | break; | |
| 1235 | } | |
| 1236 | case STR_IS: { | |
| 1237 | char *end; | |
| 1238 | Tcl_UniChar ch; | |
| 1239 | ||
| 1240 | /* | |
| 1241 | * The UniChar comparison function | |
| 1242 | */ | |
| 1243 | ||
| 1244 | int (*chcomp)_ANSI_ARGS_((int)) = NULL; | |
| 1245 | int i, failat = 0, result = 1, strict = 0; | |
| 1246 | Tcl_Obj *objPtr, *failVarObj = NULL; | |
| 1247 | ||
| 1248 | static char *isOptions[] = { | |
| 1249 | "alnum", "alpha", "ascii", "control", | |
| 1250 | "boolean", "digit", "double", "false", | |
| 1251 | "graph", "integer", "lower", "print", | |
| 1252 | "punct", "space", "true", "upper", | |
| 1253 | "wordchar", "xdigit", (char *) NULL | |
| 1254 | }; | |
| 1255 | enum isOptions { | |
| 1256 | STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, | |
| 1257 | STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE, | |
| 1258 | STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT, | |
| 1259 | STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, | |
| 1260 | STR_IS_WORD, STR_IS_XDIGIT | |
| 1261 | }; | |
| 1262 | ||
| 1263 | if (objc < 4 || objc > 7) { | |
| 1264 | Tcl_WrongNumArgs(interp, 2, objv, | |
| 1265 | "class ?-strict? ?-failindex var? str"); | |
| 1266 | return TCL_ERROR; | |
| 1267 | } | |
| 1268 | if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0, | |
| 1269 | &index) != TCL_OK) { | |
| 1270 | return TCL_ERROR; | |
| 1271 | } | |
| 1272 | if (objc != 4) { | |
| 1273 | for (i = 3; i < objc-1; i++) { | |
| 1274 | string2 = Tcl_GetStringFromObj(objv[i], &length2); | |
| 1275 | if ((length2 > 1) && | |
| 1276 | strncmp(string2, "-strict", (size_t) length2) == 0) { | |
| 1277 | strict = 1; | |
| 1278 | } else if ((length2 > 1) && | |
| 1279 | strncmp(string2, "-failindex", (size_t) length2) == 0) { | |
| 1280 | if (i+1 >= objc-1) { | |
| 1281 | Tcl_WrongNumArgs(interp, 3, objv, | |
| 1282 | "?-strict? ?-failindex var? str"); | |
| 1283 | return TCL_ERROR; | |
| 1284 | } | |
| 1285 | failVarObj = objv[++i]; | |
| 1286 | } else { | |
| 1287 | Tcl_AppendStringsToObj(resultPtr, "bad option \"", | |
| 1288 | string2, "\": must be -strict or -failindex", | |
| 1289 | (char *) NULL); | |
| 1290 | return TCL_ERROR; | |
| 1291 | } | |
| 1292 | } | |
| 1293 | } | |
| 1294 | ||
| 1295 | /* | |
| 1296 | * We get the objPtr so that we can short-cut for some classes | |
| 1297 | * by checking the object type (int and double), but we need | |
| 1298 | * the string otherwise, because we don't want any conversion | |
| 1299 | * of type occuring (as, for example, Tcl_Get*FromObj would do | |
| 1300 | */ | |
| 1301 | objPtr = objv[objc-1]; | |
| 1302 | string1 = Tcl_GetStringFromObj(objPtr, &length1); | |
| 1303 | if (length1 == 0) { | |
| 1304 | if (strict) { | |
| 1305 | result = 0; | |
| 1306 | } | |
| 1307 | goto str_is_done; | |
| 1308 | } | |
| 1309 | end = string1 + length1; | |
| 1310 | ||
| 1311 | /* | |
| 1312 | * When entering here, result == 1 and failat == 0 | |
| 1313 | */ | |
| 1314 | switch ((enum isOptions) index) { | |
| 1315 | case STR_IS_ALNUM: | |
| 1316 | chcomp = Tcl_UniCharIsAlnum; | |
| 1317 | break; | |
| 1318 | case STR_IS_ALPHA: | |
| 1319 | chcomp = Tcl_UniCharIsAlpha; | |
| 1320 | break; | |
| 1321 | case STR_IS_ASCII: | |
| 1322 | for (; string1 < end; string1++, failat++) { | |
| 1323 | /* | |
| 1324 | * This is a valid check in unicode, because all | |
| 1325 | * bytes < 0xC0 are single byte chars (but isascii | |
| 1326 | * limits that def'n to 0x80). | |
| 1327 | */ | |
| 1328 | if (*((unsigned char *)string1) >= 0x80) { | |
| 1329 | result = 0; | |
| 1330 | break; | |
| 1331 | } | |
| 1332 | } | |
| 1333 | break; | |
| 1334 | case STR_IS_BOOL: | |
| 1335 | case STR_IS_TRUE: | |
| 1336 | case STR_IS_FALSE: | |
| 1337 | if (objPtr->typePtr == &tclBooleanType) { | |
| 1338 | if ((((enum isOptions) index == STR_IS_TRUE) && | |
| 1339 | objPtr->internalRep.longValue == 0) || | |
| 1340 | (((enum isOptions) index == STR_IS_FALSE) && | |
| 1341 | objPtr->internalRep.longValue != 0)) { | |
| 1342 | result = 0; | |
| 1343 | } | |
| 1344 | } else if ((Tcl_GetBoolean(NULL, string1, &i) | |
| 1345 | == TCL_ERROR) || | |
| 1346 | (((enum isOptions) index == STR_IS_TRUE) && | |
| 1347 | i == 0) || | |
| 1348 | (((enum isOptions) index == STR_IS_FALSE) && | |
| 1349 | i != 0)) { | |
| 1350 | result = 0; | |
| 1351 | } | |
| 1352 | break; | |
| 1353 | case STR_IS_CONTROL: | |
| 1354 | chcomp = Tcl_UniCharIsControl; | |
| 1355 | break; | |
| 1356 | case STR_IS_DIGIT: | |
| 1357 | chcomp = Tcl_UniCharIsDigit; | |
| 1358 | break; | |
| 1359 | case STR_IS_DOUBLE: { | |
| 1360 | char *stop; | |
| 1361 | ||
| 1362 | if ((objPtr->typePtr == &tclDoubleType) || | |
| 1363 | (objPtr->typePtr == &tclIntType)) { | |
| 1364 | break; | |
| 1365 | } | |
| 1366 | /* | |
| 1367 | * This is adapted from Tcl_GetDouble | |
| 1368 | * | |
| 1369 | * The danger in this function is that | |
| 1370 | * "12345678901234567890" is an acceptable 'double', | |
| 1371 | * but will later be interp'd as an int by something | |
| 1372 | * like [expr]. Therefore, we check to see if it looks | |
| 1373 | * like an int, and if so we do a range check on it. | |
| 1374 | * If strtoul gets to the end, we know we either | |
| 1375 | * received an acceptable int, or over/underflow | |
| 1376 | */ | |
| 1377 | if (TclLooksLikeInt(string1, length1)) { | |
| 1378 | errno = 0; | |
| 1379 | strtoul(string1, &stop, 0); | |
| 1380 | if (stop == end) { | |
| 1381 | if (errno == ERANGE) { | |
| 1382 | result = 0; | |
| 1383 | failat = -1; | |
| 1384 | } | |
| 1385 | break; | |
| 1386 | } | |
| 1387 | } | |
| 1388 | errno = 0; | |
| 1389 | strtod(string1, &stop); /* INTL: Tcl source. */ | |
| 1390 | if (errno == ERANGE) { | |
| 1391 | /* | |
| 1392 | * if (errno == ERANGE), then it was an over/underflow | |
| 1393 | * problem, but in this method, we only want to know | |
| 1394 | * yes or no, so bad flow returns 0 (false) and sets | |
| 1395 | * the failVarObj to the string length. | |
| 1396 | */ | |
| 1397 | result = 0; | |
| 1398 | failat = -1; | |
| 1399 | } else if (stop == string1) { | |
| 1400 | /* | |
| 1401 | * In this case, nothing like a number was found | |
| 1402 | */ | |
| 1403 | result = 0; | |
| 1404 | failat = 0; | |
| 1405 | } else { | |
| 1406 | /* | |
| 1407 | * Assume we sucked up one char per byte | |
| 1408 | * and then we go onto SPACE, since we are | |
| 1409 | * allowed trailing whitespace | |
| 1410 | */ | |
| 1411 | failat = stop - string1; | |
| 1412 | string1 = stop; | |
| 1413 | chcomp = Tcl_UniCharIsSpace; | |
| 1414 | } | |
| 1415 | break; | |
| 1416 | } | |
| 1417 | case STR_IS_GRAPH: | |
| 1418 | chcomp = Tcl_UniCharIsGraph; | |
| 1419 | break; | |
| 1420 | case STR_IS_INT: { | |
| 1421 | char *stop; | |
| 1422 | ||
| 1423 | if ((objPtr->typePtr == &tclIntType) || | |
| 1424 | (Tcl_GetInt(NULL, string1, &i) == TCL_OK)) { | |
| 1425 | break; | |
| 1426 | } | |
| 1427 | /* | |
| 1428 | * Like STR_IS_DOUBLE, but we use strtoul. | |
| 1429 | * Since Tcl_GetInt already failed, we set result to 0. | |
| 1430 | */ | |
| 1431 | result = 0; | |
| 1432 | errno = 0; | |
| 1433 | strtoul(string1, &stop, 0); /* INTL: Tcl source. */ | |
| 1434 | if (errno == ERANGE) { | |
| 1435 | /* | |
| 1436 | * if (errno == ERANGE), then it was an over/underflow | |
| 1437 | * problem, but in this method, we only want to know | |
| 1438 | * yes or no, so bad flow returns 0 (false) and sets | |
| 1439 | * the failVarObj to the string length. | |
| 1440 | */ | |
| 1441 | failat = -1; | |
| 1442 | } else if (stop == string1) { | |
| 1443 | /* | |
| 1444 | * In this case, nothing like a number was found | |
| 1445 | */ | |
| 1446 | failat = 0; | |
| 1447 | } else { | |
| 1448 | /* | |
| 1449 | * Assume we sucked up one char per byte | |
| 1450 | * and then we go onto SPACE, since we are | |
| 1451 | * allowed trailing whitespace | |
| 1452 | */ | |
| 1453 | failat = stop - string1; | |
| 1454 | string1 = stop; | |
| 1455 | chcomp = Tcl_UniCharIsSpace; | |
| 1456 | } | |
| 1457 | break; | |
| 1458 | } | |
| 1459 | case STR_IS_LOWER: | |
| 1460 | chcomp = Tcl_UniCharIsLower; | |
| 1461 | break; | |
| 1462 | case STR_IS_PRINT: | |
| 1463 | chcomp = Tcl_UniCharIsPrint; | |
| 1464 | break; | |
| 1465 | case STR_IS_PUNCT: | |
| 1466 | chcomp = Tcl_UniCharIsPunct; | |
| 1467 | break; | |
| 1468 | case STR_IS_SPACE: | |
| 1469 | chcomp = Tcl_UniCharIsSpace; | |
| 1470 | break; | |
| 1471 | case STR_IS_UPPER: | |
| 1472 | chcomp = Tcl_UniCharIsUpper; | |
| 1473 | break; | |
| 1474 | case STR_IS_WORD: | |
| 1475 | chcomp = Tcl_UniCharIsWordChar; | |
| 1476 | break; | |
| 1477 | case STR_IS_XDIGIT: { | |
| 1478 | for (; string1 < end; string1++, failat++) { | |
| 1479 | /* INTL: We assume unicode is bad for this class */ | |
| 1480 | if ((*((unsigned char *)string1) >= 0xC0) || | |
| 1481 | !isxdigit(*(unsigned char *)string1)) { | |
| 1482 | result = 0; | |
| 1483 | break; | |
| 1484 | } | |
| 1485 | } | |
| 1486 | break; | |
| 1487 | } | |
| 1488 | } | |
| 1489 | if (chcomp != NULL) { | |
| 1490 | for (; string1 < end; string1 += length2, failat++) { | |
| 1491 | length2 = Tcl_UtfToUniChar(string1, &ch); | |
| 1492 | if (!chcomp(ch)) { | |
| 1493 | result = 0; | |
| 1494 | break; | |
| 1495 | } | |
| 1496 | } | |
| 1497 | } | |
| 1498 | str_is_done: | |
| 1499 | /* | |
| 1500 | * Only set the failVarObj when we will return 0 | |
| 1501 | * and we have indicated a valid fail index (>= 0) | |
| 1502 | */ | |
| 1503 | if ((result == 0) && (failVarObj != NULL) && | |
| 1504 | Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), | |
| 1505 | TCL_LEAVE_ERR_MSG) == NULL) { | |
| 1506 | return TCL_ERROR; | |
| 1507 | } | |
| 1508 | Tcl_SetBooleanObj(resultPtr, result); | |
| 1509 | break; | |
| 1510 | } | |
| 1511 | case STR_LAST: { | |
| 1512 | register char *p; | |
| 1513 | int match, utflen, start; | |
| 1514 | ||
| 1515 | if (objc < 4 || objc > 5) { | |
| 1516 | Tcl_WrongNumArgs(interp, 2, objv, | |
| 1517 | "string1 string2 ?startIndex?"); | |
| 1518 | return TCL_ERROR; | |
| 1519 | } | |
| 1520 | ||
| 1521 | /* | |
| 1522 | * This algorithm fails on improperly formed UTF strings. | |
| 1523 | */ | |
| 1524 | ||
| 1525 | match = -1; | |
| 1526 | start = 0; | |
| 1527 | utflen = -1; | |
| 1528 | string1 = Tcl_GetStringFromObj(objv[2], &length1); | |
| 1529 | string2 = Tcl_GetStringFromObj(objv[3], &length2); | |
| 1530 | ||
| 1531 | if (objc == 5) { | |
| 1532 | /* | |
| 1533 | * If a startIndex is specified, we will need to restrict | |
| 1534 | * the string range to that char index in the string | |
| 1535 | */ | |
| 1536 | utflen = Tcl_NumUtfChars(string2, length2); | |
| 1537 | if (TclGetIntForIndex(interp, objv[4], utflen-1, | |
| 1538 | &start) != TCL_OK) { | |
| 1539 | return TCL_ERROR; | |
| 1540 | } | |
| 1541 | if (start < 0) { | |
| 1542 | goto str_last_done; | |
| 1543 | } else if (start < utflen) { | |
| 1544 | if (length2 == utflen) { | |
| 1545 | /* no unicode chars */ | |
| 1546 | p = string2 + start + 1 - length1; | |
| 1547 | } else { | |
| 1548 | p = Tcl_UtfAtIndex(string2, start+1) - length1; | |
| 1549 | } | |
| 1550 | } else { | |
| 1551 | p = string2 + length2 - length1; | |
| 1552 | } | |
| 1553 | } else { | |
| 1554 | p = string2 + length2 - length1; | |
| 1555 | } | |
| 1556 | ||
| 1557 | if (length1 > 0) { | |
| 1558 | for (; p >= string2; p--) { | |
| 1559 | /* | |
| 1560 | * Scan backwards to find the first character. | |
| 1561 | */ | |
| 1562 | ||
| 1563 | while ((p != string2) && (*p != *string1)) { | |
| 1564 | p--; | |
| 1565 | } | |
| 1566 | if (memcmp(string1, p, (unsigned) length1) == 0) { | |
| 1567 | match = p - string2; | |
| 1568 | break; | |
| 1569 | } | |
| 1570 | } | |
| 1571 | } | |
| 1572 | ||
| 1573 | /* | |
| 1574 | * Compute the character index of the matching string by counting | |
| 1575 | * the number of characters before the match. | |
| 1576 | */ | |
| 1577 | str_last_done: | |
| 1578 | if (match != -1) { | |
| 1579 | if ((objc == 4) || (length2 != utflen)) { | |
| 1580 | /* only check when we've got unicode chars */ | |
| 1581 | match = Tcl_NumUtfChars(string2, match); | |
| 1582 | } | |
| 1583 | } | |
| 1584 | Tcl_SetIntObj(resultPtr, match); | |
| 1585 | break; | |
| 1586 | } | |
| 1587 | case STR_BYTELENGTH: | |
| 1588 | case STR_LENGTH: { | |
| 1589 | if (objc != 3) { | |
| 1590 | Tcl_WrongNumArgs(interp, 2, objv, "string"); | |
| 1591 | return TCL_ERROR; | |
| 1592 | } | |
| 1593 | ||
| 1594 | if ((enum options) index == STR_BYTELENGTH) { | |
| 1595 | &n |