/* * tclCmdMZ.c -- * * This file contains the top-level command routines for most of * the Tcl built-in commands whose names begin with the letters * M to Z. It contains only commands in the generic core (i.e. * those that don't depend much upon UNIX facilities). * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Scriptics Corporation. * * 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.57 2002/02/02 00:20:54 hobbs Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclRegexp.h" /* * Structure used to hold information about variable traces: */ typedef struct { int flags; /* Operations for which Tcl command is * to be invoked. */ 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; /* * The same structure is used for command traces at present */ typedef TraceVarInfo TraceCommandInfo; /* * Forward declarations for procedures defined in this file: */ typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp, int optionIndex, int objc, Tcl_Obj *CONST objv[])); Tcl_TraceTypeObjCmd TclTraceVariableObjCmd; Tcl_TraceTypeObjCmd TclTraceCommandObjCmd; /* * Each subcommand has a number of 'types' to which it can apply. * Currently 'command' and 'variable' are the only * types supported. These two arrays MUST be kept in sync! * In the future we may provide an API to add to the list of * supported trace types. */ static CONST char *traceTypeOptions[] = { "command", "variable", (char*) NULL }; static Tcl_TraceTypeObjCmd* traceSubCmds[] = { TclTraceCommandObjCmd, TclTraceVariableObjCmd, }; static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); static void TraceCommandProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, CONST char *oldName, CONST char *newName, 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_Obj *retVal; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } retVal = Tcl_FSGetCwd(interp); if (retVal == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, retVal); Tcl_DecrRefCount(retVal); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_RegexpObjCmd -- * * This procedure is invoked to process the "regexp" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_RegexpObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int i, indices, match, about, offset, all, doinline, numMatchesSaved; int cflags, eflags, stringLength; Tcl_RegExp regExpr; Tcl_Obj *objPtr, *resultPtr; Tcl_RegExpInfo info; static CONST char *options[] = { "-all", "-about", "-indices", "-inline", "-expanded", "-line", "-linestop", "-lineanchor", "-nocase", "-start", "--", (char *) NULL }; enum options { REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE, REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR, REGEXP_NOCASE, REGEXP_START, REGEXP_LAST }; indices = 0; about = 0; cflags = TCL_REG_ADVANCED; eflags = 0; offset = 0; all = 0; doinline = 0; for (i = 1; i < objc; i++) { char *name; int index; name = Tcl_GetString(objv[i]); if (name[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { case REGEXP_ALL: { all = 1; break; } case REGEXP_INDICES: { indices = 1; break; } case REGEXP_INLINE: { doinline = 1; break; } case REGEXP_NOCASE: { cflags |= TCL_REG_NOCASE; break; } case REGEXP_ABOUT: { about = 1; break; } case REGEXP_EXPANDED: { cflags |= TCL_REG_EXPANDED; break; } case REGEXP_LINE: { cflags |= TCL_REG_NEWLINE; break; } case REGEXP_LINESTOP: { cflags |= TCL_REG_NLSTOP; break; } case REGEXP_LINEANCHOR: { cflags |= TCL_REG_NLANCH; break; } case REGEXP_START: { if (++i >= objc) { goto endOfForLoop; } if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) { return TCL_ERROR; } if (offset < 0) { offset = 0; } break; } case REGEXP_LAST: { i++; goto endOfForLoop; } } } endOfForLoop: if ((objc - i) < (2 - about)) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); return TCL_ERROR; } objc -= i; objv += i; if (doinline && ((objc - 2) != 0)) { /* * User requested -inline, but specified match variables - a no-no. */ Tcl_AppendResult(interp, "regexp match variables not allowed", " when using -inline", (char *) NULL); return TCL_ERROR; } /* * Handle the odd about case separately. */ if (about) { regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) { return TCL_ERROR; } return TCL_OK; } /* * Get the length of the string that we are matching against so * we can do the termination test for -all matches. Do this before * getting the regexp to avoid shimmering problems. */ objPtr = objv[1]; stringLength = Tcl_GetCharLength(objPtr); regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if (regExpr == NULL) { return TCL_ERROR; } if (offset > 0) { /* * Add flag if using offset (string is part of a larger string), * so that "^" won't match. */ eflags |= TCL_REG_NOTBOL; } objc -= 2; objv += 2; resultPtr = Tcl_GetObjResult(interp); if (doinline) { /* * Save all the subexpressions, as we will return them as a list */ numMatchesSaved = -1; } else { /* * Save only enough subexpressions for matches we want to keep, * expect in the case of -all, where we need to keep at least * one to know where to move the offset. */ numMatchesSaved = (objc == 0) ? all : objc; } /* * The following loop is to handle multiple matches within the * same source string; each iteration handles one match. If "-all" * hasn't been specified then the loop body only gets executed once. * We terminate the loop when the starting offset is past the end of the * string. */ while (1) { match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset /* offset */, numMatchesSaved, eflags); if (match < 0) { return TCL_ERROR; } if (match == 0) { /* * We want to set the value of the intepreter result only when * this is the first time through the loop. */ if (all <= 1) { /* * If inlining, set the interpreter's object result to an * empty list, otherwise set it to an integer object w/ * value 0. */ if (doinline) { Tcl_SetListObj(resultPtr, 0, NULL); } else { Tcl_SetIntObj(resultPtr, 0); } return TCL_OK; } break; } /* * If additional variable names have been specified, return * index information in those variables. */ Tcl_RegExpGetInfo(regExpr, &info); if (doinline) { /* * It's the number of substitutions, plus one for the matchVar * at index 0 */ objc = info.nsubs + 1; } for (i = 0; i < objc; i++) { Tcl_Obj *newPtr; if (indices) { int start, end; Tcl_Obj *objs[2]; /* * Only adjust the match area if there was a match for * that area. (Scriptics Bug 4391/SF Bug #219232) */ if (i <= info.nsubs && info.matches[i].start >= 0) { start = offset + info.matches[i].start; end = offset + info.matches[i].end; /* * Adjust index so it refers to the last character in the * match instead of the first character after the match. */ if (end >= offset) { end--; } } else { start = -1; end = -1; } objs[0] = Tcl_NewLongObj(start); objs[1] = Tcl_NewLongObj(end); newPtr = Tcl_NewListObj(2, objs); } else { if (i <= info.nsubs) { newPtr = Tcl_GetRange(objPtr, offset + info.matches[i].start, offset + info.matches[i].end - 1); } else { newPtr = Tcl_NewObj(); } } if (doinline) { if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr) != TCL_OK) { Tcl_DecrRefCount(newPtr); return TCL_ERROR; } } else { Tcl_Obj *valuePtr; valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); if (valuePtr == NULL) { Tcl_DecrRefCount(newPtr); Tcl_AppendResult(interp, "couldn't set variable \"", Tcl_GetString(objv[i]), "\"", (char *) NULL); return TCL_ERROR; } } } if (all == 0) { break; } /* * Adjust the offset to the character just after the last one * in the matchVar and increment all to count how many times * we are making a match. We always increment the offset by at least * one to prevent endless looping (as in the case: * regexp -all {a*} a). Otherwise, when we match the NULL string at * the end of the input string, we will loop indefinately (because the * length of the match is 0, so offset never changes). */ if (info.matches[0].end == 0) { offset++; } offset += info.matches[0].end; all++; eflags |= TCL_REG_NOTBOL; if (offset >= stringLength) { break; } } /* * Set the interpreter's object result to an integer object * with value 1 if -all wasn't specified, otherwise it's all-1 * (the number of times through the while - 1). */ 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 idx, result, cflags, all, wlen, wsublen, numMatches, offset; int start, end, subStart, subEnd, match; Tcl_RegExp regExpr; Tcl_RegExpInfo info; Tcl_Obj *resultPtr, *subPtr, *objPtr; Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; static CONST char *options[] = { "-all", "-nocase", "-expanded", "-line", "-linestop", "-lineanchor", "-start", "--", NULL }; enum options { REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED, REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START, REGSUB_LAST }; cflags = TCL_REG_ADVANCED; all = 0; offset = 0; for (idx = 1; idx < objc; idx++) { char *name; int index; name = Tcl_GetString(objv[idx]); if (name[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { case REGSUB_ALL: { all = 1; break; } case REGSUB_NOCASE: { cflags |= TCL_REG_NOCASE; break; } case REGSUB_EXPANDED: { cflags |= TCL_REG_EXPANDED; break; } case REGSUB_LINE: { cflags |= TCL_REG_NEWLINE; break; } case REGSUB_LINESTOP: { cflags |= TCL_REG_NLSTOP; break; } case REGSUB_LINEANCHOR: { cflags |= TCL_REG_NLANCH; break; } case REGSUB_START: { if (++idx >= objc) { goto endOfForLoop; } if (Tcl_GetIntFromObj(interp, objv[idx], &offset) != TCL_OK) { return TCL_ERROR; } if (offset < 0) { offset = 0; } break; } case REGSUB_LAST: { idx++; goto endOfForLoop; } } } endOfForLoop: if (objc - idx != 4) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string subSpec varName"); return TCL_ERROR; } objv += idx; regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if (regExpr == NULL) { return TCL_ERROR; } /* * Make sure to avoid problems where the objects are shared. This * can cause RegExpObj <> UnicodeObj shimmering that causes data * corruption. [Bug #461322] */ if (objv[1] == objv[0]) { objPtr = Tcl_DuplicateObj(objv[1]); } else { objPtr = objv[1]; } wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); if (objv[2] == objv[0]) { subPtr = Tcl_DuplicateObj(objv[2]); } else { subPtr = objv[2]; } wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); result = TCL_OK; resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); /* * 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; ) { /* * 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. */ wsrc = wfirstChar = wsubspec; wend = wsubspec + wsublen; for (ch = *wsrc; wsrc != wend; wsrc++, ch = *wsrc) { if (ch == '&') { idx = 0; } else if (ch == '\\') { ch = wsrc[1]; if ((ch >= '0') && (ch <= '9')) { idx = ch - '0'; } else if ((ch == '\\') || (ch == '&')) { *wsrc = ch; Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar + 1); *wsrc = '\\'; wfirstChar = wsrc + 2; wsrc++; continue; } else { continue; } } else { continue; } if (wfirstChar != wsrc) { Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (idx <= info.nsubs) { subStart = info.matches[idx].start; subEnd = info.matches[idx].end; if ((subStart >= 0) && (subEnd >= 0)) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset + subStart, subEnd - subStart); } } if (*wsrc == '\\') { wsrc++; } wfirstChar = wsrc + 1; } if (wfirstChar != wsrc) { Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (end == 0) { /* * Always consume at least one character of the input string * in order to prevent infinite loops. */ Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); offset++; } else { offset += end; } if (!all) { break; } } /* * Copy the portion of the source string after the last match to the * result variable. */ 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, objv[3], NULL, resultPtr, 0) == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", Tcl_GetString(objv[3]), "\"", (char *) NULL); result = TCL_ERROR; } else { /* * Set the interpreter's object result to an integer object * holding the number of matches. */ Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches); } done: if (objv[1] == objv[0]) { Tcl_DecrRefCount(objPtr); } if (objv[2] == objv[0]) { Tcl_DecrRefCount(subPtr); } 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. */ { if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "fileName"); return TCL_ERROR; } return Tcl_FSEvalFile(interp, objv[1]); } /* *---------------------------------------------------------------------- * * Tcl_SplitObjCmd -- * * This procedure is invoked to process the "split" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_SplitObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_UniChar ch; int len; char *splitChars, *string, *end; int splitCharLen, stringLen; Tcl_Obj *listPtr, *objPtr; if (objc == 2) { splitChars = " \n\t\r"; splitCharLen = 4; } else if (objc == 3) { splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?"); return TCL_ERROR; } string = Tcl_GetStringFromObj(objv[1], &stringLen); end = string + stringLen; listPtr = Tcl_GetObjResult(interp); if (stringLen == 0) { /* * Do nothing. */ } else if (splitCharLen == 0) { Tcl_HashTable charReuseTable; Tcl_HashEntry *hPtr; int isNew; /* * Handle the special case of splitting on every character. * * Uses a hash table to ensure that each kind of character has * only one Tcl_Obj instance (multiply-referenced) in the * final list. This is a *major* win when splitting on a long * string (especially in the megabyte range!) - DKF */ Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); for ( ; string < end; string += len) { len = Tcl_UtfToUniChar(string, &ch); /* Assume Tcl_UniChar is an integral type... */ hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew); if (isNew) { objPtr = Tcl_NewStringObj(string, len); /* Don't need to fiddle with refcount... */ Tcl_SetHashValue(hPtr, (ClientData) objPtr); } else { objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr); } Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } Tcl_DeleteHashTable(&charReuseTable); } else { 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 CONST char *options[] = { "bytelength", "compare", "equal", "first", "index", "is", "last", "length", "map", "match", "range", "repeat", "replace", "tolower", "toupper", "totitle", "trim", "trimleft", "trimright", "wordend", "wordstart", (char *) NULL }; enum options { STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST, STR_INDEX, STR_IS, STR_LAST, STR_LENGTH, STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT, STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, STR_WORDEND, STR_WORDSTART }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } resultPtr = Tcl_GetObjResult(interp); switch ((enum options) index) { case STR_EQUAL: case STR_COMPARE: { /* * Remember to keep code here in some sync with the * byte-compiled versions in tclExecute.c (INST_STR_EQ, * INST_STR_NEQ and INST_STR_CMP as well as the expr string * comparison in INST_EQ/INST_NEQ/INST_LT/...). */ int i, match, length, nocase = 0, reqlength = -1; 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; } } if (reqlength == 0) { /* * Anything matches at 0 chars, right? */ match = 0; goto stringComparisonDone; } /* * From now on, we only access the two objects at the end * of the argument array. */ objv += objc-2; /* * Use binary versions of comparisons since that won't * cause undue type conversions and it is much faster. * Only do this if we're case-sensitive (which is all * that really makes sense with byte arrays anyway, and * we have no memcasecmp() for some reason... :^) */ if (!nocase && objv[0]->typePtr == &tclByteArrayType && objv[1]->typePtr == &tclByteArrayType) { unsigned char *bytes1, *bytes2; bytes1 = Tcl_GetByteArrayFromObj(objv[0], &length1); bytes2 = Tcl_GetByteArrayFromObj(objv[1], &length2); length = (length1 < length2) ? length1 : length2; if ((reqlength > 0) && (reqlength < length)) { length = reqlength; } else if (reqlength < 0) { /* * The requested length is negative, so we ignore it by * setting it to the longer of the two lengths. */ reqlength = (length1 > length2) ? length1 : length2; } match = memcmp(bytes1, bytes2, (unsigned)length); if ((match == 0) && (reqlength > length)) { match = length1 - length2; } goto stringComparisonDone; } /* * Use UNICODE versions of string comparisons since that * won't cause undue type conversions and we can work with * characters all of a fixed size (much faster.) Also use * this code for untyped objects, since like that we'll * pick up many things that are used for comparison in * scripts and convert them (efficiently) to UNICODE * strings for comparison, but exclude case where both are * untyped as that is a little bit aggressive. */ if ((objv[0]->typePtr == &tclStringType || objv[0]->typePtr == NULL) && (objv[1]->typePtr == &tclStringType || objv[1]->typePtr == NULL) && !(objv[0]->typePtr == NULL && objv[1]->typePtr == NULL)) { Tcl_UniChar *uni1, *uni2; uni1 = Tcl_GetUnicodeFromObj(objv[0], &length1); uni2 = Tcl_GetUnicodeFromObj(objv[1], &length2); length = (length1 < length2) ? length1 : length2; if (reqlength > 0 && reqlength < length) { length = reqlength; } else if (reqlength < 0) { /* * The requested length is negative, so we ignore it by * setting it to the longer of the two lengths. */ reqlength = (length1 < length2) ? length2 : length1; } if (nocase) { match = Tcl_UniCharNcasecmp(uni1, uni2, (unsigned)length); } else { match = Tcl_UniCharNcmp(uni1, uni2, (unsigned)length); } if ((match == 0) && (reqlength > length)) { match = length1 - length2; } goto stringComparisonDone; } /* * Strings to be compared are not both UNICODE or byte * arrays, so we will need to convert to UTF-8 and work * there (cannot use memcmp() as that is an unsafe * operation with any string containing \u0000 and the * safety test is equivalent in cost to the comparison * itself!) */ string1 = Tcl_GetStringFromObj(objv[0], &length1); string2 = Tcl_GetStringFromObj(objv[1], &length2); length1 = Tcl_NumUtfChars(string1, length1); length2 = Tcl_NumUtfChars(string2, length2); length = (length1 < length2) ? length1 : length2; if ((reqlength > 0) && (reqlength < length)) { length = reqlength; } else if (reqlength < 0) { /* * The requested length is negative, so we ignore it by * setting it to 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; } stringComparisonDone: if ((enum options) index == STR_EQUAL) { Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1); } else { Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 : (match < 0) ? -1 : 0)); } break; } case STR_FIRST: { Tcl_UniChar *ustring1, *ustring2; int match, start; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "subString string ?startIndex?"); return TCL_ERROR; } /* * We are searching string2 for the sequence string1. */ match = -1; start = 0; length2 = -1; ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); if (objc == 5) { /* * If a startIndex is specified, we will need to fast * forward to that point in the string before we think * about a match */ if (TclGetIntForIndex(interp, objv[4], length2 - 1, &start) != TCL_OK) { return TCL_ERROR; } if (start >= length2) { goto str_first_done; } else if (start > 0) { ustring2 += start; length2 -= start; } else if (start < 0) { /* * Invalid start index mapped to string start; * Bug #423581 */ start = 0; } } if (length1 > 0) { register Tcl_UniChar *p, *end; end = ustring2 + length2 - length1 + 1; for (p = ustring2; p < end; p++) { /* * Scan forward to find the first character. */ if ((*p == *ustring1) && (Tcl_UniCharNcmp(ustring1, p, (unsigned long) length1) == 0)) { match = p - ustring2; break; } } } /* * Compute the character index of the matching string by * counting the number of characters before the match. */ if ((match != -1) && (objc == 5)) { match += start; } str_first_done: Tcl_SetIntObj(resultPtr, match); break; } case STR_INDEX: { if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); return TCL_ERROR; } /* * If we have a ByteArray object, avoid indexing in the * Utf string since the byte array contains one byte per * character. Otherwise, use the Unicode string rep to * get the index'th char. */ if (objv[2]->typePtr == &tclByteArrayType) { string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1); if (TclGetIntForIndex(interp, objv[3], length1 - 1, &index) != TCL_OK) { return TCL_ERROR; } if ((index >= 0) && (index < length1)) { Tcl_SetByteArrayObj(resultPtr, (unsigned char *)(&string1[index]), 1); } } else { /* * Get Unicode char length to calulate what 'end' means. */ length1 = Tcl_GetCharLength(objv[2]); if (TclGetIntForIndex(interp, objv[3], length1 - 1, &index) != TCL_OK) { return TCL_ERROR; } if ((index >= 0) && (index < length1)) { char buf[TCL_UTF_MAX]; Tcl_UniChar ch; ch = Tcl_GetUniChar(objv[2], index); length1 = Tcl_UniCharToUtf(ch, buf); Tcl_SetStringObj(resultPtr, buf, length1); } } break; } case STR_IS: { char *end; Tcl_UniChar ch; /* * The UniChar comparison function */ int (*chcomp)_ANSI_ARGS_((int)) = NULL; int i, failat = 0, result = 1, strict = 0; Tcl_Obj *objPtr, *failVarObj = NULL; static CONST char *isOptions[] = { "alnum", "alpha", "ascii", "control", "boolean", "digit", "double", "false", "graph", "integer", "lower", "print", "punct", "space", "true", "upper", "wordchar", "xdigit", (char *) NULL }; enum isOptions { STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WORD, STR_IS_XDIGIT }; if (objc < 4 || objc > 7) { Tcl_WrongNumArgs(interp, 2, objv, "class ?-strict? ?-failindex var? str"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0, &index) != TCL_OK) { return TCL_ERROR; } if (objc != 4) { for (i = 3; i < objc-1; i++) { string2 = Tcl_GetStringFromObj(objv[i], &length2); if ((length2 > 1) && strncmp(string2, "-strict", (size_t) length2) == 0) { strict = 1; } else if ((length2 > 1) && strncmp(string2, "-failindex", (size_t) length2) == 0) { if (i+1 >= objc-1) { Tcl_WrongNumArgs(interp, 3, objv, "?-strict? ?-failindex var? str"); return TCL_ERROR; } failVarObj = objv[++i]; } else { Tcl_AppendStringsToObj(resultPtr, "bad option \"", string2, "\": must be -strict or -failindex", (char *) NULL); return TCL_ERROR; } } } /* * We get the objPtr so that we can short-cut for some classes * by checking the object type (int and double), but we need * the string otherwise, because we don't want any conversion * of type occuring (as, for example, Tcl_Get*FromObj would do */ objPtr = objv[objc-1]; string1 = Tcl_GetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { result = 0; } goto str_is_done; } end = string1 + length1; /* * When entering here, result == 1 and failat == 0 */ switch ((enum isOptions) index) { case STR_IS_ALNUM: chcomp = Tcl_UniCharIsAlnum; break; case STR_IS_ALPHA: chcomp = Tcl_UniCharIsAlpha; break; case STR_IS_ASCII: for (; string1 < end; string1++, failat++) { /* * This is a valid check in unicode, because all * bytes < 0xC0 are single byte chars (but isascii * limits that def'n to 0x80). */ if (*((unsigned char *)string1) >= 0x80) { result = 0; break; } } break; case STR_IS_BOOL: case STR_IS_TRUE: case STR_IS_FALSE: if (objPtr->typePtr == &tclBooleanType) { if ((((enum isOptions) index == STR_IS_TRUE) && objPtr->internalRep.longValue == 0) || (((enum isOptions) index == STR_IS_FALSE) && objPtr->internalRep.longValue != 0)) { result = 0; } } else if ((Tcl_GetBoolean(NULL, string1, &i) == TCL_ERROR) || (((enum isOptions) index == STR_IS_TRUE) && i == 0) || (((enum isOptions) index == STR_IS_FALSE) && i != 0)) { result = 0; } break; case STR_IS_CONTROL: chcomp = Tcl_UniCharIsControl; break; case STR_IS_DIGIT: chcomp = Tcl_UniCharIsDigit; break; case STR_IS_DOUBLE: { char *stop; if ((objPtr->typePtr == &tclDoubleType) || (objPtr->typePtr == &tclIntType)) { break; } /* * This is adapted from Tcl_GetDouble * * The danger in this function is that * "12345678901234567890" is an acceptable 'double', * but will later be interp'd as an int by something * like [expr]. Therefore, we check to see if it looks * like an int, and if so we do a range check on it. * If strtoul gets to the end, we know we either * received an acceptable int, or over/underflow */ if (TclLooksLikeInt(string1, length1)) { errno = 0; 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: { Tcl_UniChar *ustring1, *ustring2, *p; int match, start; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "subString string ?startIndex?"); return TCL_ERROR; } /* * We are searching string2 for the sequence string1. */ match = -1; start = 0; length2 = -1; ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); if (objc == 5) { /* * If a startIndex is specified, we will need to restrict * the string range to that char index in the string */ if (TclGetIntForIndex(interp, objv[4], length2 - 1, &start) != TCL_OK) { return TCL_ERROR; } if (start < 0) { goto str_last_done; } else if (start < length2) { p = ustring2 + start + 1 - length1; } else { p = ustring2 + length2 - length1; } } else { p = ustring2 + length2 - length1; } if (length1 > 0) { for (; p >= ustring2; p--) { /* * Scan backwards to find the first character. */ if ((*p == *ustring1) && (memcmp((char *) ustring1, (char *) p, (size_t) (length1 * sizeof(Tcl_UniChar))) == 0)) { match = p - ustring2; break; } } } str_last_done: Tcl_SetIntObj(resultPtr, match); break; } case STR_BYTELENGTH: case STR_LENGTH: { if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; } if ((enum options) index == STR_BYTELENGTH) { (void) Tcl_GetStringFromObj(objv[2], &length1); } else { /* * If we have a ByteArray object, avoid recomputing the * string since the byte array contains one byte per * character. Otherwise, use the Unicode string rep to * calculate the length. */ if (objv[2]->typePtr == &tclByteArrayType) { (void) Tcl_GetByteArrayFromObj(objv[2], &length1); } else { length1 = Tcl_GetCharLength(objv[2]); } } Tcl_SetIntObj(resultPtr, length1); break; } case STR_MAP: { int mapElemc, nocase = 0; Tcl_Obj **mapElemv; Tcl_UniChar *ustring1, *ustring2, *p, *end; int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*, CONST Tcl_UniChar*, unsigned long)); if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string"); return TCL_ERROR; } if (objc == 5) { string2 = Tcl_GetStringFromObj(objv[2], &length2); if ((length2 > 1) && strncmp(string2, "-nocase", (size_t) length2) == 0) { nocase = 1; } else { Tcl_AppendStringsToObj(resultPtr, "bad option \"", string2, "\": must be -nocase", (char *) NULL); return TCL_ERROR; } } if (Tcl_ListObjGetElements(interp, objv[objc-2], &mapElemc, &mapElemv) != TCL_OK) { return TCL_ERROR; } if (mapElemc == 0) { /* * empty charMap, just return whatever string was given */ Tcl_SetObjResult(interp, objv[objc-1]); return TCL_OK; } else if (mapElemc & 1) { /* * The charMap must be an even number of key/value items */ Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1); return TCL_ERROR; } objc--; ustring1 = Tcl_GetUnicodeFromObj(objv[objc], &length1); if (length1 == 0) { /* * Empty input string, just stop now */ break; } end = ustring1 + length1; strCmpFn = (nocase) ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; /* * Force result to be Unicode */ Tcl_SetUnicodeObj(resultPtr, ustring1, 0); if (mapElemc == 2) { /* * Special case for one map pair which avoids the extra * for loop and extra calls to get Unicode data. The * algorithm is otherwise identical to the multi-pair case. * This will be >30% faster on larger strings. */ int mapLen; Tcl_UniChar *mapString; ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); for (p = ustring1; ustring1 < end; ustring1++) { if ((length2 > 0) && (nocase || (*ustring1 == *ustring2)) && (strCmpFn(ustring1, ustring2, (unsigned long) length2) == 0)) { if (p != ustring1) { Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); } } } else { Tcl_UniChar **mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2) * sizeof(Tcl_UniChar *)); int *mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int)); /* * Precompute pointers to the unicode string and length. * This saves us repeated function calls later, * significantly speeding up the algorithm. */ for (index = 0; index < mapElemc; index++) { mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], &(mapLens[index])); } for (p = ustring1; ustring1 < end; ustring1++) { for (index = 0; index < mapElemc; index += 2) { /* * Get the key string to match on */ ustring2 = mapStrings[index]; length2 = mapLens[index]; if ((length2 > 0) && (nocase || (*ustring1 == *ustring2)) && (strCmpFn(ustring2, ustring1, (unsigned long) length2) == 0)) { if (p != ustring1) { /* * Put the skipped chars onto the result first */ Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); p = ustring1 + length2; } else { p += length2; } /* * Adjust len to be full length of matched string */ ustring1 = p - 1; /* * Append the map value to the unicode string */ Tcl_AppendUnicodeToObj(resultPtr, mapStrings[index+1], mapLens[index+1]); break; } } } ckfree((char *) mapStrings); ckfree((char *) mapLens); } if (p != ustring1) { /* * Put the rest of the unmapped chars onto result */ Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); } break; } case STR_MATCH: { int nocase = 0; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string"); return TCL_ERROR; } if (objc == 5) { string2 = Tcl_GetStringFromObj(objv[2], &length2); if ((length2 > 1) && strncmp(string2, "-nocase", (size_t) length2) == 0) { nocase = 1; } else { Tcl_AppendStringsToObj(resultPtr, "bad option \"", string2, "\": must be -nocase", (char *) NULL); return TCL_ERROR; } } Tcl_SetBooleanObj(resultPtr, Tcl_UniCharCaseMatch(Tcl_GetUnicode(objv[objc-1]), Tcl_GetUnicode(objv[objc-2]), nocase)); break; } case STR_RANGE: { int first, last; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "string first last"); return TCL_ERROR; } /* * Get the length in actual characters. */ length1 = Tcl_GetCharLength(objv[2]) - 1; if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) || (TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK)) { return TCL_ERROR; } if (first < 0) { first = 0; } if (last >= length1) { last = length1; } if (last >= first) { Tcl_SetObjResult(interp, Tcl_GetRange(objv[2], first, last)); } break; } case STR_REPEAT: { int count; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string count"); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) { return TCL_ERROR; } if (count == 1) { Tcl_SetObjResult(interp, objv[2]); } else if (count > 1) { string1 = Tcl_GetStringFromObj(objv[2], &length1); if (length1 > 0) { /* * Only build up a string that has data. Instead of * building it up with repeated appends, we just allocate * the necessary space once and copy the string value in. */ length2 = length1 * count; /* * Include space for the NULL */ string2 = (char *) ckalloc((size_t) length2+1); for (index = 0; index < count; index++) { memcpy(string2 + (length1 * index), string1, (size_t) length1); } string2[length2] = '\0'; /* * We have to directly assign this instead of using * Tcl_SetStringObj (and indirectly TclInitStringRep) * because that makes another copy of the data. */ resultPtr = Tcl_NewObj(); resultPtr->bytes = string2; resultPtr->length = length2; Tcl_SetObjResult(interp, resultPtr); } } break; } case STR_REPLACE: { Tcl_UniChar *ustring1; int first, last; if (objc < 5 || objc > 6) { Tcl_WrongNumArgs(interp, 2, objv, "string first last ?string?"); return TCL_ERROR; } ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); length1--; if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) || (TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK)) { return TCL_ERROR; } if ((last < first) || (last < 0) || (first > length1)) { Tcl_SetObjResult(interp, objv[2]); } else { if (first < 0) { first = 0; } Tcl_SetUnicodeObj(resultPtr, ustring1, first); if (objc == 6) { Tcl_AppendObjToObj(resultPtr, objv[5]); } if (last < length1) { Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1, length1 - last); } } break; } case STR_TOLOWER: case STR_TOUPPER: case STR_TOTITLE: if (objc < 3 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?"); return TCL_ERROR; } string1 = Tcl_GetStringFromObj(objv[2], &length1); if (objc == 3) { /* * Since the result object is not a shared object, it is * safe to copy the string into the result and do the * conversion in place. The conversion may change the length * of the string, so reset the length after conversion. */ Tcl_SetStringObj(resultPtr, string1, length1); if ((enum options) index == STR_TOLOWER) { length1 = Tcl_UtfToLower(Tcl_GetString(resultPtr)); } else if ((enum options) index == STR_TOUPPER) { length1 = Tcl_UtfToUpper(Tcl_GetString(resultPtr)); } else { length1 = Tcl_UtfToTitle(Tcl_GetString(resultPtr)); } Tcl_SetObjLength(resultPtr, length1); } else { int first, last; CONST char *start, *end; length1 = Tcl_NumUtfChars(string1, length1) - 1; if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) { return TCL_ERROR; } if (first < 0) { first = 0; } last = first; if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK)) { return TCL_ERROR; } if (last >= length1) { last = length1; } if (last < first) { Tcl_SetObjResult(interp, objv[2]); break; } start = Tcl_UtfAtIndex(string1, first); end = Tcl_UtfAtIndex(start, last - first + 1); length2 = end-start; string2 = ckalloc((size_t) length2+1); memcpy(string2, start, (size_t) length2); string2[length2] = '\0'; if ((enum options) index == STR_TOLOWER) { length2 = Tcl_UtfToLower(string2); } else if ((enum options) index == STR_TOUPPER) { length2 = Tcl_UtfToUpper(string2); } else { length2 = Tcl_UtfToTitle(string2); } Tcl_SetStringObj(resultPtr, string1, start - string1); Tcl_AppendToObj(resultPtr, string2, length2); Tcl_AppendToObj(resultPtr, end, -1); ckfree(string2); } break; case STR_TRIM: { Tcl_UniChar ch, trim; register CONST char *p, *end; char *check, *checkEnd; int offset; left = 1; right = 1; dotrim: if (objc == 4) { string2 = Tcl_GetStringFromObj(objv[3], &length2); } else if (objc == 3) { string2 = " \t\n\r"; length2 = strlen(string2); } else { Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?"); return TCL_ERROR; } string1 = Tcl_GetStringFromObj(objv[2], &length1); checkEnd = string2 + length2; if (left) { end = string1 + length1; /* * The outer loop iterates over the string. The inner * loop iterates over the trim characters. The loops * terminate as soon as a non-trim character is discovered * and string1 is left pointing at the first non-trim * character. */ for (p = string1; p < end; p += offset) { offset = 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; CONST char *p, *end; int numChars; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string index"); return TCL_ERROR; } string1 = Tcl_GetStringFromObj(objv[2], &length1); numChars = Tcl_NumUtfChars(string1, length1); if (TclGetIntForIndex(interp, objv[3], numChars-1, &index) != TCL_OK) { return TCL_ERROR; } if (index < 0) { index = 0; } if (index < numChars) { p = Tcl_UtfAtIndex(string1, index); end = string1+length1; for (cur = index; p < end; cur++) { p += Tcl_UtfToUniChar(p, &ch); if (!Tcl_UniCharIsWordChar(ch)) { break; } } if (cur == index) { cur++; } } else { cur = numChars; } Tcl_SetIntObj(resultPtr, cur); break; } case STR_WORDSTART: { int cur; Tcl_UniChar ch; CONST char *p; int numChars; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string index"); return TCL_ERROR; } string1 = Tcl_GetStringFromObj(objv[2], &length1); numChars = Tcl_NumUtfChars(string1, length1); if (TclGetIntForIndex(interp, objv[3], numChars-1, &index) != TCL_OK) { return TCL_ERROR; } if (index >= numChars) { index = numChars - 1; } cur = 0; if (index > 0) { p = Tcl_UtfAtIndex(string1, index); for (cur = index; cur >= 0; cur--) { Tcl_UtfToUniChar(p, &ch); if (!Tcl_UniCharIsWordChar(ch)) { break; } p = Tcl_UtfPrev(p, string1); } if (cur != index) { cur += 1; } } Tcl_SetIntObj(resultPtr, cur); break; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SubstObjCmd -- * * This procedure is invoked to process the "subst" Tcl command. * See the user documentation for details on what it does. This * command relies on Tcl_SubstObj() for its implementation. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_SubstObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *substOptions[] = { "-nobackslashes", "-nocommands", "-novariables", (char *) NULL }; enum substOptions { SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS }; Tcl_Obj *resultPtr; int optionIndex, flags, i; /* * Parse command-line options. */ flags = TCL_SUBST_ALL; for (i = 1; i < (objc-1); i++) { if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch (optionIndex) { case SUBST_NOBACKSLASHES: { flags &= ~TCL_SUBST_BACKSLASHES; break; } case SUBST_NOCOMMANDS: { flags &= ~TCL_SUBST_COMMANDS; break; } case SUBST_NOVARS: { flags &= ~TCL_SUBST_VARIABLES; break; } default: { panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); } } } if (i != (objc-1)) { Tcl_WrongNumArgs(interp, 1, objv, "?-nobackslashes? ?-nocommands? ?-novariables? string"); return TCL_ERROR; } /* * Perform the substitution. */ resultPtr = Tcl_SubstObj(interp, objv[i], flags); if (resultPtr == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SubstObj -- * * This function performs the substitutions specified on the * given string as described in the user documentation for the * "subst" Tcl command. This code is heavily based on an * implementation by Andrew Payne. Note that if a command * substitution returns TCL_CONTINUE or TCL_RETURN from its * evaluation and is not completely well-formed, the results are * not defined. * * Results: * A Tcl_Obj* containing the substituted string, or NULL to * indicate that an error occurred. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_SubstObj(interp, objPtr, flags) Tcl_Interp *interp; Tcl_Obj *objPtr; int flags; { Tcl_Obj *resultObj; char *p, *old; old = p = Tcl_GetString(objPtr); resultObj = Tcl_NewStringObj("", 0); while (1) { switch (*p) { case 0: if (p != old) { Tcl_AppendToObj(resultObj, old, p-old); } return resultObj; case '\\': if (flags & TCL_SUBST_BACKSLASHES) { char buf[TCL_UTF_MAX]; int count; if (p != old) { Tcl_AppendToObj(resultObj, old, p-old); } Tcl_AppendToObj(resultObj, buf, Tcl_UtfBackslash(p, &count, buf)); p += count; old = p; } else { p++; } break; case '$': if (flags & TCL_SUBST_VARIABLES) { Tcl_Parse parse; int code; /* * Code is simpler overall if we (effectively) inline * Tcl_ParseVar, particularly as that allows us to use * a non-string interface when we come to appending * the variable contents to the result object. There * are a few other optimisations that doing this * enables (like being able to continue the run of * unsubstituted characters straight through if a '$' * does not precede a variable name.) */ if (Tcl_ParseVarName(interp, p, -1, &parse, 0) != TCL_OK) { goto errorResult; } if (parse.numTokens == 1) { /* * There isn't a variable name after all: the $ is * just a $. */ p++; break; } if (p != old) { Tcl_AppendToObj(resultObj, old, p-old); } p += parse.tokenPtr->size; code = Tcl_EvalTokensStandard(interp, parse.tokenPtr, parse.numTokens); if (code != TCL_OK) { goto errorResult; } Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp)); Tcl_ResetResult(interp); old = p; } else { p++; } break; case '[': if (flags & TCL_SUBST_COMMANDS) { Interp *iPtr = (Interp *) interp; int code; if (p != old) { Tcl_AppendToObj(resultObj, old, p-old); } iPtr->evalFlags = TCL_BRACKET_TERM; code = Tcl_EvalEx(interp, p+1, -1, 0); switch (code) { case TCL_ERROR: goto errorResult; case TCL_BREAK: Tcl_ResetResult(interp); return resultObj; default: Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp)); case TCL_CONTINUE: Tcl_ResetResult(interp); old = p = (p+1 + iPtr->termOffset + 1); } } else { p++; } break; default: p++; break; } } errorResult: Tcl_DecrRefCount(resultObj); return NULL; } /* *---------------------------------------------------------------------- * * Tcl_SwitchObjCmd -- * * This object-based procedure is invoked to process the "switch" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_SwitchObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int i, j, index, mode, matched, result, splitObjs; char *string, *pattern; Tcl_Obj *stringObj; Tcl_Obj *CONST *savedObjv = objv; static CONST char *options[] = { "-exact", "-glob", "-regexp", "--", NULL }; enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST }; mode = OPT_EXACT; for (i = 1; i < objc; i++) { string = Tcl_GetString(objv[i]); if (string[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } if (index == OPT_LAST) { i++; break; } mode = index; } if (objc - i < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? string pattern body ... ?default body?"); return TCL_ERROR; } stringObj = objv[i]; objc -= i + 1; objv += i + 1; /* * If all of the pattern/command pairs are lumped into a single * argument, split them out again. */ splitObjs = 0; if (objc == 1) { Tcl_Obj **listv; if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { return TCL_ERROR; } /* * Ensure that the list is non-empty. */ if (objc < 1) { Tcl_WrongNumArgs(interp, 1, savedObjv, "?switches? string {pattern body ... ?default body?}"); return TCL_ERROR; } objv = listv; splitObjs = 1; } /* * Complain if there is an odd number of words in the list of * patterns and bodies. */ if (objc % 2) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); /* * Check if this can be due to a badly placed comment * in the switch block. * * The following is an heuristic to detect the infamous * "comment in switch" error: just check if a pattern * begins with '#'. */ if (splitObjs) { for (i=0 ; i= objc) { /* * This shouldn't happen since we've checked that the * last body is not a continuation... */ panic("fall-out when searching for body to match pattern"); } if (strcmp(Tcl_GetString(objv[j]), "-") != 0) { break; } } result = Tcl_EvalObjEx(interp, objv[j], 0); if (result == TCL_ERROR) { char msg[100 + TCL_INTEGER_SPACE]; sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern, interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); } return result; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_TimeObjCmd -- * * This object-based procedure is invoked to process the "time" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_TimeObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { register Tcl_Obj *objPtr; register int i, result; int count; double totalMicroSec; Tcl_Time start, stop; char buf[100]; if (objc == 2) { count = 1; } else if (objc == 3) { result = Tcl_GetIntFromObj(interp, objv[2], &count); if (result != TCL_OK) { return result; } } else { Tcl_WrongNumArgs(interp, 1, objv, "command ?count?"); return TCL_ERROR; } objPtr = objv[1]; i = count; Tcl_GetTime(&start); while (i-- > 0) { result = Tcl_EvalObjEx(interp, objPtr, 0); if (result != TCL_OK) { return result; } } Tcl_GetTime(&stop); totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6 + ( stop.usec - start.usec ) ); sprintf(buf, "%.0f microseconds per iteration", ((count <= 0) ? 0 : totalMicroSec/count)); Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_TraceObjCmd -- * * This procedure is invoked to process the "trace" Tcl command. * See the user documentation for details on what it does. * * Standard syntax as of Tcl 8.4 is * * trace {add|remove|list} {command|variable} name ops cmd * * * 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, *flagOps, *command, *p; size_t length; /* Main sub commands to 'trace' */ static CONST char *traceOptions[] = { "add", "list", "remove", #ifndef TCL_REMOVE_OBSOLETE_TRACES "variable", "vdelete", "vinfo", #endif (char *) NULL }; /* 'OLD' options are pre-Tcl-8.4 style */ enum traceOptions { TRACE_ADD, TRACE_LIST, TRACE_REMOVE, #ifndef TCL_REMOVE_OBSOLETE_TRACES TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO #endif }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum traceOptions) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: case TRACE_LIST: { /* * All sub commands of trace add/remove must take at least * one more argument. Beyond that we let the subcommand itself * control the argument structure. */ int typeIndex; if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, "option", 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); break; } #ifndef TCL_REMOVE_OBSOLETE_TRACES case TRACE_OLD_VARIABLE: { int flags; TraceVarInfo *tvarPtr; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); return TCL_ERROR; } flags = 0; flagOps = Tcl_GetString(objv[3]); for (p = flagOps; *p != 0; p++) { if (*p == 'r') { flags |= TCL_TRACE_READS; } else if (*p == 'w') { flags |= TCL_TRACE_WRITES; } else if (*p == 'u') { flags |= TCL_TRACE_UNSETS; } else if (*p == 'a') { flags |= TCL_TRACE_ARRAY; } else { goto badVarOps; } } if (flags == 0) { goto badVarOps; } flags |= TCL_TRACE_OLD_STYLE; command = Tcl_GetStringFromObj(objv[4], &commandLength); length = (size_t) commandLength; tvarPtr = (TraceVarInfo *) ckalloc((unsigned) (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); tvarPtr->flags = flags; tvarPtr->length = length; flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; strcpy(tvarPtr->command, command); name = Tcl_GetString(objv[2]); if (Tcl_TraceVar(interp, name, flags, TraceVarProc, (ClientData) tvarPtr) != TCL_OK) { ckfree((char *) tvarPtr); return TCL_ERROR; } break; } case TRACE_OLD_VDELETE: { int flags; TraceVarInfo *tvarPtr; ClientData clientData; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); return TCL_ERROR; } flags = 0; flagOps = Tcl_GetString(objv[3]); for (p = flagOps; *p != 0; p++) { if (*p == 'r') { flags |= TCL_TRACE_READS; } else if (*p == 'w') { flags |= TCL_TRACE_WRITES; } else if (*p == 'u') { flags |= TCL_TRACE_UNSETS; } else if (*p == 'a') { flags |= TCL_TRACE_ARRAY; } else { goto badVarOps; } } if (flags == 0) { goto badVarOps; } flags |= TCL_TRACE_OLD_STYLE; /* * 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 | TCL_TRACE_RESULT_OBJECT, TraceVarProc, clientData); ckfree((char *) tvarPtr); break; } } break; } case TRACE_OLD_VINFO: { ClientData clientData; char ops[5]; Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "name"); return TCL_ERROR; } resultListPtr = Tcl_GetObjResult(interp); clientData = 0; name = Tcl_GetString(objv[2]); while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, clientData)) != 0) { TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); p = ops; if (tvarPtr->flags & TCL_TRACE_READS) { *p = 'r'; p++; } if (tvarPtr->flags & TCL_TRACE_WRITES) { *p = 'w'; p++; } if (tvarPtr->flags & TCL_TRACE_UNSETS) { *p = 'u'; p++; } if (tvarPtr->flags & TCL_TRACE_ARRAY) { *p = 'a'; p++; } *p = '\0'; /* * 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; } #endif /* TCL_REMOVE_OBSOLETE_TRACES */ } return TCL_OK; badVarOps: Tcl_AppendResult(interp, "bad operations \"", flagOps, "\": should be one or more of rwua", (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TclTraceCommandObjCmd -- * * Helper function for Tcl_TraceObjCmd; implements the * [trace {add|remove|list} command ...] subcommands. * See the user documentation for details on what these do. * * Results: * Standard Tcl result. * * Side effects: * Depends on the operation (add, remove, or list) being performed; * may add or remove command traces on a command. * *---------------------------------------------------------------------- */ int TclTraceCommandObjCmd(interp, optionIndex, objc, objv) Tcl_Interp *interp; /* Current interpreter. */ int optionIndex; /* Add, list or remove */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int commandLength, index; char *name, *command; size_t length; enum traceOptions { TRACE_ADD, TRACE_LIST, TRACE_REMOVE }; static CONST char *opStrings[] = { "delete", "rename", (char *) NULL }; enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; switch ((enum traceOptions) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { int flags = 0; int i, listLen, result; Tcl_Obj **elemPtrs; if (objc != 6) { Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); return TCL_ERROR; } /* * Make sure the ops argument is a list object; get its length and * a pointer to its array of element pointers. */ result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } if (listLen == 0) { Tcl_SetResult(interp, "bad operation list \"\": must be " "one or more of delete or rename", TCL_STATIC); return TCL_ERROR; } for (i = 0; i < listLen; i++) { if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, "operation", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum operations) index) { case TRACE_CMD_RENAME: flags |= TCL_TRACE_RENAME; break; case TRACE_CMD_DELETE: flags |= TCL_TRACE_DELETE; break; } } command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr; tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) + length + 1)); tcmdPtr->flags = flags; tcmdPtr->length = length; flags |= TCL_TRACE_DELETE; strcpy(tcmdPtr->command, command); name = Tcl_GetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, (ClientData) tcmdPtr) != TCL_OK) { ckfree((char *) tcmdPtr); return TCL_ERROR; } } else { /* * Search through all of our traces on this command to * see if there's one with the given command. If so, then * delete the first one that matches. */ TraceCommandInfo *tcmdPtr; ClientData clientData; clientData = 0; name = Tcl_GetString(objv[3]); while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, TraceCommandProc, clientData)) != 0) { tcmdPtr = (TraceCommandInfo *) clientData; if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags) && (strncmp(command, tcmdPtr->command, (size_t) length) == 0)) { Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, TraceCommandProc, clientData); ckfree((char *) tcmdPtr); break; } } } break; } case TRACE_LIST: { ClientData clientData; Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "name"); return TCL_ERROR; } resultListPtr = Tcl_GetObjResult(interp); clientData = 0; name = Tcl_GetString(objv[3]); while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, TraceCommandProc, clientData)) != 0) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); /* * Build a list with the ops list as * the first obj element and the tcmdPtr->command string * as the second obj element. Append this list (as an * element) to the end of the result object list. */ elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); if (tcmdPtr->flags & TCL_TRACE_RENAME) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("rename",6)); } if (tcmdPtr->flags & TCL_TRACE_DELETE) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("delete",6)); } Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); } Tcl_SetObjResult(interp, resultListPtr); break; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclTraceVariableObjCmd -- * * Helper function for Tcl_TraceObjCmd; implements the * [trace {add|remove|list} variable ...] subcommands. * See the user documentation for details on what these do. * * Results: * Standard Tcl result. * * Side effects: * Depends on the operation (add, remove, or list) being performed; * may add or remove variable traces on a variable. * *---------------------------------------------------------------------- */ int TclTraceVariableObjCmd(interp, optionIndex, objc, objv) Tcl_Interp *interp; /* Current interpreter. */ int optionIndex; /* Add, list or remove */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int commandLength, index; char *name, *command; size_t length; enum traceOptions { TRACE_ADD, TRACE_LIST, TRACE_REMOVE }; static CONST char *opStrings[] = { "array", "read", "unset", "write", (char *) NULL }; enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, TRACE_VAR_WRITE }; switch ((enum traceOptions) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { int flags = 0; int i, listLen, result; Tcl_Obj **elemPtrs; if (objc != 6) { Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); return TCL_ERROR; } /* * Make sure the ops argument is a list object; get its length and * a pointer to its array of element pointers. */ result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } if (listLen == 0) { Tcl_SetResult(interp, "bad operation list \"\": must be " "one or more of array, read, unset, or write", TCL_STATIC); return TCL_ERROR; } for (i = 0; i < listLen ; i++) { if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, "operation", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum operations) index) { case TRACE_VAR_ARRAY: flags |= TCL_TRACE_ARRAY; break; case TRACE_VAR_READ: flags |= TCL_TRACE_READS; break; case TRACE_VAR_UNSET: flags |= TCL_TRACE_UNSETS; break; case TRACE_VAR_WRITE: flags |= TCL_TRACE_WRITES; break; } } command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceVarInfo *tvarPtr; tvarPtr = (TraceVarInfo *) ckalloc((unsigned) (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); tvarPtr->flags = flags; tvarPtr->length = length; flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; strcpy(tvarPtr->command, command); name = Tcl_GetString(objv[3]); if (Tcl_TraceVar(interp, name, flags, TraceVarProc, (ClientData) tvarPtr) != TCL_OK) { ckfree((char *) tvarPtr); return TCL_ERROR; } } else { /* * 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. */ TraceVarInfo *tvarPtr; ClientData clientData = 0; name = Tcl_GetString(objv[3]); while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, clientData)) != 0) { tvarPtr = (TraceVarInfo *) clientData; if ((tvarPtr->length == length) && (tvarPtr->flags == flags) && (strncmp(command, tvarPtr->command, (size_t) length) == 0)) { Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, TraceVarProc, clientData); ckfree((char *) tvarPtr); break; } } } break; } case TRACE_LIST: { ClientData clientData; Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "name"); return TCL_ERROR; } resultListPtr = Tcl_GetObjResult(interp); clientData = 0; name = Tcl_GetString(objv[3]); while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, clientData)) != 0) { TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); /* * Build a list with the ops list as * the first obj element and the tcmdPtr->command string * as the second obj element. Append this list (as an * element) to the end of the result object list. */ elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); if (tvarPtr->flags & TCL_TRACE_ARRAY) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("array", 5)); } if (tvarPtr->flags & TCL_TRACE_READS) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("read", 4)); } if (tvarPtr->flags & TCL_TRACE_WRITES) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("write", 5)); } if (tvarPtr->flags & TCL_TRACE_UNSETS) { Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("unset", 5)); } Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); } Tcl_SetObjResult(interp, resultListPtr); break; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_CommandTraceInfo -- * * Return the clientData value associated with a trace on a * command. This procedure can also be used to step through * all of the traces on a particular command that have the * same trace procedure. * * Results: * The return value is the clientData value associated with * a trace on the given command. Information will only be * returned for a trace with proc as trace procedure. If * the clientData argument is NULL then the first such trace is * returned; otherwise, the next relevant one after the one * given by clientData will be returned. If the command * doesn't exist, or if there are no (more) traces for it, * then NULL is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ ClientData Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData) Tcl_Interp *interp; /* Interpreter containing command. */ CONST char *cmdName; /* Name of command. */ int flags; /* OR-ed combo or TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY (can be 0). */ Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ ClientData prevClientData; /* If non-NULL, gives last value returned * by this procedure, so this call will * return the next trace after that one. * If NULL, this call will return the * first trace. */ { Command *cmdPtr; register CommandTrace *tracePtr; cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return NULL; } /* * Find the relevant trace, if any, and return its clientData. */ tracePtr = cmdPtr->tracePtr; if (prevClientData != NULL) { for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { if ((tracePtr->clientData == prevClientData) && (tracePtr->traceProc == proc)) { tracePtr = tracePtr->nextPtr; break; } } } for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { if (tracePtr->traceProc == proc) { return tracePtr->clientData; } } return NULL; } /* *---------------------------------------------------------------------- * * Tcl_TraceCommand -- * * Arrange for rename/deletes to a command to cause a * procedure to be invoked, which can monitor the operations. * * Results: * A standard Tcl return value. * * Side effects: * A trace is set up on the command given by cmdName, such that * future changes to the command will be intermediated by * proc. See the manual entry for complete details on the calling * sequence for proc. * *---------------------------------------------------------------------- */ int Tcl_TraceCommand(interp, cmdName, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter in which command is * to be traced. */ CONST char *cmdName; /* Name of command. */ int flags; /* OR-ed collection of bits, including any * of TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ Tcl_CommandTraceProc *proc; /* Procedure to call when specified ops are * invoked upon varName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { Command *cmdPtr; register CommandTrace *tracePtr; cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return TCL_ERROR; } /* * Set up trace information. */ tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE); tracePtr->nextPtr = cmdPtr->tracePtr; cmdPtr->tracePtr = tracePtr; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_UntraceCommand -- * * Remove a previously-created trace for a command. * * Results: * None. * * Side effects: * If there exists a trace for the command given by cmdName * with the given flags, proc, and clientData, then that trace * is removed. * *---------------------------------------------------------------------- */ void Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter containing command. */ CONST char *cmdName; /* Name of command. */ int flags; /* OR-ed collection of bits, including any * of TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { register CommandTrace *tracePtr; CommandTrace *prevPtr; Command *cmdPtr; Interp *iPtr = (Interp *) interp; ActiveCommandTrace *activePtr; cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return; } flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE); for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { return; } if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags) && (tracePtr->clientData == clientData)) { break; } } /* * The code below makes it possible to delete traces while traces * are active: it makes sure that the deleted trace won't be * processed by CallTraces. */ for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->nextTracePtr == tracePtr) { activePtr->nextTracePtr = tracePtr->nextPtr; } } if (prevPtr == NULL) { cmdPtr->tracePtr = tracePtr->nextPtr; } else { prevPtr->nextPtr = tracePtr->nextPtr; } Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); } /* *---------------------------------------------------------------------- * * TraceCommandProc -- * * This procedure is called to handle command changes that have * been traced using the "trace" command. * * Results: * None. * * Side effects: * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void TraceCommandProc(clientData, interp, oldName, newName, flags) ClientData clientData; /* Information about the command trace. */ Tcl_Interp *interp; /* Interpreter containing command. */ CONST char *oldName; /* Name of command being changed. */ CONST char *newName; /* New name of command. Empty string * or NULL means command is being deleted * (renamed to ""). */ int flags; /* OR-ed bits giving operation and other * information. */ { Tcl_SavedResult state; TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; int code; Tcl_DString cmd; if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { /* * Generate a command to execute by appending list elements * for the old and new command name and the operation. */ if (newName == NULL) { newName = ""; } Tcl_DStringInit(&cmd); Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); Tcl_DStringAppendElement(&cmd, oldName); Tcl_DStringAppendElement(&cmd, newName); if (flags & TCL_TRACE_RENAME) { Tcl_DStringAppend(&cmd, " rename", 7); } else if (flags & TCL_TRACE_DELETE) { Tcl_DStringAppend(&cmd, " delete", 7); } /* * 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) { /* We ignore errors in these traced commands */ } Tcl_RestoreResult(interp, &state); Tcl_DStringFree(&cmd); } if (flags & TCL_TRACE_DESTROYED) { ckfree((char *) tcmdPtr); } return; } /* *---------------------------------------------------------------------- * * 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->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { if (tvarPtr->length != (size_t) 0) { /* * Generate a command to execute by appending list elements * for the two variable names and the operation. */ if (name2 == NULL) { name2 = ""; } Tcl_DStringInit(&cmd); Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); Tcl_DStringAppendElement(&cmd, name1); Tcl_DStringAppendElement(&cmd, name2); #ifndef TCL_REMOVE_OBSOLETE_TRACES if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) { if (flags & TCL_TRACE_ARRAY) { Tcl_DStringAppend(&cmd, " a", 2); } else if (flags & TCL_TRACE_READS) { Tcl_DStringAppend(&cmd, " r", 2); } else if (flags & TCL_TRACE_WRITES) { Tcl_DStringAppend(&cmd, " w", 2); } else if (flags & TCL_TRACE_UNSETS) { Tcl_DStringAppend(&cmd, " u", 2); } } else { #endif if (flags & TCL_TRACE_ARRAY) { Tcl_DStringAppend(&cmd, " array", 6); } else if (flags & TCL_TRACE_READS) { Tcl_DStringAppend(&cmd, " read", 5); } else if (flags & TCL_TRACE_WRITES) { Tcl_DStringAppend(&cmd, " write", 6); } else if (flags & TCL_TRACE_UNSETS) { Tcl_DStringAppend(&cmd, " unset", 6); } #ifndef TCL_REMOVE_OBSOLETE_TRACES } #endif /* * 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 */ register Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errMsgObj); result = (char *) errMsgObj; } Tcl_RestoreResult(interp, &state); Tcl_DStringFree(&cmd); } } if (flags & TCL_TRACE_DESTROYED) { if (result != NULL) { register Tcl_Obj *errMsgObj = (Tcl_Obj *) result; Tcl_DecrRefCount(errMsgObj); result = NULL; } 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; }