sl@0: /* sl@0: * tclCmdMZ.c -- sl@0: * sl@0: * This file contains the top-level command routines for most of sl@0: * the Tcl built-in commands whose names begin with the letters sl@0: * M to Z. It contains only commands in the generic core (i.e. sl@0: * those that don't depend much upon UNIX facilities). sl@0: * sl@0: * Copyright (c) 1987-1993 The Regents of the University of California. sl@0: * Copyright (c) 1994-1997 Sun Microsystems, Inc. sl@0: * Copyright (c) 1998-2000 Scriptics Corporation. sl@0: * Copyright (c) 2002 ActiveState Corporation. sl@0: * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved. sl@0: * sl@0: * See the file "license.terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.28 2007/05/10 18:23:58 dgp Exp $ sl@0: */ sl@0: sl@0: #include "tclInt.h" sl@0: #include "tclPort.h" sl@0: #include "tclRegexp.h" sl@0: #include "tclCompile.h" sl@0: sl@0: /* sl@0: * Structures used to hold information about variable traces: sl@0: */ sl@0: sl@0: typedef struct { sl@0: int flags; /* Operations for which Tcl command is sl@0: * to be invoked. */ sl@0: size_t length; /* Number of non-NULL chars. in command. */ sl@0: char command[4]; /* Space for Tcl command to invoke. Actual sl@0: * size will be as large as necessary to sl@0: * hold command. This field must be the sl@0: * last in the structure, so that it can sl@0: * be larger than 4 bytes. */ sl@0: } TraceVarInfo; sl@0: sl@0: typedef struct { sl@0: VarTrace trace; sl@0: TraceVarInfo tvar; sl@0: } CompoundVarTrace; sl@0: sl@0: /* sl@0: * Structure used to hold information about command traces: sl@0: */ sl@0: sl@0: typedef struct { sl@0: int flags; /* Operations for which Tcl command is sl@0: * to be invoked. */ sl@0: size_t length; /* Number of non-NULL chars. in command. */ sl@0: Tcl_Trace stepTrace; /* Used for execution traces, when tracing sl@0: * inside the given command */ sl@0: int startLevel; /* Used for bookkeeping with step execution sl@0: * traces, store the level at which the step sl@0: * trace was invoked */ sl@0: char *startCmd; /* Used for bookkeeping with step execution sl@0: * traces, store the command name which invoked sl@0: * step trace */ sl@0: int curFlags; /* Trace flags for the current command */ sl@0: int curCode; /* Return code for the current command */ sl@0: int refCount; /* Used to ensure this structure is sl@0: * not deleted too early. Keeps track sl@0: * of how many pieces of code have sl@0: * a pointer to this structure. */ sl@0: char command[4]; /* Space for Tcl command to invoke. Actual sl@0: * size will be as large as necessary to sl@0: * hold command. This field must be the sl@0: * last in the structure, so that it can sl@0: * be larger than 4 bytes. */ sl@0: } TraceCommandInfo; sl@0: sl@0: /* sl@0: * Used by command execution traces. Note that we assume in the code sl@0: * that the first two defines are exactly 4 times the sl@0: * 'TCL_TRACE_ENTER_EXEC' and 'TCL_TRACE_LEAVE_EXEC' constants. sl@0: * sl@0: * TCL_TRACE_ENTER_DURING_EXEC - Trace each command inside the command sl@0: * currently being traced, before execution. sl@0: * TCL_TRACE_LEAVE_DURING_EXEC - Trace each command inside the command sl@0: * currently being traced, after execution. sl@0: * TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags. sl@0: * TCL_TRACE_EXEC_IN_PROGRESS - The callback procedure on this trace sl@0: * is currently executing. Therefore we sl@0: * don't let further traces execute. sl@0: * TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly sl@0: * by the command being traced, not because sl@0: * of an internal trace. sl@0: * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also sl@0: * be used in command execution traces. sl@0: */ sl@0: #define TCL_TRACE_ENTER_DURING_EXEC 4 sl@0: #define TCL_TRACE_LEAVE_DURING_EXEC 8 sl@0: #define TCL_TRACE_ANY_EXEC 15 sl@0: #define TCL_TRACE_EXEC_IN_PROGRESS 0x10 sl@0: #define TCL_TRACE_EXEC_DIRECT 0x20 sl@0: sl@0: /* sl@0: * Forward declarations for procedures defined in this file: sl@0: */ sl@0: sl@0: typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp, sl@0: int optionIndex, int objc, Tcl_Obj *CONST objv[])); sl@0: sl@0: Tcl_TraceTypeObjCmd TclTraceVariableObjCmd; sl@0: Tcl_TraceTypeObjCmd TclTraceCommandObjCmd; sl@0: Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd; sl@0: sl@0: /* sl@0: * Each subcommand has a number of 'types' to which it can apply. sl@0: * Currently 'execution', 'command' and 'variable' are the only sl@0: * types supported. These three arrays MUST be kept in sync! sl@0: * In the future we may provide an API to add to the list of sl@0: * supported trace types. sl@0: */ sl@0: static CONST char *traceTypeOptions[] = { sl@0: "execution", "command", "variable", (char*) NULL sl@0: }; sl@0: static Tcl_TraceTypeObjCmd* traceSubCmds[] = { sl@0: TclTraceExecutionObjCmd, sl@0: TclTraceCommandObjCmd, sl@0: TclTraceVariableObjCmd, sl@0: }; sl@0: sl@0: /* sl@0: * Declarations for local procedures to this file: sl@0: */ sl@0: static int CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Trace *tracePtr, Command *cmdPtr, sl@0: CONST char *command, int numChars, sl@0: int objc, Tcl_Obj *CONST objv[])); sl@0: static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, CONST char *name1, sl@0: CONST char *name2, int flags)); sl@0: static void TraceCommandProc _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, CONST char *oldName, sl@0: CONST char *newName, int flags)); sl@0: static Tcl_CmdObjTraceProc TraceExecutionProc; sl@0: sl@0: #ifdef TCL_TIP280 sl@0: static void ListLines _ANSI_ARGS_((CONST char* listStr, int line, sl@0: int n, int* lines)); sl@0: #endif sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_PwdObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "pwd" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_PwdObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Tcl_Obj *retVal; sl@0: sl@0: if (objc != 1) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: retVal = Tcl_FSGetCwd(interp); sl@0: if (retVal == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetObjResult(interp, retVal); sl@0: Tcl_DecrRefCount(retVal); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_RegexpObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "regexp" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_RegexpObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int i, indices, match, about, offset, all, doinline, numMatchesSaved; sl@0: int cflags, eflags, stringLength; sl@0: Tcl_RegExp regExpr; sl@0: Tcl_Obj *objPtr, *resultPtr; sl@0: Tcl_RegExpInfo info; sl@0: static CONST char *options[] = { sl@0: "-all", "-about", "-indices", "-inline", sl@0: "-expanded", "-line", "-linestop", "-lineanchor", sl@0: "-nocase", "-start", "--", (char *) NULL sl@0: }; sl@0: enum options { sl@0: REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE, sl@0: REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR, sl@0: REGEXP_NOCASE, REGEXP_START, REGEXP_LAST sl@0: }; sl@0: sl@0: indices = 0; sl@0: about = 0; sl@0: cflags = TCL_REG_ADVANCED; sl@0: eflags = 0; sl@0: offset = 0; sl@0: all = 0; sl@0: doinline = 0; sl@0: sl@0: for (i = 1; i < objc; i++) { sl@0: char *name; sl@0: int index; sl@0: sl@0: name = Tcl_GetString(objv[i]); sl@0: if (name[0] != '-') { sl@0: break; sl@0: } sl@0: if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, sl@0: &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: switch ((enum options) index) { sl@0: case REGEXP_ALL: { sl@0: all = 1; sl@0: break; sl@0: } sl@0: case REGEXP_INDICES: { sl@0: indices = 1; sl@0: break; sl@0: } sl@0: case REGEXP_INLINE: { sl@0: doinline = 1; sl@0: break; sl@0: } sl@0: case REGEXP_NOCASE: { sl@0: cflags |= TCL_REG_NOCASE; sl@0: break; sl@0: } sl@0: case REGEXP_ABOUT: { sl@0: about = 1; sl@0: break; sl@0: } sl@0: case REGEXP_EXPANDED: { sl@0: cflags |= TCL_REG_EXPANDED; sl@0: break; sl@0: } sl@0: case REGEXP_LINE: { sl@0: cflags |= TCL_REG_NEWLINE; sl@0: break; sl@0: } sl@0: case REGEXP_LINESTOP: { sl@0: cflags |= TCL_REG_NLSTOP; sl@0: break; sl@0: } sl@0: case REGEXP_LINEANCHOR: { sl@0: cflags |= TCL_REG_NLANCH; sl@0: break; sl@0: } sl@0: case REGEXP_START: { sl@0: if (++i >= objc) { sl@0: goto endOfForLoop; sl@0: } sl@0: if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (offset < 0) { sl@0: offset = 0; sl@0: } sl@0: break; sl@0: } sl@0: case REGEXP_LAST: { sl@0: i++; sl@0: goto endOfForLoop; sl@0: } sl@0: } sl@0: } sl@0: sl@0: endOfForLoop: sl@0: if ((objc - i) < (2 - about)) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, sl@0: "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: objc -= i; sl@0: objv += i; sl@0: sl@0: if (doinline && ((objc - 2) != 0)) { sl@0: /* sl@0: * User requested -inline, but specified match variables - a no-no. sl@0: */ sl@0: Tcl_AppendResult(interp, "regexp match variables not allowed", sl@0: " when using -inline", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Handle the odd about case separately. sl@0: */ sl@0: if (about) { sl@0: regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); sl@0: if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) { sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: * Get the length of the string that we are matching against so sl@0: * we can do the termination test for -all matches. Do this before sl@0: * getting the regexp to avoid shimmering problems. sl@0: */ sl@0: objPtr = objv[1]; sl@0: stringLength = Tcl_GetCharLength(objPtr); sl@0: sl@0: regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); sl@0: if (regExpr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (offset > 0) { sl@0: /* sl@0: * Add flag if using offset (string is part of a larger string), sl@0: * so that "^" won't match. sl@0: */ sl@0: eflags |= TCL_REG_NOTBOL; sl@0: } sl@0: sl@0: objc -= 2; sl@0: objv += 2; sl@0: resultPtr = Tcl_GetObjResult(interp); sl@0: sl@0: if (doinline) { sl@0: /* sl@0: * Save all the subexpressions, as we will return them as a list sl@0: */ sl@0: numMatchesSaved = -1; sl@0: } else { sl@0: /* sl@0: * Save only enough subexpressions for matches we want to keep, sl@0: * expect in the case of -all, where we need to keep at least sl@0: * one to know where to move the offset. sl@0: */ sl@0: numMatchesSaved = (objc == 0) ? all : objc; sl@0: } sl@0: sl@0: /* sl@0: * The following loop is to handle multiple matches within the sl@0: * same source string; each iteration handles one match. If "-all" sl@0: * hasn't been specified then the loop body only gets executed once. sl@0: * We terminate the loop when the starting offset is past the end of the sl@0: * string. sl@0: */ sl@0: sl@0: while (1) { sl@0: match = Tcl_RegExpExecObj(interp, regExpr, objPtr, sl@0: offset /* offset */, numMatchesSaved, eflags sl@0: | ((offset > 0 && sl@0: (Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n')) sl@0: ? TCL_REG_NOTBOL : 0)); sl@0: sl@0: if (match < 0) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (match == 0) { sl@0: /* sl@0: * We want to set the value of the intepreter result only when sl@0: * this is the first time through the loop. sl@0: */ sl@0: if (all <= 1) { sl@0: /* sl@0: * If inlining, set the interpreter's object result to an sl@0: * empty list, otherwise set it to an integer object w/ sl@0: * value 0. sl@0: */ sl@0: if (doinline) { sl@0: Tcl_SetListObj(resultPtr, 0, NULL); sl@0: } else { sl@0: Tcl_SetIntObj(resultPtr, 0); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: break; sl@0: } sl@0: sl@0: /* sl@0: * If additional variable names have been specified, return sl@0: * index information in those variables. sl@0: */ sl@0: sl@0: Tcl_RegExpGetInfo(regExpr, &info); sl@0: if (doinline) { sl@0: /* sl@0: * It's the number of substitutions, plus one for the matchVar sl@0: * at index 0 sl@0: */ sl@0: objc = info.nsubs + 1; sl@0: } sl@0: for (i = 0; i < objc; i++) { sl@0: Tcl_Obj *newPtr; sl@0: sl@0: if (indices) { sl@0: int start, end; sl@0: Tcl_Obj *objs[2]; sl@0: sl@0: /* sl@0: * Only adjust the match area if there was a match for sl@0: * that area. (Scriptics Bug 4391/SF Bug #219232) sl@0: */ sl@0: if (i <= info.nsubs && info.matches[i].start >= 0) { sl@0: start = offset + info.matches[i].start; sl@0: end = offset + info.matches[i].end; sl@0: sl@0: /* sl@0: * Adjust index so it refers to the last character in the sl@0: * match instead of the first character after the match. sl@0: */ sl@0: sl@0: if (end >= offset) { sl@0: end--; sl@0: } sl@0: } else { sl@0: start = -1; sl@0: end = -1; sl@0: } sl@0: sl@0: objs[0] = Tcl_NewLongObj(start); sl@0: objs[1] = Tcl_NewLongObj(end); sl@0: sl@0: newPtr = Tcl_NewListObj(2, objs); sl@0: } else { sl@0: if (i <= info.nsubs) { sl@0: newPtr = Tcl_GetRange(objPtr, sl@0: offset + info.matches[i].start, sl@0: offset + info.matches[i].end - 1); sl@0: } else { sl@0: newPtr = Tcl_NewObj(); sl@0: } sl@0: } sl@0: if (doinline) { sl@0: if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr) sl@0: != TCL_OK) { sl@0: Tcl_DecrRefCount(newPtr); sl@0: return TCL_ERROR; sl@0: } sl@0: } else { sl@0: Tcl_Obj *valuePtr; sl@0: Tcl_IncrRefCount(newPtr); sl@0: valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); sl@0: Tcl_DecrRefCount(newPtr); sl@0: if (valuePtr == NULL) { sl@0: Tcl_AppendResult(interp, "couldn't set variable \"", sl@0: Tcl_GetString(objv[i]), "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: } sl@0: sl@0: if (all == 0) { sl@0: break; sl@0: } sl@0: /* sl@0: * Adjust the offset to the character just after the last one sl@0: * in the matchVar and increment all to count how many times sl@0: * we are making a match. We always increment the offset by at least sl@0: * one to prevent endless looping (as in the case: sl@0: * regexp -all {a*} a). Otherwise, when we match the NULL string at sl@0: * the end of the input string, we will loop indefinately (because the sl@0: * length of the match is 0, so offset never changes). sl@0: */ sl@0: if (info.matches[0].end == 0) { sl@0: offset++; sl@0: } sl@0: offset += info.matches[0].end; sl@0: all++; sl@0: eflags |= TCL_REG_NOTBOL; sl@0: if (offset >= stringLength) { sl@0: break; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Set the interpreter's object result to an integer object sl@0: * with value 1 if -all wasn't specified, otherwise it's all-1 sl@0: * (the number of times through the while - 1). sl@0: * Get the resultPtr again as the Tcl_ObjSetVar2 above may have sl@0: * cause the result to change. [Patch #558324] (watson). sl@0: */ sl@0: sl@0: if (!doinline) { sl@0: resultPtr = Tcl_GetObjResult(interp); sl@0: Tcl_SetIntObj(resultPtr, (all ? all-1 : 1)); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_RegsubObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "regsub" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_RegsubObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int idx, result, cflags, all, wlen, wsublen, numMatches, offset; sl@0: int start, end, subStart, subEnd, match; sl@0: Tcl_RegExp regExpr; sl@0: Tcl_RegExpInfo info; sl@0: Tcl_Obj *resultPtr, *subPtr, *objPtr; sl@0: Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; sl@0: sl@0: static CONST char *options[] = { sl@0: "-all", "-nocase", "-expanded", sl@0: "-line", "-linestop", "-lineanchor", "-start", sl@0: "--", NULL sl@0: }; sl@0: enum options { sl@0: REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED, sl@0: REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START, sl@0: REGSUB_LAST sl@0: }; sl@0: sl@0: cflags = TCL_REG_ADVANCED; sl@0: all = 0; sl@0: offset = 0; sl@0: resultPtr = NULL; sl@0: sl@0: for (idx = 1; idx < objc; idx++) { sl@0: char *name; sl@0: int index; sl@0: sl@0: name = Tcl_GetString(objv[idx]); sl@0: if (name[0] != '-') { sl@0: break; sl@0: } sl@0: if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", sl@0: TCL_EXACT, &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: switch ((enum options) index) { sl@0: case REGSUB_ALL: { sl@0: all = 1; sl@0: break; sl@0: } sl@0: case REGSUB_NOCASE: { sl@0: cflags |= TCL_REG_NOCASE; sl@0: break; sl@0: } sl@0: case REGSUB_EXPANDED: { sl@0: cflags |= TCL_REG_EXPANDED; sl@0: break; sl@0: } sl@0: case REGSUB_LINE: { sl@0: cflags |= TCL_REG_NEWLINE; sl@0: break; sl@0: } sl@0: case REGSUB_LINESTOP: { sl@0: cflags |= TCL_REG_NLSTOP; sl@0: break; sl@0: } sl@0: case REGSUB_LINEANCHOR: { sl@0: cflags |= TCL_REG_NLANCH; sl@0: break; sl@0: } sl@0: case REGSUB_START: { sl@0: if (++idx >= objc) { sl@0: goto endOfForLoop; sl@0: } sl@0: if (Tcl_GetIntFromObj(interp, objv[idx], &offset) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (offset < 0) { sl@0: offset = 0; sl@0: } sl@0: break; sl@0: } sl@0: case REGSUB_LAST: { sl@0: idx++; sl@0: goto endOfForLoop; sl@0: } sl@0: } sl@0: } sl@0: endOfForLoop: sl@0: if (objc-idx < 3 || objc-idx > 4) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, sl@0: "?switches? exp string subSpec ?varName?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: objc -= idx; sl@0: objv += idx; sl@0: sl@0: if (all && (offset == 0) sl@0: && (strpbrk(Tcl_GetString(objv[2]), "&\\") == NULL) sl@0: && (strpbrk(Tcl_GetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { sl@0: /* sl@0: * This is a simple one pair string map situation. We make use of sl@0: * a slightly modified version of the one pair STR_MAP code. sl@0: */ sl@0: int slen, nocase; sl@0: int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar *, CONST Tcl_UniChar *, sl@0: unsigned long)); sl@0: Tcl_UniChar *p, wsrclc; sl@0: sl@0: numMatches = 0; sl@0: nocase = (cflags & TCL_REG_NOCASE); sl@0: strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; sl@0: sl@0: wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); sl@0: wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); sl@0: wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen); sl@0: wend = wstring + wlen - (slen ? slen - 1 : 0); sl@0: result = TCL_OK; sl@0: sl@0: if (slen == 0) { sl@0: /* sl@0: * regsub behavior for "" matches between each character. sl@0: * 'string map' skips the "" case. sl@0: */ sl@0: if (wstring < wend) { sl@0: resultPtr = Tcl_NewUnicodeObj(wstring, 0); sl@0: Tcl_IncrRefCount(resultPtr); sl@0: for (; wstring < wend; wstring++) { sl@0: Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); sl@0: Tcl_AppendUnicodeToObj(resultPtr, wstring, 1); sl@0: numMatches++; sl@0: } sl@0: wlen = 0; sl@0: } sl@0: } else { sl@0: wsrclc = Tcl_UniCharToLower(*wsrc); sl@0: for (p = wfirstChar = wstring; wstring < wend; wstring++) { sl@0: if (((*wstring == *wsrc) || sl@0: (nocase && (Tcl_UniCharToLower(*wstring) == sl@0: wsrclc))) && sl@0: ((slen == 1) || (strCmpFn(wstring, wsrc, sl@0: (unsigned long) slen) == 0))) { sl@0: if (numMatches == 0) { sl@0: resultPtr = Tcl_NewUnicodeObj(wstring, 0); sl@0: Tcl_IncrRefCount(resultPtr); sl@0: } sl@0: if (p != wstring) { sl@0: Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p); sl@0: p = wstring + slen; sl@0: } else { sl@0: p += slen; sl@0: } sl@0: wstring = p - 1; sl@0: sl@0: Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); sl@0: numMatches++; sl@0: } sl@0: } sl@0: if (numMatches) { sl@0: wlen = wfirstChar + wlen - p; sl@0: wstring = p; sl@0: } sl@0: } sl@0: objPtr = NULL; sl@0: subPtr = NULL; sl@0: goto regsubDone; sl@0: } sl@0: sl@0: regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); sl@0: if (regExpr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Make sure to avoid problems where the objects are shared. This sl@0: * can cause RegExpObj <> UnicodeObj shimmering that causes data sl@0: * corruption. [Bug #461322] sl@0: */ sl@0: sl@0: if (objv[1] == objv[0]) { sl@0: objPtr = Tcl_DuplicateObj(objv[1]); sl@0: } else { sl@0: objPtr = objv[1]; sl@0: } sl@0: wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); sl@0: if (objv[2] == objv[0]) { sl@0: subPtr = Tcl_DuplicateObj(objv[2]); sl@0: } else { sl@0: subPtr = objv[2]; sl@0: } sl@0: wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); sl@0: sl@0: result = TCL_OK; sl@0: sl@0: /* sl@0: * The following loop is to handle multiple matches within the sl@0: * same source string; each iteration handles one match and its sl@0: * corresponding substitution. If "-all" hasn't been specified sl@0: * then the loop body only gets executed once. We must use sl@0: * 'offset <= wlen' in particular for the case where the regexp sl@0: * pattern can match the empty string - this is useful when sl@0: * doing, say, 'regsub -- ^ $str ...' when $str might be empty. sl@0: */ sl@0: sl@0: numMatches = 0; sl@0: for ( ; offset <= wlen; ) { sl@0: sl@0: /* sl@0: * The flags argument is set if string is part of a larger string, sl@0: * so that "^" won't match. sl@0: */ sl@0: sl@0: match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset, sl@0: 10 /* matches */, ((offset > 0 && sl@0: (wstring[offset-1] != (Tcl_UniChar)'\n')) sl@0: ? TCL_REG_NOTBOL : 0)); sl@0: sl@0: if (match < 0) { sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: if (match == 0) { sl@0: break; sl@0: } sl@0: if (numMatches == 0) { sl@0: resultPtr = Tcl_NewUnicodeObj(wstring, 0); sl@0: Tcl_IncrRefCount(resultPtr); sl@0: if (offset > 0) { sl@0: /* sl@0: * Copy the initial portion of the string in if an offset sl@0: * was specified. sl@0: */ sl@0: Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); sl@0: } sl@0: } sl@0: numMatches++; sl@0: sl@0: /* sl@0: * Copy the portion of the source string before the match to the sl@0: * result variable. sl@0: */ sl@0: sl@0: Tcl_RegExpGetInfo(regExpr, &info); sl@0: start = info.matches[0].start; sl@0: end = info.matches[0].end; sl@0: Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); sl@0: sl@0: /* sl@0: * Append the subSpec argument to the variable, making appropriate sl@0: * substitutions. This code is a bit hairy because of the backslash sl@0: * conventions and because the code saves up ranges of characters in sl@0: * subSpec to reduce the number of calls to Tcl_SetVar. sl@0: */ sl@0: sl@0: wsrc = wfirstChar = wsubspec; sl@0: wend = wsubspec + wsublen; sl@0: for (ch = *wsrc; wsrc != wend; wsrc++, ch = *wsrc) { sl@0: if (ch == '&') { sl@0: idx = 0; sl@0: } else if (ch == '\\') { sl@0: ch = wsrc[1]; sl@0: if ((ch >= '0') && (ch <= '9')) { sl@0: idx = ch - '0'; sl@0: } else if ((ch == '\\') || (ch == '&')) { sl@0: *wsrc = ch; sl@0: Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, sl@0: wsrc - wfirstChar + 1); sl@0: *wsrc = '\\'; sl@0: wfirstChar = wsrc + 2; sl@0: wsrc++; sl@0: continue; sl@0: } else { sl@0: continue; sl@0: } sl@0: } else { sl@0: continue; sl@0: } sl@0: if (wfirstChar != wsrc) { sl@0: Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, sl@0: wsrc - wfirstChar); sl@0: } sl@0: if (idx <= info.nsubs) { sl@0: subStart = info.matches[idx].start; sl@0: subEnd = info.matches[idx].end; sl@0: if ((subStart >= 0) && (subEnd >= 0)) { sl@0: Tcl_AppendUnicodeToObj(resultPtr, sl@0: wstring + offset + subStart, subEnd - subStart); sl@0: } sl@0: } sl@0: if (*wsrc == '\\') { sl@0: wsrc++; sl@0: } sl@0: wfirstChar = wsrc + 1; sl@0: } sl@0: if (wfirstChar != wsrc) { sl@0: Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); sl@0: } sl@0: if (end == 0) { sl@0: /* sl@0: * Always consume at least one character of the input string sl@0: * in order to prevent infinite loops. sl@0: */ sl@0: sl@0: if (offset < wlen) { sl@0: Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); sl@0: } sl@0: offset++; sl@0: } else { sl@0: offset += end; sl@0: if (start == end) { sl@0: /* sl@0: * We matched an empty string, which means we must go sl@0: * forward one more step so we don't match again at the sl@0: * same spot. sl@0: */ sl@0: if (offset < wlen) { sl@0: Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); sl@0: } sl@0: offset++; sl@0: } sl@0: } sl@0: if (!all) { sl@0: break; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Copy the portion of the source string after the last match to the sl@0: * result variable. sl@0: */ sl@0: regsubDone: sl@0: if (numMatches == 0) { sl@0: /* sl@0: * On zero matches, just ignore the offset, since it shouldn't sl@0: * matter to us in this case, and the user may have skewed it. sl@0: */ sl@0: resultPtr = objv[1]; sl@0: Tcl_IncrRefCount(resultPtr); sl@0: } else if (offset < wlen) { sl@0: Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); sl@0: } sl@0: if (objc == 4) { sl@0: if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) { sl@0: Tcl_AppendResult(interp, "couldn't set variable \"", sl@0: Tcl_GetString(objv[3]), "\"", (char *) NULL); sl@0: result = TCL_ERROR; sl@0: } else { sl@0: /* sl@0: * Set the interpreter's object result to an integer object sl@0: * holding the number of matches. sl@0: */ sl@0: sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches); sl@0: } sl@0: } else { sl@0: /* sl@0: * No varname supplied, so just return the modified string. sl@0: */ sl@0: Tcl_SetObjResult(interp, resultPtr); sl@0: } sl@0: sl@0: done: sl@0: if (objPtr && (objv[1] == objv[0])) { Tcl_DecrRefCount(objPtr); } sl@0: if (subPtr && (objv[2] == objv[0])) { Tcl_DecrRefCount(subPtr); } sl@0: if (resultPtr) { Tcl_DecrRefCount(resultPtr); } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_RenameObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "rename" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_RenameObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Arbitrary value passed to the command. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: char *oldName, *newName; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: oldName = Tcl_GetString(objv[1]); sl@0: newName = Tcl_GetString(objv[2]); sl@0: return TclRenameCommand(interp, oldName, newName); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ReturnObjCmd -- sl@0: * sl@0: * This object-based procedure is invoked to process the "return" Tcl sl@0: * command. See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_ReturnObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: int optionLen, argLen, code, result; sl@0: sl@0: if (iPtr->errorInfo != NULL) { sl@0: ckfree(iPtr->errorInfo); sl@0: iPtr->errorInfo = NULL; sl@0: } sl@0: if (iPtr->errorCode != NULL) { sl@0: ckfree(iPtr->errorCode); sl@0: iPtr->errorCode = NULL; sl@0: } sl@0: code = TCL_OK; sl@0: sl@0: for (objv++, objc--; objc > 1; objv += 2, objc -= 2) { sl@0: char *option = Tcl_GetStringFromObj(objv[0], &optionLen); sl@0: char *arg = Tcl_GetStringFromObj(objv[1], &argLen); sl@0: sl@0: if (strcmp(option, "-code") == 0) { sl@0: register int c = arg[0]; sl@0: if ((c == 'o') && (strcmp(arg, "ok") == 0)) { sl@0: code = TCL_OK; sl@0: } else if ((c == 'e') && (strcmp(arg, "error") == 0)) { sl@0: code = TCL_ERROR; sl@0: } else if ((c == 'r') && (strcmp(arg, "return") == 0)) { sl@0: code = TCL_RETURN; sl@0: } else if ((c == 'b') && (strcmp(arg, "break") == 0)) { sl@0: code = TCL_BREAK; sl@0: } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) { sl@0: code = TCL_CONTINUE; sl@0: } else { sl@0: result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1], sl@0: &code); sl@0: if (result != TCL_OK) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "bad completion code \"", sl@0: Tcl_GetString(objv[1]), sl@0: "\": must be ok, error, return, break, ", sl@0: "continue, or an integer", (char *) NULL); sl@0: return result; sl@0: } sl@0: } sl@0: } else if (strcmp(option, "-errorinfo") == 0) { sl@0: iPtr->errorInfo = sl@0: (char *) ckalloc((unsigned) (strlen(arg) + 1)); sl@0: strcpy(iPtr->errorInfo, arg); sl@0: } else if (strcmp(option, "-errorcode") == 0) { sl@0: iPtr->errorCode = sl@0: (char *) ckalloc((unsigned) (strlen(arg) + 1)); sl@0: strcpy(iPtr->errorCode, arg); sl@0: } else { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "bad option \"", option, sl@0: "\": must be -code, -errorcode, or -errorinfo", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: if (objc == 1) { sl@0: /* sl@0: * Set the interpreter's object result. An inline version of sl@0: * Tcl_SetObjResult. sl@0: */ sl@0: sl@0: Tcl_SetObjResult(interp, objv[0]); sl@0: } sl@0: iPtr->returnCode = code; sl@0: return TCL_RETURN; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SourceObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "source" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_SourceObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "fileName"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: return Tcl_FSEvalFile(interp, objv[1]); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SplitObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "split" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_SplitObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Tcl_UniChar ch; sl@0: int len; sl@0: char *splitChars, *string, *end; sl@0: int splitCharLen, stringLen; sl@0: Tcl_Obj *listPtr, *objPtr; sl@0: sl@0: if (objc == 2) { sl@0: splitChars = " \n\t\r"; sl@0: splitCharLen = 4; sl@0: } else if (objc == 3) { sl@0: splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen); sl@0: } else { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: string = Tcl_GetStringFromObj(objv[1], &stringLen); sl@0: end = string + stringLen; sl@0: listPtr = Tcl_GetObjResult(interp); sl@0: sl@0: if (stringLen == 0) { sl@0: /* sl@0: * Do nothing. sl@0: */ sl@0: } else if (splitCharLen == 0) { sl@0: Tcl_HashTable charReuseTable; sl@0: Tcl_HashEntry *hPtr; sl@0: int isNew; sl@0: sl@0: /* sl@0: * Handle the special case of splitting on every character. sl@0: * sl@0: * Uses a hash table to ensure that each kind of character has sl@0: * only one Tcl_Obj instance (multiply-referenced) in the sl@0: * final list. This is a *major* win when splitting on a long sl@0: * string (especially in the megabyte range!) - DKF sl@0: */ sl@0: sl@0: Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); sl@0: for ( ; string < end; string += len) { sl@0: len = TclUtfToUniChar(string, &ch); sl@0: /* Assume Tcl_UniChar is an integral type... */ sl@0: hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew); sl@0: if (isNew) { sl@0: objPtr = Tcl_NewStringObj(string, len); sl@0: /* Don't need to fiddle with refcount... */ sl@0: Tcl_SetHashValue(hPtr, (ClientData) objPtr); sl@0: } else { sl@0: objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr); sl@0: } sl@0: Tcl_ListObjAppendElement(NULL, listPtr, objPtr); sl@0: } sl@0: Tcl_DeleteHashTable(&charReuseTable); sl@0: } else if (splitCharLen == 1) { sl@0: char *p; sl@0: sl@0: /* sl@0: * Handle the special case of splitting on a single character. sl@0: * This is only true for the one-char ASCII case, as one unicode sl@0: * char is > 1 byte in length. sl@0: */ sl@0: sl@0: while (*string && (p = strchr(string, (int) *splitChars)) != NULL) { sl@0: objPtr = Tcl_NewStringObj(string, p - string); sl@0: Tcl_ListObjAppendElement(NULL, listPtr, objPtr); sl@0: string = p + 1; sl@0: } sl@0: objPtr = Tcl_NewStringObj(string, end - string); sl@0: Tcl_ListObjAppendElement(NULL, listPtr, objPtr); sl@0: } else { sl@0: char *element, *p, *splitEnd; sl@0: int splitLen; sl@0: Tcl_UniChar splitChar; sl@0: sl@0: /* sl@0: * Normal case: split on any of a given set of characters. sl@0: * Discard instances of the split characters. sl@0: */ sl@0: sl@0: splitEnd = splitChars + splitCharLen; sl@0: sl@0: for (element = string; string < end; string += len) { sl@0: len = TclUtfToUniChar(string, &ch); sl@0: for (p = splitChars; p < splitEnd; p += splitLen) { sl@0: splitLen = TclUtfToUniChar(p, &splitChar); sl@0: if (ch == splitChar) { sl@0: objPtr = Tcl_NewStringObj(element, string - element); sl@0: Tcl_ListObjAppendElement(NULL, listPtr, objPtr); sl@0: element = string + len; sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: objPtr = Tcl_NewStringObj(element, string - element); sl@0: Tcl_ListObjAppendElement(NULL, listPtr, objPtr); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_StringObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "string" Tcl command. sl@0: * See the user documentation for details on what it does. Note sl@0: * that this command only functions correctly on properly formed sl@0: * Tcl UTF strings. sl@0: * sl@0: * Note that the primary methods here (equal, compare, match, ...) sl@0: * have bytecode equivalents. You will find the code for those in sl@0: * tclExecute.c. The code here will only be used in the non-bc sl@0: * case (like in an 'eval'). sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_StringObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int index, left, right; sl@0: Tcl_Obj *resultPtr; sl@0: char *string1, *string2; sl@0: int length1, length2; sl@0: static CONST char *options[] = { sl@0: "bytelength", "compare", "equal", "first", sl@0: "index", "is", "last", "length", sl@0: "map", "match", "range", "repeat", sl@0: "replace", "tolower", "toupper", "totitle", sl@0: "trim", "trimleft", "trimright", sl@0: "wordend", "wordstart", (char *) NULL sl@0: }; sl@0: enum options { sl@0: STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST, sl@0: STR_INDEX, STR_IS, STR_LAST, STR_LENGTH, sl@0: STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT, sl@0: STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE, sl@0: STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, sl@0: STR_WORDEND, STR_WORDSTART sl@0: }; sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, sl@0: &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: resultPtr = Tcl_GetObjResult(interp); sl@0: switch ((enum options) index) { sl@0: case STR_EQUAL: sl@0: case STR_COMPARE: { sl@0: /* sl@0: * Remember to keep code here in some sync with the sl@0: * byte-compiled versions in tclExecute.c (INST_STR_EQ, sl@0: * INST_STR_NEQ and INST_STR_CMP as well as the expr string sl@0: * comparison in INST_EQ/INST_NEQ/INST_LT/...). sl@0: */ sl@0: int i, match, length, nocase = 0, reqlength = -1; sl@0: int (*strCmpFn)(); sl@0: sl@0: if (objc < 4 || objc > 7) { sl@0: str_cmp_args: sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "?-nocase? ?-length int? string1 string2"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: for (i = 2; i < objc-2; i++) { sl@0: string2 = Tcl_GetStringFromObj(objv[i], &length2); sl@0: if ((length2 > 1) sl@0: && strncmp(string2, "-nocase", (size_t)length2) == 0) { sl@0: nocase = 1; sl@0: } else if ((length2 > 1) sl@0: && strncmp(string2, "-length", (size_t)length2) == 0) { sl@0: if (i+1 >= objc-2) { sl@0: goto str_cmp_args; sl@0: } sl@0: if (Tcl_GetIntFromObj(interp, objv[++i], sl@0: &reqlength) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: } else { sl@0: Tcl_AppendStringsToObj(resultPtr, "bad option \"", sl@0: string2, "\": must be -nocase or -length", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * From now on, we only access the two objects at the end sl@0: * of the argument array. sl@0: */ sl@0: objv += objc-2; sl@0: sl@0: if ((reqlength == 0) || (objv[0] == objv[1])) { sl@0: /* sl@0: * Alway match at 0 chars of if it is the same obj. sl@0: */ sl@0: sl@0: Tcl_SetBooleanObj(resultPtr, sl@0: ((enum options) index == STR_EQUAL)); sl@0: break; sl@0: } else if (!nocase && objv[0]->typePtr == &tclByteArrayType && sl@0: objv[1]->typePtr == &tclByteArrayType) { sl@0: /* sl@0: * Use binary versions of comparisons since that won't sl@0: * cause undue type conversions and it is much faster. sl@0: * Only do this if we're case-sensitive (which is all sl@0: * that really makes sense with byte arrays anyway, and sl@0: * we have no memcasecmp() for some reason... :^) sl@0: */ sl@0: string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1); sl@0: string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2); sl@0: strCmpFn = memcmp; sl@0: } else if ((objv[0]->typePtr == &tclStringType) sl@0: && (objv[1]->typePtr == &tclStringType)) { sl@0: /* sl@0: * Do a unicode-specific comparison if both of the args sl@0: * are of String type. In benchmark testing this proved sl@0: * the most efficient check between the unicode and sl@0: * string comparison operations. sl@0: */ sl@0: string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1); sl@0: string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2); sl@0: strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; sl@0: } else { sl@0: /* sl@0: * As a catch-all we will work with UTF-8. We cannot use sl@0: * memcmp() as that is unsafe with any string containing sl@0: * NULL (\xC0\x80 in Tcl's utf rep). We can use the more sl@0: * efficient TclpUtfNcmp2 if we are case-sensitive and no sl@0: * specific length was requested. sl@0: */ sl@0: string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1); sl@0: string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2); sl@0: if ((reqlength < 0) && !nocase) { sl@0: strCmpFn = TclpUtfNcmp2; sl@0: } else { sl@0: length1 = Tcl_NumUtfChars(string1, length1); sl@0: length2 = Tcl_NumUtfChars(string2, length2); sl@0: strCmpFn = nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp; sl@0: } sl@0: } sl@0: sl@0: if (((enum options) index == STR_EQUAL) sl@0: && (reqlength < 0) && (length1 != length2)) { sl@0: match = 1; /* this will be reversed below */ sl@0: } else { sl@0: length = (length1 < length2) ? length1 : length2; sl@0: if (reqlength > 0 && reqlength < length) { sl@0: length = reqlength; sl@0: } else if (reqlength < 0) { sl@0: /* sl@0: * The requested length is negative, so we ignore it by sl@0: * setting it to length + 1 so we correct the match var. sl@0: */ sl@0: reqlength = length + 1; sl@0: } sl@0: match = strCmpFn(string1, string2, (unsigned) length); sl@0: if ((match == 0) && (reqlength > length)) { sl@0: match = length1 - length2; sl@0: } sl@0: } sl@0: sl@0: if ((enum options) index == STR_EQUAL) { sl@0: Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1); sl@0: } else { sl@0: Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 : sl@0: (match < 0) ? -1 : 0)); sl@0: } sl@0: break; sl@0: } sl@0: case STR_FIRST: { sl@0: Tcl_UniChar *ustring1, *ustring2; sl@0: int match, start; sl@0: sl@0: if (objc < 4 || objc > 5) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "subString string ?startIndex?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * We are searching string2 for the sequence string1. sl@0: */ sl@0: sl@0: match = -1; sl@0: start = 0; sl@0: length2 = -1; sl@0: sl@0: ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); sl@0: ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); sl@0: sl@0: if (objc == 5) { sl@0: /* sl@0: * If a startIndex is specified, we will need to fast sl@0: * forward to that point in the string before we think sl@0: * about a match sl@0: */ sl@0: if (TclGetIntForIndex(interp, objv[4], length2 - 1, sl@0: &start) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (start >= length2) { sl@0: goto str_first_done; sl@0: } else if (start > 0) { sl@0: ustring2 += start; sl@0: length2 -= start; sl@0: } else if (start < 0) { sl@0: /* sl@0: * Invalid start index mapped to string start; sl@0: * Bug #423581 sl@0: */ sl@0: start = 0; sl@0: } sl@0: } sl@0: sl@0: if (length1 > 0) { sl@0: register Tcl_UniChar *p, *end; sl@0: sl@0: end = ustring2 + length2 - length1 + 1; sl@0: for (p = ustring2; p < end; p++) { sl@0: /* sl@0: * Scan forward to find the first character. sl@0: */ sl@0: if ((*p == *ustring1) && sl@0: (TclUniCharNcmp(ustring1, p, sl@0: (unsigned long) length1) == 0)) { sl@0: match = p - ustring2; sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: /* sl@0: * Compute the character index of the matching string by sl@0: * counting the number of characters before the match. sl@0: */ sl@0: if ((match != -1) && (objc == 5)) { sl@0: match += start; sl@0: } sl@0: sl@0: str_first_done: sl@0: Tcl_SetIntObj(resultPtr, match); sl@0: break; sl@0: } sl@0: case STR_INDEX: { sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * If we have a ByteArray object, avoid indexing in the sl@0: * Utf string since the byte array contains one byte per sl@0: * character. Otherwise, use the Unicode string rep to sl@0: * get the index'th char. sl@0: */ sl@0: sl@0: if (objv[2]->typePtr == &tclByteArrayType) { sl@0: string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1); sl@0: sl@0: if (TclGetIntForIndex(interp, objv[3], length1 - 1, sl@0: &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if ((index >= 0) && (index < length1)) { sl@0: Tcl_SetByteArrayObj(resultPtr, sl@0: (unsigned char *)(&string1[index]), 1); sl@0: } sl@0: } else { sl@0: /* sl@0: * Get Unicode char length to calulate what 'end' means. sl@0: */ sl@0: length1 = Tcl_GetCharLength(objv[2]); sl@0: sl@0: if (TclGetIntForIndex(interp, objv[3], length1 - 1, sl@0: &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if ((index >= 0) && (index < length1)) { sl@0: char buf[TCL_UTF_MAX]; sl@0: Tcl_UniChar ch; sl@0: sl@0: ch = Tcl_GetUniChar(objv[2], index); sl@0: length1 = Tcl_UniCharToUtf(ch, buf); sl@0: Tcl_SetStringObj(resultPtr, buf, length1); sl@0: } sl@0: } sl@0: break; sl@0: } sl@0: case STR_IS: { sl@0: char *end; sl@0: Tcl_UniChar ch; sl@0: sl@0: /* sl@0: * The UniChar comparison function sl@0: */ sl@0: sl@0: int (*chcomp)_ANSI_ARGS_((int)) = NULL; sl@0: int i, failat = 0, result = 1, strict = 0; sl@0: Tcl_Obj *objPtr, *failVarObj = NULL; sl@0: sl@0: static CONST char *isOptions[] = { sl@0: "alnum", "alpha", "ascii", "control", sl@0: "boolean", "digit", "double", "false", sl@0: "graph", "integer", "lower", "print", sl@0: "punct", "space", "true", "upper", sl@0: "wordchar", "xdigit", (char *) NULL sl@0: }; sl@0: enum isOptions { sl@0: STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, sl@0: STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE, sl@0: STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT, sl@0: STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, sl@0: STR_IS_WORD, STR_IS_XDIGIT sl@0: }; sl@0: sl@0: if (objc < 4 || objc > 7) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "class ?-strict? ?-failindex var? str"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0, sl@0: &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (objc != 4) { sl@0: for (i = 3; i < objc-1; i++) { sl@0: string2 = Tcl_GetStringFromObj(objv[i], &length2); sl@0: if ((length2 > 1) && sl@0: strncmp(string2, "-strict", (size_t) length2) == 0) { sl@0: strict = 1; sl@0: } else if ((length2 > 1) && sl@0: strncmp(string2, "-failindex", sl@0: (size_t) length2) == 0) { sl@0: if (i+1 >= objc-1) { sl@0: Tcl_WrongNumArgs(interp, 3, objv, sl@0: "?-strict? ?-failindex var? str"); sl@0: return TCL_ERROR; sl@0: } sl@0: failVarObj = objv[++i]; sl@0: } else { sl@0: Tcl_AppendStringsToObj(resultPtr, "bad option \"", sl@0: string2, "\": must be -strict or -failindex", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * We get the objPtr so that we can short-cut for some classes sl@0: * by checking the object type (int and double), but we need sl@0: * the string otherwise, because we don't want any conversion sl@0: * of type occuring (as, for example, Tcl_Get*FromObj would do sl@0: */ sl@0: objPtr = objv[objc-1]; sl@0: string1 = Tcl_GetStringFromObj(objPtr, &length1); sl@0: if (length1 == 0) { sl@0: if (strict) { sl@0: result = 0; sl@0: } sl@0: goto str_is_done; sl@0: } sl@0: end = string1 + length1; sl@0: sl@0: /* sl@0: * When entering here, result == 1 and failat == 0 sl@0: */ sl@0: switch ((enum isOptions) index) { sl@0: case STR_IS_ALNUM: sl@0: chcomp = Tcl_UniCharIsAlnum; sl@0: break; sl@0: case STR_IS_ALPHA: sl@0: chcomp = Tcl_UniCharIsAlpha; sl@0: break; sl@0: case STR_IS_ASCII: sl@0: for (; string1 < end; string1++, failat++) { sl@0: /* sl@0: * This is a valid check in unicode, because all sl@0: * bytes < 0xC0 are single byte chars (but isascii sl@0: * limits that def'n to 0x80). sl@0: */ sl@0: if (*((unsigned char *)string1) >= 0x80) { sl@0: result = 0; sl@0: break; sl@0: } sl@0: } sl@0: break; sl@0: case STR_IS_BOOL: sl@0: case STR_IS_TRUE: sl@0: case STR_IS_FALSE: sl@0: /* Optimizers, beware Bug 1187123 ! */ sl@0: if ((Tcl_GetBoolean(NULL, string1, &i) sl@0: == TCL_ERROR) || sl@0: (((enum isOptions) index == STR_IS_TRUE) && sl@0: i == 0) || sl@0: (((enum isOptions) index == STR_IS_FALSE) && sl@0: i != 0)) { sl@0: result = 0; sl@0: } sl@0: break; sl@0: case STR_IS_CONTROL: sl@0: chcomp = Tcl_UniCharIsControl; sl@0: break; sl@0: case STR_IS_DIGIT: sl@0: chcomp = Tcl_UniCharIsDigit; sl@0: break; sl@0: case STR_IS_DOUBLE: { sl@0: char *stop; sl@0: sl@0: if ((objPtr->typePtr == &tclDoubleType) || sl@0: (objPtr->typePtr == &tclIntType)) { sl@0: break; sl@0: } sl@0: /* sl@0: * This is adapted from Tcl_GetDouble sl@0: * sl@0: * The danger in this function is that sl@0: * "12345678901234567890" is an acceptable 'double', sl@0: * but will later be interp'd as an int by something sl@0: * like [expr]. Therefore, we check to see if it looks sl@0: * like an int, and if so we do a range check on it. sl@0: * If strtoul gets to the end, we know we either sl@0: * received an acceptable int, or over/underflow sl@0: */ sl@0: if (TclLooksLikeInt(string1, length1)) { sl@0: errno = 0; sl@0: #ifdef TCL_WIDE_INT_IS_LONG sl@0: strtoul(string1, &stop, 0); /* INTL: Tcl source. */ sl@0: #else sl@0: strtoull(string1, &stop, 0); /* INTL: Tcl source. */ sl@0: #endif sl@0: if (stop == end) { sl@0: if (errno == ERANGE) { sl@0: result = 0; sl@0: failat = -1; sl@0: } sl@0: break; sl@0: } sl@0: } sl@0: errno = 0; sl@0: strtod(string1, &stop); /* INTL: Tcl source. */ sl@0: if (errno == ERANGE) { sl@0: /* sl@0: * if (errno == ERANGE), then it was an over/underflow sl@0: * problem, but in this method, we only want to know sl@0: * yes or no, so bad flow returns 0 (false) and sets sl@0: * the failVarObj to the string length. sl@0: */ sl@0: result = 0; sl@0: failat = -1; sl@0: } else if (stop == string1) { sl@0: /* sl@0: * In this case, nothing like a number was found sl@0: */ sl@0: result = 0; sl@0: failat = 0; sl@0: } else { sl@0: /* sl@0: * Assume we sucked up one char per byte sl@0: * and then we go onto SPACE, since we are sl@0: * allowed trailing whitespace sl@0: */ sl@0: failat = stop - string1; sl@0: string1 = stop; sl@0: chcomp = Tcl_UniCharIsSpace; sl@0: } sl@0: break; sl@0: } sl@0: case STR_IS_GRAPH: sl@0: chcomp = Tcl_UniCharIsGraph; sl@0: break; sl@0: case STR_IS_INT: { sl@0: char *stop; sl@0: long int l = 0; sl@0: sl@0: if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) { sl@0: break; sl@0: } sl@0: /* sl@0: * Like STR_IS_DOUBLE, but we use strtoul. sl@0: * Since Tcl_GetIntFromObj already failed, sl@0: * we set result to 0. sl@0: */ sl@0: result = 0; sl@0: errno = 0; sl@0: l = strtol(string1, &stop, 0); /* INTL: Tcl source. */ sl@0: if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) { sl@0: /* sl@0: * if (errno == ERANGE), then it was an over/underflow sl@0: * problem, but in this method, we only want to know sl@0: * yes or no, so bad flow returns 0 (false) and sets sl@0: * the failVarObj to the string length. sl@0: */ sl@0: failat = -1; sl@0: sl@0: } else if (stop == string1) { sl@0: /* sl@0: * In this case, nothing like a number was found sl@0: */ sl@0: failat = 0; sl@0: } else { sl@0: /* sl@0: * Assume we sucked up one char per byte sl@0: * and then we go onto SPACE, since we are sl@0: * allowed trailing whitespace sl@0: */ sl@0: failat = stop - string1; sl@0: string1 = stop; sl@0: chcomp = Tcl_UniCharIsSpace; sl@0: } sl@0: break; sl@0: } sl@0: case STR_IS_LOWER: sl@0: chcomp = Tcl_UniCharIsLower; sl@0: break; sl@0: case STR_IS_PRINT: sl@0: chcomp = Tcl_UniCharIsPrint; sl@0: break; sl@0: case STR_IS_PUNCT: sl@0: chcomp = Tcl_UniCharIsPunct; sl@0: break; sl@0: case STR_IS_SPACE: sl@0: chcomp = Tcl_UniCharIsSpace; sl@0: break; sl@0: case STR_IS_UPPER: sl@0: chcomp = Tcl_UniCharIsUpper; sl@0: break; sl@0: case STR_IS_WORD: sl@0: chcomp = Tcl_UniCharIsWordChar; sl@0: break; sl@0: case STR_IS_XDIGIT: { sl@0: for (; string1 < end; string1++, failat++) { sl@0: /* INTL: We assume unicode is bad for this class */ sl@0: if ((*((unsigned char *)string1) >= 0xC0) || sl@0: !isxdigit(*(unsigned char *)string1)) { sl@0: result = 0; sl@0: break; sl@0: } sl@0: } sl@0: break; sl@0: } sl@0: } sl@0: if (chcomp != NULL) { sl@0: for (; string1 < end; string1 += length2, failat++) { sl@0: length2 = TclUtfToUniChar(string1, &ch); sl@0: if (!chcomp(ch)) { sl@0: result = 0; sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: str_is_done: sl@0: /* sl@0: * Only set the failVarObj when we will return 0 sl@0: * and we have indicated a valid fail index (>= 0) sl@0: */ sl@0: if ((result == 0) && (failVarObj != NULL)) { sl@0: Tcl_Obj *resPtr, *tmpPtr = Tcl_NewIntObj(failat); sl@0: sl@0: Tcl_IncrRefCount(tmpPtr); sl@0: resPtr = Tcl_ObjSetVar2(interp, failVarObj, NULL, tmpPtr, sl@0: TCL_LEAVE_ERR_MSG); sl@0: Tcl_DecrRefCount(tmpPtr); sl@0: if (resPtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: Tcl_SetBooleanObj(resultPtr, result); sl@0: break; sl@0: } sl@0: case STR_LAST: { sl@0: Tcl_UniChar *ustring1, *ustring2, *p; sl@0: int match, start; sl@0: sl@0: if (objc < 4 || objc > 5) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "subString string ?startIndex?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * We are searching string2 for the sequence string1. sl@0: */ sl@0: sl@0: match = -1; sl@0: start = 0; sl@0: length2 = -1; sl@0: sl@0: ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); sl@0: ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); sl@0: sl@0: if (objc == 5) { sl@0: /* sl@0: * If a startIndex is specified, we will need to restrict sl@0: * the string range to that char index in the string sl@0: */ sl@0: if (TclGetIntForIndex(interp, objv[4], length2 - 1, sl@0: &start) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (start < 0) { sl@0: goto str_last_done; sl@0: } else if (start < length2) { sl@0: p = ustring2 + start + 1 - length1; sl@0: } else { sl@0: p = ustring2 + length2 - length1; sl@0: } sl@0: } else { sl@0: p = ustring2 + length2 - length1; sl@0: } sl@0: sl@0: if (length1 > 0) { sl@0: for (; p >= ustring2; p--) { sl@0: /* sl@0: * Scan backwards to find the first character. sl@0: */ sl@0: if ((*p == *ustring1) && sl@0: (memcmp((char *) ustring1, (char *) p, (size_t) sl@0: (length1 * sizeof(Tcl_UniChar))) == 0)) { sl@0: match = p - ustring2; sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: sl@0: str_last_done: sl@0: Tcl_SetIntObj(resultPtr, match); sl@0: break; sl@0: } sl@0: case STR_BYTELENGTH: sl@0: case STR_LENGTH: { sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "string"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if ((enum options) index == STR_BYTELENGTH) { sl@0: (void) Tcl_GetStringFromObj(objv[2], &length1); sl@0: } else { sl@0: /* sl@0: * If we have a ByteArray object, avoid recomputing the sl@0: * string since the byte array contains one byte per sl@0: * character. Otherwise, use the Unicode string rep to sl@0: * calculate the length. sl@0: */ sl@0: sl@0: if (objv[2]->typePtr == &tclByteArrayType) { sl@0: (void) Tcl_GetByteArrayFromObj(objv[2], &length1); sl@0: } else { sl@0: length1 = Tcl_GetCharLength(objv[2]); sl@0: } sl@0: } sl@0: Tcl_SetIntObj(resultPtr, length1); sl@0: break; sl@0: } sl@0: case STR_MAP: { sl@0: int mapElemc, nocase = 0, copySource = 0; sl@0: Tcl_Obj **mapElemv, *sourceObj; sl@0: Tcl_UniChar *ustring1, *ustring2, *p, *end; sl@0: int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*, sl@0: CONST Tcl_UniChar*, unsigned long)); sl@0: sl@0: if (objc < 4 || objc > 5) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (objc == 5) { sl@0: string2 = Tcl_GetStringFromObj(objv[2], &length2); sl@0: if ((length2 > 1) && sl@0: strncmp(string2, "-nocase", (size_t) length2) == 0) { sl@0: nocase = 1; sl@0: } else { sl@0: Tcl_AppendStringsToObj(resultPtr, "bad option \"", sl@0: string2, "\": must be -nocase", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: if (Tcl_ListObjGetElements(interp, objv[objc-2], &mapElemc, sl@0: &mapElemv) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (mapElemc == 0) { sl@0: /* sl@0: * empty charMap, just return whatever string was given sl@0: */ sl@0: Tcl_SetObjResult(interp, objv[objc-1]); sl@0: return TCL_OK; sl@0: } else if (mapElemc & 1) { sl@0: /* sl@0: * The charMap must be an even number of key/value items sl@0: */ sl@0: Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Take a copy of the source string object if it is the sl@0: * same as the map string to cut out nasty sharing sl@0: * crashes. [Bug 1018562] sl@0: */ sl@0: if (objv[objc-2] == objv[objc-1]) { sl@0: sourceObj = Tcl_DuplicateObj(objv[objc-1]); sl@0: copySource = 1; sl@0: } else { sl@0: sourceObj = objv[objc-1]; sl@0: } sl@0: ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1); sl@0: if (length1 == 0) { sl@0: /* sl@0: * Empty input string, just stop now sl@0: */ sl@0: if (copySource) { sl@0: Tcl_DecrRefCount(sourceObj); sl@0: } sl@0: break; sl@0: } sl@0: end = ustring1 + length1; sl@0: sl@0: strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; sl@0: sl@0: /* sl@0: * Force result to be Unicode sl@0: */ sl@0: Tcl_SetUnicodeObj(resultPtr, ustring1, 0); sl@0: sl@0: if (mapElemc == 2) { sl@0: /* sl@0: * Special case for one map pair which avoids the extra sl@0: * for loop and extra calls to get Unicode data. The sl@0: * algorithm is otherwise identical to the multi-pair case. sl@0: * This will be >30% faster on larger strings. sl@0: */ sl@0: int mapLen; sl@0: Tcl_UniChar *mapString, u2lc; sl@0: sl@0: ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); sl@0: p = ustring1; sl@0: if ((length2 > length1) || (length2 == 0)) { sl@0: /* match string is either longer than input or empty */ sl@0: ustring1 = end; sl@0: } else { sl@0: mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); sl@0: u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); sl@0: for (; ustring1 < end; ustring1++) { sl@0: if (((*ustring1 == *ustring2) || sl@0: (nocase && (Tcl_UniCharToLower(*ustring1) == sl@0: u2lc))) && sl@0: ((length2 == 1) || strCmpFn(ustring1, ustring2, sl@0: (unsigned long) length2) == 0)) { sl@0: if (p != ustring1) { sl@0: Tcl_AppendUnicodeToObj(resultPtr, p, sl@0: ustring1 - p); sl@0: p = ustring1 + length2; sl@0: } else { sl@0: p += length2; sl@0: } sl@0: ustring1 = p - 1; sl@0: sl@0: Tcl_AppendUnicodeToObj(resultPtr, mapString, sl@0: mapLen); sl@0: } sl@0: } sl@0: } sl@0: } else { sl@0: Tcl_UniChar **mapStrings, *u2lc = NULL; sl@0: int *mapLens; sl@0: /* sl@0: * Precompute pointers to the unicode string and length. sl@0: * This saves us repeated function calls later, sl@0: * significantly speeding up the algorithm. We only need sl@0: * the lowercase first char in the nocase case. sl@0: */ sl@0: mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2) sl@0: * sizeof(Tcl_UniChar *)); sl@0: mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int)); sl@0: if (nocase) { sl@0: u2lc = (Tcl_UniChar *) sl@0: ckalloc((mapElemc) * sizeof(Tcl_UniChar)); sl@0: } sl@0: for (index = 0; index < mapElemc; index++) { sl@0: mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], sl@0: &(mapLens[index])); sl@0: if (nocase && ((index % 2) == 0)) { sl@0: u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); sl@0: } sl@0: } sl@0: for (p = ustring1; ustring1 < end; ustring1++) { sl@0: for (index = 0; index < mapElemc; index += 2) { sl@0: /* sl@0: * Get the key string to match on. sl@0: */ sl@0: ustring2 = mapStrings[index]; sl@0: length2 = mapLens[index]; sl@0: if ((length2 > 0) && ((*ustring1 == *ustring2) || sl@0: (nocase && (Tcl_UniCharToLower(*ustring1) == sl@0: u2lc[index/2]))) && sl@0: /* restrict max compare length */ sl@0: ((end - ustring1) >= length2) && sl@0: ((length2 == 1) || strCmpFn(ustring2, ustring1, sl@0: (unsigned long) length2) == 0)) { sl@0: if (p != ustring1) { sl@0: /* sl@0: * Put the skipped chars onto the result first sl@0: */ sl@0: Tcl_AppendUnicodeToObj(resultPtr, p, sl@0: ustring1 - p); sl@0: p = ustring1 + length2; sl@0: } else { sl@0: p += length2; sl@0: } sl@0: /* sl@0: * Adjust len to be full length of matched string sl@0: */ sl@0: ustring1 = p - 1; sl@0: sl@0: /* sl@0: * Append the map value to the unicode string sl@0: */ sl@0: Tcl_AppendUnicodeToObj(resultPtr, sl@0: mapStrings[index+1], mapLens[index+1]); sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: ckfree((char *) mapStrings); sl@0: ckfree((char *) mapLens); sl@0: if (nocase) { sl@0: ckfree((char *) u2lc); sl@0: } sl@0: } sl@0: if (p != ustring1) { sl@0: /* sl@0: * Put the rest of the unmapped chars onto result sl@0: */ sl@0: Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); sl@0: } sl@0: if (copySource) { sl@0: Tcl_DecrRefCount(sourceObj); sl@0: } sl@0: break; sl@0: } sl@0: case STR_MATCH: { sl@0: Tcl_UniChar *ustring1, *ustring2; sl@0: int nocase = 0; sl@0: sl@0: if (objc < 4 || objc > 5) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (objc == 5) { sl@0: string2 = Tcl_GetStringFromObj(objv[2], &length2); sl@0: if ((length2 > 1) && sl@0: strncmp(string2, "-nocase", (size_t) length2) == 0) { sl@0: nocase = 1; sl@0: } else { sl@0: Tcl_AppendStringsToObj(resultPtr, "bad option \"", sl@0: string2, "\": must be -nocase", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1); sl@0: ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2); sl@0: Tcl_SetBooleanObj(resultPtr, TclUniCharMatch(ustring1, length1, sl@0: ustring2, length2, nocase)); sl@0: break; sl@0: } sl@0: case STR_RANGE: { sl@0: int first, last; sl@0: sl@0: if (objc != 5) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "string first last"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * If we have a ByteArray object, avoid indexing in the sl@0: * Utf string since the byte array contains one byte per sl@0: * character. Otherwise, use the Unicode string rep to sl@0: * get the range. sl@0: */ sl@0: sl@0: if (objv[2]->typePtr == &tclByteArrayType) { sl@0: string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1); sl@0: length1--; sl@0: } else { sl@0: /* sl@0: * Get the length in actual characters. sl@0: */ sl@0: string1 = NULL; sl@0: length1 = Tcl_GetCharLength(objv[2]) - 1; sl@0: } sl@0: sl@0: if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) sl@0: || (TclGetIntForIndex(interp, objv[4], length1, sl@0: &last) != TCL_OK)) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (first < 0) { sl@0: first = 0; sl@0: } sl@0: if (last >= length1) { sl@0: last = length1; sl@0: } sl@0: if (last >= first) { sl@0: if (string1 != NULL) { sl@0: int numBytes = last - first + 1; sl@0: resultPtr = Tcl_NewByteArrayObj( sl@0: (unsigned char *) &string1[first], numBytes); sl@0: Tcl_SetObjResult(interp, resultPtr); sl@0: } else { sl@0: Tcl_SetObjResult(interp, sl@0: Tcl_GetRange(objv[2], first, last)); sl@0: } sl@0: } sl@0: break; sl@0: } sl@0: case STR_REPEAT: { sl@0: int count; sl@0: sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "string count"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (count == 1) { sl@0: Tcl_SetObjResult(interp, objv[2]); sl@0: } else if (count > 1) { sl@0: string1 = Tcl_GetStringFromObj(objv[2], &length1); sl@0: if (length1 > 0) { sl@0: /* sl@0: * Only build up a string that has data. Instead of sl@0: * building it up with repeated appends, we just allocate sl@0: * the necessary space once and copy the string value in. sl@0: * Check for overflow with back-division. [Bug #714106] sl@0: */ sl@0: length2 = length1 * count; sl@0: if ((length2 / count) != length1) { sl@0: char buf[TCL_INTEGER_SPACE+1]; sl@0: sprintf(buf, "%d", INT_MAX); sl@0: Tcl_AppendStringsToObj(resultPtr, sl@0: "string size overflow, must be less than ", sl@0: buf, (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: /* sl@0: * Include space for the NULL sl@0: */ sl@0: string2 = (char *) ckalloc((size_t) length2+1); sl@0: for (index = 0; index < count; index++) { sl@0: memcpy(string2 + (length1 * index), string1, sl@0: (size_t) length1); sl@0: } sl@0: string2[length2] = '\0'; sl@0: /* sl@0: * We have to directly assign this instead of using sl@0: * Tcl_SetStringObj (and indirectly TclInitStringRep) sl@0: * because that makes another copy of the data. sl@0: */ sl@0: resultPtr = Tcl_NewObj(); sl@0: resultPtr->bytes = string2; sl@0: resultPtr->length = length2; sl@0: Tcl_SetObjResult(interp, resultPtr); sl@0: } sl@0: } sl@0: break; sl@0: } sl@0: case STR_REPLACE: { sl@0: Tcl_UniChar *ustring1; sl@0: int first, last; sl@0: sl@0: if (objc < 5 || objc > 6) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "string first last ?string?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); sl@0: length1--; sl@0: sl@0: if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) sl@0: || (TclGetIntForIndex(interp, objv[4], length1, sl@0: &last) != TCL_OK)) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if ((last < first) || (last < 0) || (first > length1)) { sl@0: Tcl_SetObjResult(interp, objv[2]); sl@0: } else { sl@0: if (first < 0) { sl@0: first = 0; sl@0: } sl@0: sl@0: Tcl_SetUnicodeObj(resultPtr, ustring1, first); sl@0: if (objc == 6) { sl@0: Tcl_AppendObjToObj(resultPtr, objv[5]); sl@0: } sl@0: if (last < length1) { sl@0: Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1, sl@0: length1 - last); sl@0: } sl@0: } sl@0: break; sl@0: } sl@0: case STR_TOLOWER: sl@0: case STR_TOUPPER: sl@0: case STR_TOTITLE: sl@0: if (objc < 3 || objc > 5) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: string1 = Tcl_GetStringFromObj(objv[2], &length1); sl@0: sl@0: if (objc == 3) { sl@0: /* sl@0: * Since the result object is not a shared object, it is sl@0: * safe to copy the string into the result and do the sl@0: * conversion in place. The conversion may change the length sl@0: * of the string, so reset the length after conversion. sl@0: */ sl@0: sl@0: Tcl_SetStringObj(resultPtr, string1, length1); sl@0: if ((enum options) index == STR_TOLOWER) { sl@0: length1 = Tcl_UtfToLower(Tcl_GetString(resultPtr)); sl@0: } else if ((enum options) index == STR_TOUPPER) { sl@0: length1 = Tcl_UtfToUpper(Tcl_GetString(resultPtr)); sl@0: } else { sl@0: length1 = Tcl_UtfToTitle(Tcl_GetString(resultPtr)); sl@0: } sl@0: Tcl_SetObjLength(resultPtr, length1); sl@0: } else { sl@0: int first, last; sl@0: CONST char *start, *end; sl@0: sl@0: length1 = Tcl_NumUtfChars(string1, length1) - 1; sl@0: if (TclGetIntForIndex(interp, objv[3], length1, sl@0: &first) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (first < 0) { sl@0: first = 0; sl@0: } sl@0: last = first; sl@0: if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1, sl@0: &last) != TCL_OK)) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (last >= length1) { sl@0: last = length1; sl@0: } sl@0: if (last < first) { sl@0: Tcl_SetObjResult(interp, objv[2]); sl@0: break; sl@0: } sl@0: start = Tcl_UtfAtIndex(string1, first); sl@0: end = Tcl_UtfAtIndex(start, last - first + 1); sl@0: length2 = end-start; sl@0: string2 = ckalloc((size_t) length2+1); sl@0: memcpy(string2, start, (size_t) length2); sl@0: string2[length2] = '\0'; sl@0: if ((enum options) index == STR_TOLOWER) { sl@0: length2 = Tcl_UtfToLower(string2); sl@0: } else if ((enum options) index == STR_TOUPPER) { sl@0: length2 = Tcl_UtfToUpper(string2); sl@0: } else { sl@0: length2 = Tcl_UtfToTitle(string2); sl@0: } sl@0: Tcl_SetStringObj(resultPtr, string1, start - string1); sl@0: Tcl_AppendToObj(resultPtr, string2, length2); sl@0: Tcl_AppendToObj(resultPtr, end, -1); sl@0: ckfree(string2); sl@0: } sl@0: break; sl@0: sl@0: case STR_TRIM: { sl@0: Tcl_UniChar ch, trim; sl@0: register CONST char *p, *end; sl@0: char *check, *checkEnd; sl@0: int offset; sl@0: sl@0: left = 1; sl@0: right = 1; sl@0: sl@0: dotrim: sl@0: if (objc == 4) { sl@0: string2 = Tcl_GetStringFromObj(objv[3], &length2); sl@0: } else if (objc == 3) { sl@0: string2 = " \t\n\r"; sl@0: length2 = strlen(string2); sl@0: } else { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?"); sl@0: return TCL_ERROR; sl@0: } sl@0: string1 = Tcl_GetStringFromObj(objv[2], &length1); sl@0: checkEnd = string2 + length2; sl@0: sl@0: if (left) { sl@0: end = string1 + length1; sl@0: /* sl@0: * The outer loop iterates over the string. The inner sl@0: * loop iterates over the trim characters. The loops sl@0: * terminate as soon as a non-trim character is discovered sl@0: * and string1 is left pointing at the first non-trim sl@0: * character. sl@0: */ sl@0: sl@0: for (p = string1; p < end; p += offset) { sl@0: offset = TclUtfToUniChar(p, &ch); sl@0: sl@0: for (check = string2; ; ) { sl@0: if (check >= checkEnd) { sl@0: p = end; sl@0: break; sl@0: } sl@0: check += TclUtfToUniChar(check, &trim); sl@0: if (ch == trim) { sl@0: length1 -= offset; sl@0: string1 += offset; sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: } sl@0: if (right) { sl@0: end = string1; sl@0: sl@0: /* sl@0: * The outer loop iterates over the string. The inner sl@0: * loop iterates over the trim characters. The loops sl@0: * terminate as soon as a non-trim character is discovered sl@0: * and length1 marks the last non-trim character. sl@0: */ sl@0: sl@0: for (p = string1 + length1; p > end; ) { sl@0: p = Tcl_UtfPrev(p, string1); sl@0: offset = TclUtfToUniChar(p, &ch); sl@0: for (check = string2; ; ) { sl@0: if (check >= checkEnd) { sl@0: p = end; sl@0: break; sl@0: } sl@0: check += TclUtfToUniChar(check, &trim); sl@0: if (ch == trim) { sl@0: length1 -= offset; sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: } sl@0: Tcl_SetStringObj(resultPtr, string1, length1); sl@0: break; sl@0: } sl@0: case STR_TRIMLEFT: { sl@0: left = 1; sl@0: right = 0; sl@0: goto dotrim; sl@0: } sl@0: case STR_TRIMRIGHT: { sl@0: left = 0; sl@0: right = 1; sl@0: goto dotrim; sl@0: } sl@0: case STR_WORDEND: { sl@0: int cur; sl@0: Tcl_UniChar ch; sl@0: CONST char *p, *end; sl@0: int numChars; sl@0: sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "string index"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: string1 = Tcl_GetStringFromObj(objv[2], &length1); sl@0: numChars = Tcl_NumUtfChars(string1, length1); sl@0: if (TclGetIntForIndex(interp, objv[3], numChars-1, sl@0: &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (index < 0) { sl@0: index = 0; sl@0: } sl@0: if (index < numChars) { sl@0: p = Tcl_UtfAtIndex(string1, index); sl@0: end = string1+length1; sl@0: for (cur = index; p < end; cur++) { sl@0: p += TclUtfToUniChar(p, &ch); sl@0: if (!Tcl_UniCharIsWordChar(ch)) { sl@0: break; sl@0: } sl@0: } sl@0: if (cur == index) { sl@0: cur++; sl@0: } sl@0: } else { sl@0: cur = numChars; sl@0: } sl@0: Tcl_SetIntObj(resultPtr, cur); sl@0: break; sl@0: } sl@0: case STR_WORDSTART: { sl@0: int cur; sl@0: Tcl_UniChar ch; sl@0: CONST char *p; sl@0: int numChars; sl@0: sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "string index"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: string1 = Tcl_GetStringFromObj(objv[2], &length1); sl@0: numChars = Tcl_NumUtfChars(string1, length1); sl@0: if (TclGetIntForIndex(interp, objv[3], numChars-1, sl@0: &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (index >= numChars) { sl@0: index = numChars - 1; sl@0: } sl@0: cur = 0; sl@0: if (index > 0) { sl@0: p = Tcl_UtfAtIndex(string1, index); sl@0: for (cur = index; cur >= 0; cur--) { sl@0: TclUtfToUniChar(p, &ch); sl@0: if (!Tcl_UniCharIsWordChar(ch)) { sl@0: break; sl@0: } sl@0: p = Tcl_UtfPrev(p, string1); sl@0: } sl@0: if (cur != index) { sl@0: cur += 1; sl@0: } sl@0: } sl@0: Tcl_SetIntObj(resultPtr, cur); sl@0: break; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SubstObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "subst" Tcl command. sl@0: * See the user documentation for details on what it does. This sl@0: * command relies on Tcl_SubstObj() for its implementation. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_SubstObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: static CONST char *substOptions[] = { sl@0: "-nobackslashes", "-nocommands", "-novariables", (char *) NULL sl@0: }; sl@0: enum substOptions { sl@0: SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS sl@0: }; sl@0: Tcl_Obj *resultPtr; sl@0: int optionIndex, flags, i; sl@0: sl@0: /* sl@0: * Parse command-line options. sl@0: */ sl@0: sl@0: flags = TCL_SUBST_ALL; sl@0: for (i = 1; i < (objc-1); i++) { sl@0: if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, sl@0: "switch", 0, &optionIndex) != TCL_OK) { sl@0: sl@0: return TCL_ERROR; sl@0: } sl@0: switch (optionIndex) { sl@0: case SUBST_NOBACKSLASHES: { sl@0: flags &= ~TCL_SUBST_BACKSLASHES; sl@0: break; sl@0: } sl@0: case SUBST_NOCOMMANDS: { sl@0: flags &= ~TCL_SUBST_COMMANDS; sl@0: break; sl@0: } sl@0: case SUBST_NOVARS: { sl@0: flags &= ~TCL_SUBST_VARIABLES; sl@0: break; sl@0: } sl@0: default: { sl@0: panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); sl@0: } sl@0: } sl@0: } sl@0: if (i != (objc-1)) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, sl@0: "?-nobackslashes? ?-nocommands? ?-novariables? string"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Perform the substitution. sl@0: */ sl@0: resultPtr = Tcl_SubstObj(interp, objv[i], flags); sl@0: sl@0: if (resultPtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetObjResult(interp, resultPtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SubstObj -- sl@0: * sl@0: * This function performs the substitutions specified on the sl@0: * given string as described in the user documentation for the sl@0: * "subst" Tcl command. This code is heavily based on an sl@0: * implementation by Andrew Payne. Note that if a command sl@0: * substitution returns TCL_CONTINUE or TCL_RETURN from its sl@0: * evaluation and is not completely well-formed, the results are sl@0: * not defined (or at least hard to characterise.) This fault sl@0: * will be fixed at some point, but the cost of the only sane sl@0: * fix (well-formedness check first) is such that you need to sl@0: * "precompile and cache" to stop everyone from being hit with sl@0: * the consequences every time through. Note that the current sl@0: * behaviour is not a security hole; it just restarts parsing sl@0: * the string following the substitution in a mildly surprising sl@0: * place, and it is a very bad idea to count on this remaining sl@0: * the same in future... sl@0: * sl@0: * Results: sl@0: * A Tcl_Obj* containing the substituted string, or NULL to sl@0: * indicate that an error occurred. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_SubstObj(interp, objPtr, flags) sl@0: Tcl_Interp *interp; sl@0: Tcl_Obj *objPtr; sl@0: int flags; sl@0: { sl@0: Tcl_Obj *resultObj; sl@0: char *p, *old; sl@0: int length; sl@0: sl@0: old = p = Tcl_GetStringFromObj(objPtr, &length); sl@0: resultObj = Tcl_NewStringObj("", 0); sl@0: while (length) { sl@0: switch (*p) { sl@0: case '\\': sl@0: if (flags & TCL_SUBST_BACKSLASHES) { sl@0: char buf[TCL_UTF_MAX]; sl@0: int count; sl@0: sl@0: if (p != old) { sl@0: Tcl_AppendToObj(resultObj, old, p-old); sl@0: } sl@0: Tcl_AppendToObj(resultObj, buf, sl@0: Tcl_UtfBackslash(p, &count, buf)); sl@0: p += count; length -= count; sl@0: old = p; sl@0: } else { sl@0: p++; length--; sl@0: } sl@0: break; sl@0: sl@0: case '$': sl@0: if (flags & TCL_SUBST_VARIABLES) { sl@0: Tcl_Parse parse; sl@0: int code; sl@0: sl@0: /* sl@0: * Code is simpler overall if we (effectively) inline sl@0: * Tcl_ParseVar, particularly as that allows us to use sl@0: * a non-string interface when we come to appending sl@0: * the variable contents to the result object. There sl@0: * are a few other optimisations that doing this sl@0: * enables (like being able to continue the run of sl@0: * unsubstituted characters straight through if a '$' sl@0: * does not precede a variable name.) sl@0: */ sl@0: if (Tcl_ParseVarName(interp, p, -1, &parse, 0) != TCL_OK) { sl@0: goto errorResult; sl@0: } sl@0: if (parse.numTokens == 1) { sl@0: /* sl@0: * There isn't a variable name after all: the $ is sl@0: * just a $. sl@0: */ sl@0: p++; length--; sl@0: break; sl@0: } sl@0: if (p != old) { sl@0: Tcl_AppendToObj(resultObj, old, p-old); sl@0: } sl@0: p += parse.tokenPtr->size; sl@0: length -= parse.tokenPtr->size; sl@0: code = Tcl_EvalTokensStandard(interp, parse.tokenPtr, sl@0: parse.numTokens); sl@0: if (code == TCL_ERROR) { sl@0: goto errorResult; sl@0: } sl@0: if (code == TCL_BREAK) { sl@0: Tcl_ResetResult(interp); sl@0: return resultObj; sl@0: } sl@0: if (code != TCL_CONTINUE) { sl@0: Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp)); sl@0: } sl@0: Tcl_ResetResult(interp); sl@0: old = p; sl@0: } else { sl@0: p++; length--; sl@0: } sl@0: break; sl@0: sl@0: case '[': sl@0: if (flags & TCL_SUBST_COMMANDS) { sl@0: Interp *iPtr = (Interp *) interp; sl@0: int code; sl@0: sl@0: if (p != old) { sl@0: Tcl_AppendToObj(resultObj, old, p-old); sl@0: } sl@0: iPtr->evalFlags = TCL_BRACKET_TERM; sl@0: iPtr->numLevels++; sl@0: code = TclInterpReady(interp); sl@0: if (code == TCL_OK) { sl@0: code = Tcl_EvalEx(interp, p+1, -1, 0); sl@0: } sl@0: iPtr->numLevels--; sl@0: switch (code) { sl@0: case TCL_ERROR: sl@0: goto errorResult; sl@0: case TCL_BREAK: sl@0: Tcl_ResetResult(interp); sl@0: return resultObj; sl@0: default: sl@0: Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp)); sl@0: case TCL_CONTINUE: sl@0: Tcl_ResetResult(interp); sl@0: old = p = (p+1 + iPtr->termOffset + 1); sl@0: length -= (iPtr->termOffset + 2); sl@0: } sl@0: } else { sl@0: p++; length--; sl@0: } sl@0: break; sl@0: default: sl@0: p++; length--; sl@0: break; sl@0: } sl@0: } sl@0: if (p != old) { sl@0: Tcl_AppendToObj(resultObj, old, p-old); sl@0: } sl@0: return resultObj; sl@0: sl@0: errorResult: sl@0: Tcl_DecrRefCount(resultObj); sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SwitchObjCmd -- sl@0: * sl@0: * This object-based procedure is invoked to process the "switch" Tcl sl@0: * command. See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_SwitchObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int i, j, index, mode, matched, result, splitObjs; sl@0: char *string, *pattern; sl@0: Tcl_Obj *stringObj; sl@0: Tcl_Obj *CONST *savedObjv = objv; sl@0: #ifdef TCL_TIP280 sl@0: Interp* iPtr = (Interp*) interp; sl@0: int pc = 0; sl@0: int bidx = 0; /* Index of body argument */ sl@0: Tcl_Obj* blist = NULL; /* List obj which is the body */ sl@0: CmdFrame ctx; /* Copy of the topmost cmdframe, sl@0: * to allow us to mess with the sl@0: * line information */ sl@0: #endif sl@0: static CONST char *options[] = { sl@0: "-exact", "-glob", "-regexp", "--", sl@0: NULL sl@0: }; sl@0: enum options { sl@0: OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST sl@0: }; sl@0: sl@0: mode = OPT_EXACT; sl@0: for (i = 1; i < objc; i++) { sl@0: string = Tcl_GetString(objv[i]); sl@0: if (string[0] != '-') { sl@0: break; sl@0: } sl@0: if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, sl@0: &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (index == OPT_LAST) { sl@0: i++; sl@0: break; sl@0: } sl@0: mode = index; sl@0: } sl@0: sl@0: if (objc - i < 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, sl@0: "?switches? string pattern body ... ?default body?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: stringObj = objv[i]; sl@0: objc -= i + 1; sl@0: objv += i + 1; sl@0: #ifdef TCL_TIP280 sl@0: bidx = i+1; /* First after the match string */ sl@0: #endif sl@0: sl@0: /* sl@0: * If all of the pattern/command pairs are lumped into a single sl@0: * argument, split them out again. sl@0: * sl@0: * TIP #280: Determine the lines the words in the list start at, based on sl@0: * the same data for the list word itself. The cmdFramePtr line information sl@0: * is manipulated directly. sl@0: */ sl@0: sl@0: splitObjs = 0; sl@0: if (objc == 1) { sl@0: Tcl_Obj **listv; sl@0: #ifdef TCL_TIP280 sl@0: blist = objv[0]; sl@0: #endif sl@0: if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Ensure that the list is non-empty. sl@0: */ sl@0: sl@0: if (objc < 1) { sl@0: Tcl_WrongNumArgs(interp, 1, savedObjv, sl@0: "?switches? string {pattern body ... ?default body?}"); sl@0: return TCL_ERROR; sl@0: } sl@0: objv = listv; sl@0: splitObjs = 1; sl@0: } sl@0: sl@0: /* sl@0: * Complain if there is an odd number of words in the list of sl@0: * patterns and bodies. sl@0: */ sl@0: sl@0: if (objc % 2) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); sl@0: sl@0: /* sl@0: * Check if this can be due to a badly placed comment sl@0: * in the switch block. sl@0: * sl@0: * The following is an heuristic to detect the infamous sl@0: * "comment in switch" error: just check if a pattern sl@0: * begins with '#'. sl@0: */ sl@0: sl@0: if (splitObjs) { sl@0: for (i=0 ; icmdFramePtr; sl@0: sl@0: if (splitObjs) { sl@0: /* We have to perform the GetSrc and other type dependent handling sl@0: * of the frame here because we are munging with the line numbers, sl@0: * something the other commands like if, etc. are not doing. Them sl@0: * are fine with simply passing the CmdFrame through and having sl@0: * the special handling done in 'info frame', or the bc compiler sl@0: */ sl@0: sl@0: if (ctx.type == TCL_LOCATION_BC) { sl@0: /* Note: Type BC => ctx.data.eval.path is not used. sl@0: * ctx.data.tebc.codePtr is used instead. sl@0: */ sl@0: TclGetSrcInfoForPc (&ctx); sl@0: pc = 1; sl@0: /* The line information in the cmdFrame is now a copy we do sl@0: * not own */ sl@0: } sl@0: sl@0: if (ctx.type == TCL_LOCATION_SOURCE) { sl@0: int bline = ctx.line [bidx]; sl@0: if (bline >= 0) { sl@0: ctx.line = (int*) ckalloc (objc * sizeof(int)); sl@0: ctx.nline = objc; sl@0: sl@0: ListLines (Tcl_GetString (blist), bline, objc, ctx.line); sl@0: } else { sl@0: int k; sl@0: /* Dynamic code word ... All elements are relative to themselves */ sl@0: sl@0: ctx.line = (int*) ckalloc (objc * sizeof(int)); sl@0: ctx.nline = objc; sl@0: for (k=0; k < objc; k++) {ctx.line[k] = -1;} sl@0: } sl@0: } else { sl@0: int k; sl@0: /* Anything else ... No information, or dynamic ... */ sl@0: sl@0: ctx.line = (int*) ckalloc (objc * sizeof(int)); sl@0: ctx.nline = objc; sl@0: for (k=0; k < objc; k++) {ctx.line[k] = -1;} sl@0: } sl@0: } sl@0: #endif sl@0: sl@0: for (j = i + 1; ; j += 2) { sl@0: if (j >= objc) { sl@0: /* sl@0: * This shouldn't happen since we've checked that the sl@0: * last body is not a continuation... sl@0: */ sl@0: panic("fall-out when searching for body to match pattern"); sl@0: } sl@0: if (strcmp(Tcl_GetString(objv[j]), "-") != 0) { sl@0: break; sl@0: } sl@0: } sl@0: #ifndef TCL_TIP280 sl@0: result = Tcl_EvalObjEx(interp, objv[j], 0); sl@0: #else sl@0: /* TIP #280. Make invoking context available to switch branch */ sl@0: result = TclEvalObjEx(interp, objv[j], 0, &ctx, j); sl@0: if (splitObjs) { sl@0: ckfree ((char*) ctx.line); sl@0: if (pc && (ctx.type == TCL_LOCATION_SOURCE)) { sl@0: /* Death of SrcInfo reference */ sl@0: Tcl_DecrRefCount (ctx.data.eval.path); sl@0: } sl@0: } sl@0: #endif sl@0: if (result == TCL_ERROR) { sl@0: char msg[100 + TCL_INTEGER_SPACE]; sl@0: sl@0: sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern, sl@0: interp->errorLine); sl@0: Tcl_AddObjErrorInfo(interp, msg, -1); sl@0: } sl@0: return result; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_TimeObjCmd -- sl@0: * sl@0: * This object-based procedure is invoked to process the "time" Tcl sl@0: * command. See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_TimeObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: register Tcl_Obj *objPtr; sl@0: Tcl_Obj *objs[4]; sl@0: register int i, result; sl@0: int count; sl@0: double totalMicroSec; sl@0: Tcl_Time start, stop; sl@0: sl@0: if (objc == 2) { sl@0: count = 1; sl@0: } else if (objc == 3) { sl@0: result = Tcl_GetIntFromObj(interp, objv[2], &count); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: } else { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "command ?count?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: objPtr = objv[1]; sl@0: i = count; sl@0: Tcl_GetTime(&start); sl@0: while (i-- > 0) { sl@0: result = Tcl_EvalObjEx(interp, objPtr, 0); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: } sl@0: Tcl_GetTime(&stop); sl@0: sl@0: totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6 sl@0: + ( stop.usec - start.usec ) ); sl@0: if (count <= 1) { sl@0: /* Use int obj since we know time is not fractional [Bug 1202178] */ sl@0: objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec); sl@0: } else { sl@0: objs[0] = Tcl_NewDoubleObj(totalMicroSec/count); sl@0: } sl@0: objs[1] = Tcl_NewStringObj("microseconds", -1); sl@0: objs[2] = Tcl_NewStringObj("per", -1); sl@0: objs[3] = Tcl_NewStringObj("iteration", -1); sl@0: Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs)); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_TraceObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "trace" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Standard syntax as of Tcl 8.4 is sl@0: * sl@0: * trace {add|info|remove} {command|variable} name ops cmd sl@0: * sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_TraceObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int optionIndex; sl@0: char *name, *flagOps, *p; sl@0: /* Main sub commands to 'trace' */ sl@0: static CONST char *traceOptions[] = { sl@0: "add", "info", "remove", sl@0: #ifndef TCL_REMOVE_OBSOLETE_TRACES sl@0: "variable", "vdelete", "vinfo", sl@0: #endif sl@0: (char *) NULL sl@0: }; sl@0: /* 'OLD' options are pre-Tcl-8.4 style */ sl@0: enum traceOptions { sl@0: TRACE_ADD, TRACE_INFO, TRACE_REMOVE, sl@0: #ifndef TCL_REMOVE_OBSOLETE_TRACES sl@0: TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO sl@0: #endif sl@0: }; sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, sl@0: "option", 0, &optionIndex) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: switch ((enum traceOptions) optionIndex) { sl@0: case TRACE_ADD: sl@0: case TRACE_REMOVE: sl@0: case TRACE_INFO: { sl@0: /* sl@0: * All sub commands of trace add/remove must take at least sl@0: * one more argument. Beyond that we let the subcommand itself sl@0: * control the argument structure. sl@0: */ sl@0: int typeIndex; sl@0: if (objc < 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, sl@0: "option", 0, &typeIndex) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); sl@0: } sl@0: #ifndef TCL_REMOVE_OBSOLETE_TRACES sl@0: case TRACE_OLD_VARIABLE: sl@0: case TRACE_OLD_VDELETE: { sl@0: Tcl_Obj *copyObjv[6]; sl@0: Tcl_Obj *opsList; sl@0: int code, numFlags; sl@0: sl@0: if (objc != 5) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: opsList = Tcl_NewObj(); sl@0: Tcl_IncrRefCount(opsList); sl@0: flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); sl@0: if (numFlags == 0) { sl@0: Tcl_DecrRefCount(opsList); sl@0: goto badVarOps; sl@0: } sl@0: for (p = flagOps; *p != 0; p++) { sl@0: if (*p == 'r') { sl@0: Tcl_ListObjAppendElement(NULL, opsList, sl@0: Tcl_NewStringObj("read", -1)); sl@0: } else if (*p == 'w') { sl@0: Tcl_ListObjAppendElement(NULL, opsList, sl@0: Tcl_NewStringObj("write", -1)); sl@0: } else if (*p == 'u') { sl@0: Tcl_ListObjAppendElement(NULL, opsList, sl@0: Tcl_NewStringObj("unset", -1)); sl@0: } else if (*p == 'a') { sl@0: Tcl_ListObjAppendElement(NULL, opsList, sl@0: Tcl_NewStringObj("array", -1)); sl@0: } else { sl@0: Tcl_DecrRefCount(opsList); sl@0: goto badVarOps; sl@0: } sl@0: } sl@0: copyObjv[0] = NULL; sl@0: memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *)); sl@0: copyObjv[4] = opsList; sl@0: if (optionIndex == TRACE_OLD_VARIABLE) { sl@0: code = (traceSubCmds[2])(interp,TRACE_ADD,objc+1,copyObjv); sl@0: } else { sl@0: code = (traceSubCmds[2])(interp,TRACE_REMOVE,objc+1,copyObjv); sl@0: } sl@0: Tcl_DecrRefCount(opsList); sl@0: return code; sl@0: } sl@0: case TRACE_OLD_VINFO: { sl@0: ClientData clientData; sl@0: char ops[5]; sl@0: Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "name"); sl@0: return TCL_ERROR; sl@0: } sl@0: resultListPtr = Tcl_GetObjResult(interp); sl@0: clientData = 0; sl@0: name = Tcl_GetString(objv[2]); sl@0: while ((clientData = Tcl_VarTraceInfo(interp, name, 0, sl@0: TraceVarProc, clientData)) != 0) { sl@0: sl@0: TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; sl@0: sl@0: pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: p = ops; sl@0: if (tvarPtr->flags & TCL_TRACE_READS) { sl@0: *p = 'r'; sl@0: p++; sl@0: } sl@0: if (tvarPtr->flags & TCL_TRACE_WRITES) { sl@0: *p = 'w'; sl@0: p++; sl@0: } sl@0: if (tvarPtr->flags & TCL_TRACE_UNSETS) { sl@0: *p = 'u'; sl@0: p++; sl@0: } sl@0: if (tvarPtr->flags & TCL_TRACE_ARRAY) { sl@0: *p = 'a'; sl@0: p++; sl@0: } sl@0: *p = '\0'; sl@0: sl@0: /* sl@0: * Build a pair (2-item list) with the ops string as sl@0: * the first obj element and the tvarPtr->command string sl@0: * as the second obj element. Append the pair (as an sl@0: * element) to the end of the result object list. sl@0: */ sl@0: sl@0: elemObjPtr = Tcl_NewStringObj(ops, -1); sl@0: Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); sl@0: elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); sl@0: Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); sl@0: Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr); sl@0: } sl@0: Tcl_SetObjResult(interp, resultListPtr); sl@0: break; sl@0: } sl@0: #endif /* TCL_REMOVE_OBSOLETE_TRACES */ sl@0: } sl@0: return TCL_OK; sl@0: sl@0: badVarOps: sl@0: Tcl_AppendResult(interp, "bad operations \"", flagOps, sl@0: "\": should be one or more of rwua", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclTraceExecutionObjCmd -- sl@0: * sl@0: * Helper function for Tcl_TraceObjCmd; implements the sl@0: * [trace {add|remove|info} execution ...] subcommands. sl@0: * See the user documentation for details on what these do. sl@0: * sl@0: * Results: sl@0: * Standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Depends on the operation (add, remove, or info) being performed; sl@0: * may add or remove command traces on a command. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int optionIndex; /* Add, info or remove */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int commandLength, index; sl@0: char *name, *command; sl@0: size_t length; sl@0: enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; sl@0: static CONST char *opStrings[] = { "enter", "leave", sl@0: "enterstep", "leavestep", (char *) NULL }; sl@0: enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE, sl@0: TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP }; sl@0: sl@0: switch ((enum traceOptions) optionIndex) { sl@0: case TRACE_ADD: sl@0: case TRACE_REMOVE: { sl@0: int flags = 0; sl@0: int i, listLen, result; sl@0: Tcl_Obj **elemPtrs; sl@0: if (objc != 6) { sl@0: Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); sl@0: return TCL_ERROR; sl@0: } sl@0: /* sl@0: * Make sure the ops argument is a list object; get its length and sl@0: * a pointer to its array of element pointers. sl@0: */ sl@0: sl@0: result = Tcl_ListObjGetElements(interp, objv[4], &listLen, sl@0: &elemPtrs); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: if (listLen == 0) { sl@0: Tcl_SetResult(interp, "bad operation list \"\": must be " sl@0: "one or more of enter, leave, enterstep, or leavestep", sl@0: TCL_STATIC); sl@0: return TCL_ERROR; sl@0: } sl@0: for (i = 0; i < listLen; i++) { sl@0: if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, sl@0: "operation", TCL_EXACT, &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: switch ((enum operations) index) { sl@0: case TRACE_EXEC_ENTER: sl@0: flags |= TCL_TRACE_ENTER_EXEC; sl@0: break; sl@0: case TRACE_EXEC_LEAVE: sl@0: flags |= TCL_TRACE_LEAVE_EXEC; sl@0: break; sl@0: case TRACE_EXEC_ENTER_STEP: sl@0: flags |= TCL_TRACE_ENTER_DURING_EXEC; sl@0: break; sl@0: case TRACE_EXEC_LEAVE_STEP: sl@0: flags |= TCL_TRACE_LEAVE_DURING_EXEC; sl@0: break; sl@0: } sl@0: } sl@0: command = Tcl_GetStringFromObj(objv[5], &commandLength); sl@0: length = (size_t) commandLength; sl@0: if ((enum traceOptions) optionIndex == TRACE_ADD) { sl@0: TraceCommandInfo *tcmdPtr; sl@0: tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) sl@0: (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) sl@0: + length + 1)); sl@0: tcmdPtr->flags = flags; sl@0: tcmdPtr->stepTrace = NULL; sl@0: tcmdPtr->startLevel = 0; sl@0: tcmdPtr->startCmd = NULL; sl@0: tcmdPtr->length = length; sl@0: tcmdPtr->refCount = 1; sl@0: flags |= TCL_TRACE_DELETE; sl@0: if (flags & (TCL_TRACE_ENTER_DURING_EXEC | sl@0: TCL_TRACE_LEAVE_DURING_EXEC)) { sl@0: flags |= (TCL_TRACE_ENTER_EXEC | sl@0: TCL_TRACE_LEAVE_EXEC); sl@0: } sl@0: strcpy(tcmdPtr->command, command); sl@0: name = Tcl_GetString(objv[3]); sl@0: if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, sl@0: (ClientData) tcmdPtr) != TCL_OK) { sl@0: ckfree((char *) tcmdPtr); sl@0: return TCL_ERROR; sl@0: } sl@0: } else { sl@0: /* sl@0: * Search through all of our traces on this command to sl@0: * see if there's one with the given command. If so, then sl@0: * delete the first one that matches. sl@0: */ sl@0: sl@0: TraceCommandInfo *tcmdPtr; sl@0: ClientData clientData = NULL; sl@0: name = Tcl_GetString(objv[3]); sl@0: sl@0: /* First ensure the name given is valid */ sl@0: if (Tcl_FindCommand(interp, name, NULL, sl@0: TCL_LEAVE_ERR_MSG) == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, sl@0: TraceCommandProc, clientData)) != NULL) { sl@0: tcmdPtr = (TraceCommandInfo *) clientData; sl@0: /* sl@0: * In checking the 'flags' field we must remove any sl@0: * extraneous flags which may have been temporarily sl@0: * added by various pieces of the trace mechanism. sl@0: */ sl@0: if ((tcmdPtr->length == length) sl@0: && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | sl@0: TCL_TRACE_RENAME | sl@0: TCL_TRACE_DELETE)) == flags) sl@0: && (strncmp(command, tcmdPtr->command, sl@0: (size_t) length) == 0)) { sl@0: flags |= TCL_TRACE_DELETE; sl@0: if (flags & (TCL_TRACE_ENTER_DURING_EXEC | sl@0: TCL_TRACE_LEAVE_DURING_EXEC)) { sl@0: flags |= (TCL_TRACE_ENTER_EXEC | sl@0: TCL_TRACE_LEAVE_EXEC); sl@0: } sl@0: Tcl_UntraceCommand(interp, name, sl@0: flags, TraceCommandProc, clientData); sl@0: if (tcmdPtr->stepTrace != NULL) { sl@0: /* sl@0: * We need to remove the interpreter-wide trace sl@0: * which we created to allow 'step' traces. sl@0: */ sl@0: Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); sl@0: tcmdPtr->stepTrace = NULL; sl@0: if (tcmdPtr->startCmd != NULL) { sl@0: ckfree((char *)tcmdPtr->startCmd); sl@0: } sl@0: } sl@0: if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { sl@0: /* Postpone deletion */ sl@0: tcmdPtr->flags = 0; sl@0: } sl@0: tcmdPtr->refCount--; sl@0: if (tcmdPtr->refCount < 0) { sl@0: Tcl_Panic("TclTraceExecutionObjCmd: negative TraceCommandInfo refCount"); sl@0: } sl@0: if (tcmdPtr->refCount == 0) { sl@0: ckfree((char*)tcmdPtr); sl@0: } sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: break; sl@0: } sl@0: case TRACE_INFO: { sl@0: ClientData clientData; sl@0: Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 3, objv, "name"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: clientData = NULL; sl@0: name = Tcl_GetString(objv[3]); sl@0: sl@0: /* First ensure the name given is valid */ sl@0: if (Tcl_FindCommand(interp, name, NULL, sl@0: TCL_LEAVE_ERR_MSG) == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, sl@0: TraceCommandProc, clientData)) != NULL) { sl@0: int numOps = 0; sl@0: sl@0: TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; sl@0: sl@0: /* sl@0: * Build a list with the ops list as the first obj sl@0: * element and the tcmdPtr->command string as the sl@0: * second obj element. Append this list (as an sl@0: * element) to the end of the result object list. sl@0: */ sl@0: sl@0: elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: Tcl_IncrRefCount(elemObjPtr); sl@0: if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) { sl@0: Tcl_ListObjAppendElement(NULL, elemObjPtr, sl@0: Tcl_NewStringObj("enter",5)); sl@0: } sl@0: if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) { sl@0: Tcl_ListObjAppendElement(NULL, elemObjPtr, sl@0: Tcl_NewStringObj("leave",5)); sl@0: } sl@0: if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) { sl@0: Tcl_ListObjAppendElement(NULL, elemObjPtr, sl@0: Tcl_NewStringObj("enterstep",9)); sl@0: } sl@0: if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) { sl@0: Tcl_ListObjAppendElement(NULL, elemObjPtr, sl@0: Tcl_NewStringObj("leavestep",9)); sl@0: } sl@0: Tcl_ListObjLength(NULL, elemObjPtr, &numOps); sl@0: if (0 == numOps) { sl@0: Tcl_DecrRefCount(elemObjPtr); sl@0: continue; sl@0: } sl@0: eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); sl@0: Tcl_DecrRefCount(elemObjPtr); sl@0: elemObjPtr = NULL; sl@0: sl@0: Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, sl@0: Tcl_NewStringObj(tcmdPtr->command, -1)); sl@0: Tcl_ListObjAppendElement(interp, resultListPtr, sl@0: eachTraceObjPtr); sl@0: } sl@0: Tcl_SetObjResult(interp, resultListPtr); sl@0: break; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclTraceCommandObjCmd -- sl@0: * sl@0: * Helper function for Tcl_TraceObjCmd; implements the sl@0: * [trace {add|info|remove} command ...] subcommands. sl@0: * See the user documentation for details on what these do. sl@0: * sl@0: * Results: sl@0: * Standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Depends on the operation (add, remove, or info) being performed; sl@0: * may add or remove command traces on a command. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclTraceCommandObjCmd(interp, optionIndex, objc, objv) sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int optionIndex; /* Add, info or remove */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int commandLength, index; sl@0: char *name, *command; sl@0: size_t length; sl@0: enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; sl@0: static CONST char *opStrings[] = { "delete", "rename", (char *) NULL }; sl@0: enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; sl@0: sl@0: switch ((enum traceOptions) optionIndex) { sl@0: case TRACE_ADD: sl@0: case TRACE_REMOVE: { sl@0: int flags = 0; sl@0: int i, listLen, result; sl@0: Tcl_Obj **elemPtrs; sl@0: if (objc != 6) { sl@0: Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); sl@0: return TCL_ERROR; sl@0: } sl@0: /* sl@0: * Make sure the ops argument is a list object; get its length and sl@0: * a pointer to its array of element pointers. sl@0: */ sl@0: sl@0: result = Tcl_ListObjGetElements(interp, objv[4], &listLen, sl@0: &elemPtrs); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: if (listLen == 0) { sl@0: Tcl_SetResult(interp, "bad operation list \"\": must be " sl@0: "one or more of delete or rename", TCL_STATIC); sl@0: return TCL_ERROR; sl@0: } sl@0: for (i = 0; i < listLen; i++) { sl@0: if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, sl@0: "operation", TCL_EXACT, &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: switch ((enum operations) index) { sl@0: case TRACE_CMD_RENAME: sl@0: flags |= TCL_TRACE_RENAME; sl@0: break; sl@0: case TRACE_CMD_DELETE: sl@0: flags |= TCL_TRACE_DELETE; sl@0: break; sl@0: } sl@0: } sl@0: command = Tcl_GetStringFromObj(objv[5], &commandLength); sl@0: length = (size_t) commandLength; sl@0: if ((enum traceOptions) optionIndex == TRACE_ADD) { sl@0: TraceCommandInfo *tcmdPtr; sl@0: tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) sl@0: (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) sl@0: + length + 1)); sl@0: tcmdPtr->flags = flags; sl@0: tcmdPtr->stepTrace = NULL; sl@0: tcmdPtr->startLevel = 0; sl@0: tcmdPtr->startCmd = NULL; sl@0: tcmdPtr->length = length; sl@0: tcmdPtr->refCount = 1; sl@0: flags |= TCL_TRACE_DELETE; sl@0: strcpy(tcmdPtr->command, command); sl@0: name = Tcl_GetString(objv[3]); sl@0: if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, sl@0: (ClientData) tcmdPtr) != TCL_OK) { sl@0: ckfree((char *) tcmdPtr); sl@0: return TCL_ERROR; sl@0: } sl@0: } else { sl@0: /* sl@0: * Search through all of our traces on this command to sl@0: * see if there's one with the given command. If so, then sl@0: * delete the first one that matches. sl@0: */ sl@0: sl@0: TraceCommandInfo *tcmdPtr; sl@0: ClientData clientData = NULL; sl@0: name = Tcl_GetString(objv[3]); sl@0: sl@0: /* First ensure the name given is valid */ sl@0: if (Tcl_FindCommand(interp, name, NULL, sl@0: TCL_LEAVE_ERR_MSG) == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, sl@0: TraceCommandProc, clientData)) != NULL) { sl@0: tcmdPtr = (TraceCommandInfo *) clientData; sl@0: if ((tcmdPtr->length == length) sl@0: && (tcmdPtr->flags == flags) sl@0: && (strncmp(command, tcmdPtr->command, sl@0: (size_t) length) == 0)) { sl@0: Tcl_UntraceCommand(interp, name, sl@0: flags | TCL_TRACE_DELETE, sl@0: TraceCommandProc, clientData); sl@0: tcmdPtr->flags |= TCL_TRACE_DESTROYED; sl@0: tcmdPtr->refCount--; sl@0: if (tcmdPtr->refCount < 0) { sl@0: Tcl_Panic("TclTraceCommandObjCmd: negative TraceCommandInfo refCount"); sl@0: } sl@0: if (tcmdPtr->refCount == 0) { sl@0: ckfree((char *) tcmdPtr); sl@0: } sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: break; sl@0: } sl@0: case TRACE_INFO: { sl@0: ClientData clientData; sl@0: Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 3, objv, "name"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: clientData = NULL; sl@0: name = Tcl_GetString(objv[3]); sl@0: sl@0: /* First ensure the name given is valid */ sl@0: if (Tcl_FindCommand(interp, name, NULL, sl@0: TCL_LEAVE_ERR_MSG) == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, sl@0: TraceCommandProc, clientData)) != NULL) { sl@0: int numOps = 0; sl@0: sl@0: TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; sl@0: sl@0: /* sl@0: * Build a list with the ops list as sl@0: * the first obj element and the tcmdPtr->command string sl@0: * as the second obj element. Append this list (as an sl@0: * element) to the end of the result object list. sl@0: */ sl@0: sl@0: elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: Tcl_IncrRefCount(elemObjPtr); sl@0: if (tcmdPtr->flags & TCL_TRACE_RENAME) { sl@0: Tcl_ListObjAppendElement(NULL, elemObjPtr, sl@0: Tcl_NewStringObj("rename",6)); sl@0: } sl@0: if (tcmdPtr->flags & TCL_TRACE_DELETE) { sl@0: Tcl_ListObjAppendElement(NULL, elemObjPtr, sl@0: Tcl_NewStringObj("delete",6)); sl@0: } sl@0: Tcl_ListObjLength(NULL, elemObjPtr, &numOps); sl@0: if (0 == numOps) { sl@0: Tcl_DecrRefCount(elemObjPtr); sl@0: continue; sl@0: } sl@0: eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); sl@0: Tcl_DecrRefCount(elemObjPtr); sl@0: sl@0: elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); sl@0: Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); sl@0: Tcl_ListObjAppendElement(interp, resultListPtr, sl@0: eachTraceObjPtr); sl@0: } sl@0: Tcl_SetObjResult(interp, resultListPtr); sl@0: break; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclTraceVariableObjCmd -- sl@0: * sl@0: * Helper function for Tcl_TraceObjCmd; implements the sl@0: * [trace {add|info|remove} variable ...] subcommands. sl@0: * See the user documentation for details on what these do. sl@0: * sl@0: * Results: sl@0: * Standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Depends on the operation (add, remove, or info) being performed; sl@0: * may add or remove variable traces on a variable. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclTraceVariableObjCmd(interp, optionIndex, objc, objv) sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int optionIndex; /* Add, info or remove */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int commandLength, index; sl@0: char *name, *command; sl@0: size_t length; sl@0: enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; sl@0: static CONST char *opStrings[] = { "array", "read", "unset", "write", sl@0: (char *) NULL }; sl@0: enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, sl@0: TRACE_VAR_WRITE }; sl@0: sl@0: switch ((enum traceOptions) optionIndex) { sl@0: case TRACE_ADD: sl@0: case TRACE_REMOVE: { sl@0: int flags = 0; sl@0: int i, listLen, result; sl@0: Tcl_Obj **elemPtrs; sl@0: if (objc != 6) { sl@0: Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); sl@0: return TCL_ERROR; sl@0: } sl@0: /* sl@0: * Make sure the ops argument is a list object; get its length and sl@0: * a pointer to its array of element pointers. sl@0: */ sl@0: sl@0: result = Tcl_ListObjGetElements(interp, objv[4], &listLen, sl@0: &elemPtrs); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: if (listLen == 0) { sl@0: Tcl_SetResult(interp, "bad operation list \"\": must be " sl@0: "one or more of array, read, unset, or write", sl@0: TCL_STATIC); sl@0: return TCL_ERROR; sl@0: } sl@0: for (i = 0; i < listLen ; i++) { sl@0: if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, sl@0: "operation", TCL_EXACT, &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: switch ((enum operations) index) { sl@0: case TRACE_VAR_ARRAY: sl@0: flags |= TCL_TRACE_ARRAY; sl@0: break; sl@0: case TRACE_VAR_READ: sl@0: flags |= TCL_TRACE_READS; sl@0: break; sl@0: case TRACE_VAR_UNSET: sl@0: flags |= TCL_TRACE_UNSETS; sl@0: break; sl@0: case TRACE_VAR_WRITE: sl@0: flags |= TCL_TRACE_WRITES; sl@0: break; sl@0: } sl@0: } sl@0: command = Tcl_GetStringFromObj(objv[5], &commandLength); sl@0: length = (size_t) commandLength; sl@0: if ((enum traceOptions) optionIndex == TRACE_ADD) { sl@0: /* sl@0: * This code essentially mallocs together the VarTrace and the sl@0: * TraceVarInfo, then inlines the Tcl_TraceVar(). This is sl@0: * necessary in order to have the TraceVarInfo to be freed sl@0: * automatically when the VarTrace is freed [Bug 1348775] sl@0: */ sl@0: sl@0: CompoundVarTrace *compTracePtr; sl@0: TraceVarInfo *tvarPtr; sl@0: Var *varPtr, *arrayPtr; sl@0: VarTrace *tracePtr; sl@0: int flagMask; sl@0: sl@0: compTracePtr = (CompoundVarTrace *) ckalloc((unsigned) sl@0: (sizeof(CompoundVarTrace) - sizeof(tvarPtr->command) sl@0: + length + 1)); sl@0: tracePtr = &(compTracePtr->trace); sl@0: tvarPtr = &(compTracePtr->tvar); sl@0: tvarPtr->flags = flags; sl@0: if (objv[0] == NULL) { sl@0: tvarPtr->flags |= TCL_TRACE_OLD_STYLE; sl@0: } sl@0: tvarPtr->length = length; sl@0: flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; sl@0: strcpy(tvarPtr->command, command); sl@0: name = Tcl_GetString(objv[3]); sl@0: flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; sl@0: varPtr = TclLookupVar(interp, name, NULL, sl@0: (flags & flagMask) | TCL_LEAVE_ERR_MSG, "trace", sl@0: /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); sl@0: if (varPtr == NULL) { sl@0: ckfree((char *) tracePtr); sl@0: return TCL_ERROR; sl@0: } sl@0: flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES sl@0: | TCL_TRACE_UNSETS | TCL_TRACE_ARRAY sl@0: | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; sl@0: #ifndef TCL_REMOVE_OBSOLETE_TRACES sl@0: flagMask |= TCL_TRACE_OLD_STYLE; sl@0: #endif sl@0: tracePtr->traceProc = TraceVarProc; sl@0: tracePtr->clientData = (ClientData) tvarPtr; sl@0: tracePtr->flags = flags & flagMask; sl@0: tracePtr->nextPtr = varPtr->tracePtr; sl@0: varPtr->tracePtr = tracePtr; sl@0: } else { sl@0: /* sl@0: * Search through all of our traces on this variable to sl@0: * see if there's one with the given command. If so, then sl@0: * delete the first one that matches. sl@0: */ sl@0: sl@0: TraceVarInfo *tvarPtr; sl@0: ClientData clientData = 0; sl@0: name = Tcl_GetString(objv[3]); sl@0: while ((clientData = Tcl_VarTraceInfo(interp, name, 0, sl@0: TraceVarProc, clientData)) != 0) { sl@0: tvarPtr = (TraceVarInfo *) clientData; sl@0: if ((tvarPtr->length == length) sl@0: && ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags) sl@0: && (strncmp(command, tvarPtr->command, sl@0: (size_t) length) == 0)) { sl@0: Tcl_UntraceVar2(interp, name, NULL, sl@0: flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, sl@0: TraceVarProc, clientData); sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: break; sl@0: } sl@0: case TRACE_INFO: { sl@0: ClientData clientData; sl@0: Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 3, objv, "name"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: resultListPtr = Tcl_GetObjResult(interp); sl@0: clientData = 0; sl@0: name = Tcl_GetString(objv[3]); sl@0: while ((clientData = Tcl_VarTraceInfo(interp, name, 0, sl@0: TraceVarProc, clientData)) != 0) { sl@0: sl@0: TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; sl@0: sl@0: /* sl@0: * Build a list with the ops list as sl@0: * the first obj element and the tcmdPtr->command string sl@0: * as the second obj element. Append this list (as an sl@0: * element) to the end of the result object list. sl@0: */ sl@0: sl@0: elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: if (tvarPtr->flags & TCL_TRACE_ARRAY) { sl@0: Tcl_ListObjAppendElement(NULL, elemObjPtr, sl@0: Tcl_NewStringObj("array", 5)); sl@0: } sl@0: if (tvarPtr->flags & TCL_TRACE_READS) { sl@0: Tcl_ListObjAppendElement(NULL, elemObjPtr, sl@0: Tcl_NewStringObj("read", 4)); sl@0: } sl@0: if (tvarPtr->flags & TCL_TRACE_WRITES) { sl@0: Tcl_ListObjAppendElement(NULL, elemObjPtr, sl@0: Tcl_NewStringObj("write", 5)); sl@0: } sl@0: if (tvarPtr->flags & TCL_TRACE_UNSETS) { sl@0: Tcl_ListObjAppendElement(NULL, elemObjPtr, sl@0: Tcl_NewStringObj("unset", 5)); sl@0: } sl@0: eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); sl@0: Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); sl@0: sl@0: elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); sl@0: Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); sl@0: Tcl_ListObjAppendElement(interp, resultListPtr, sl@0: eachTraceObjPtr); sl@0: } sl@0: Tcl_SetObjResult(interp, resultListPtr); sl@0: break; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_CommandTraceInfo -- sl@0: * sl@0: * Return the clientData value associated with a trace on a sl@0: * command. This procedure can also be used to step through sl@0: * all of the traces on a particular command that have the sl@0: * same trace procedure. sl@0: * sl@0: * Results: sl@0: * The return value is the clientData value associated with sl@0: * a trace on the given command. Information will only be sl@0: * returned for a trace with proc as trace procedure. If sl@0: * the clientData argument is NULL then the first such trace is sl@0: * returned; otherwise, the next relevant one after the one sl@0: * given by clientData will be returned. If the command sl@0: * doesn't exist then an error message is left in the interpreter sl@0: * and NULL is returned. Also, if there are no (more) traces for sl@0: * the given command, NULL is returned. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C ClientData sl@0: Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData) sl@0: Tcl_Interp *interp; /* Interpreter containing command. */ sl@0: CONST char *cmdName; /* Name of command. */ sl@0: int flags; /* OR-ed combo or TCL_GLOBAL_ONLY, sl@0: * TCL_NAMESPACE_ONLY (can be 0). */ sl@0: Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ sl@0: ClientData prevClientData; /* If non-NULL, gives last value returned sl@0: * by this procedure, so this call will sl@0: * return the next trace after that one. sl@0: * If NULL, this call will return the sl@0: * first trace. */ sl@0: { sl@0: Command *cmdPtr; sl@0: register CommandTrace *tracePtr; sl@0: sl@0: cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, sl@0: NULL, TCL_LEAVE_ERR_MSG); sl@0: if (cmdPtr == NULL) { sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: * Find the relevant trace, if any, and return its clientData. sl@0: */ sl@0: sl@0: tracePtr = cmdPtr->tracePtr; sl@0: if (prevClientData != NULL) { sl@0: for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { sl@0: if ((tracePtr->clientData == prevClientData) sl@0: && (tracePtr->traceProc == proc)) { sl@0: tracePtr = tracePtr->nextPtr; sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { sl@0: if (tracePtr->traceProc == proc) { sl@0: return tracePtr->clientData; sl@0: } sl@0: } sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_TraceCommand -- sl@0: * sl@0: * Arrange for rename/deletes to a command to cause a sl@0: * procedure to be invoked, which can monitor the operations. sl@0: * sl@0: * Also optionally arrange for execution of that command sl@0: * to cause a procedure to be invoked. sl@0: * sl@0: * Results: sl@0: * A standard Tcl return value. sl@0: * sl@0: * Side effects: sl@0: * A trace is set up on the command given by cmdName, such that sl@0: * future changes to the command will be intermediated by sl@0: * proc. See the manual entry for complete details on the calling sl@0: * sequence for proc. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_TraceCommand(interp, cmdName, flags, proc, clientData) sl@0: Tcl_Interp *interp; /* Interpreter in which command is sl@0: * to be traced. */ sl@0: CONST char *cmdName; /* Name of command. */ sl@0: int flags; /* OR-ed collection of bits, including any sl@0: * of TCL_TRACE_RENAME, TCL_TRACE_DELETE, sl@0: * and any of the TRACE_*_EXEC flags */ sl@0: Tcl_CommandTraceProc *proc; /* Procedure to call when specified ops are sl@0: * invoked upon varName. */ sl@0: ClientData clientData; /* Arbitrary argument to pass to proc. */ sl@0: { sl@0: Command *cmdPtr; sl@0: register CommandTrace *tracePtr; sl@0: sl@0: cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, sl@0: NULL, TCL_LEAVE_ERR_MSG); sl@0: if (cmdPtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Set up trace information. sl@0: */ sl@0: sl@0: tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace)); sl@0: tracePtr->traceProc = proc; sl@0: tracePtr->clientData = clientData; sl@0: tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE sl@0: | TCL_TRACE_ANY_EXEC); sl@0: tracePtr->nextPtr = cmdPtr->tracePtr; sl@0: tracePtr->refCount = 1; sl@0: cmdPtr->tracePtr = tracePtr; sl@0: if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { sl@0: cmdPtr->flags |= CMD_HAS_EXEC_TRACES; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_UntraceCommand -- sl@0: * sl@0: * Remove a previously-created trace for a command. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * If there exists a trace for the command given by cmdName sl@0: * with the given flags, proc, and clientData, then that trace sl@0: * is removed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) sl@0: Tcl_Interp *interp; /* Interpreter containing command. */ sl@0: CONST char *cmdName; /* Name of command. */ sl@0: int flags; /* OR-ed collection of bits, including any sl@0: * of TCL_TRACE_RENAME, TCL_TRACE_DELETE, sl@0: * and any of the TRACE_*_EXEC flags */ sl@0: Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ sl@0: ClientData clientData; /* Arbitrary argument to pass to proc. */ sl@0: { sl@0: register CommandTrace *tracePtr; sl@0: CommandTrace *prevPtr; sl@0: Command *cmdPtr; sl@0: Interp *iPtr = (Interp *) interp; sl@0: ActiveCommandTrace *activePtr; sl@0: int hasExecTraces = 0; sl@0: sl@0: cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, sl@0: NULL, TCL_LEAVE_ERR_MSG); sl@0: if (cmdPtr == NULL) { sl@0: return; sl@0: } sl@0: sl@0: flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); sl@0: sl@0: for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ; sl@0: prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { sl@0: if (tracePtr == NULL) { sl@0: return; sl@0: } sl@0: if ((tracePtr->traceProc == proc) sl@0: && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | sl@0: TCL_TRACE_ANY_EXEC)) == flags) sl@0: && (tracePtr->clientData == clientData)) { sl@0: if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { sl@0: hasExecTraces = 1; sl@0: } sl@0: break; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * The code below makes it possible to delete traces while traces sl@0: * are active: it makes sure that the deleted trace won't be sl@0: * processed by CallCommandTraces. sl@0: */ sl@0: sl@0: for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL; sl@0: activePtr = activePtr->nextPtr) { sl@0: if (activePtr->nextTracePtr == tracePtr) { sl@0: if (activePtr->reverseScan) { sl@0: activePtr->nextTracePtr = prevPtr; sl@0: } else { sl@0: activePtr->nextTracePtr = tracePtr->nextPtr; sl@0: } sl@0: } sl@0: } sl@0: if (prevPtr == NULL) { sl@0: cmdPtr->tracePtr = tracePtr->nextPtr; sl@0: } else { sl@0: prevPtr->nextPtr = tracePtr->nextPtr; sl@0: } sl@0: tracePtr->flags = 0; sl@0: sl@0: if ((--tracePtr->refCount) <= 0) { sl@0: ckfree((char*)tracePtr); sl@0: } sl@0: sl@0: if (hasExecTraces) { sl@0: for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ; sl@0: prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { sl@0: if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { sl@0: return; sl@0: } sl@0: } sl@0: /* sl@0: * None of the remaining traces on this command are execution sl@0: * traces. We therefore remove this flag: sl@0: */ sl@0: cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TraceCommandProc -- sl@0: * sl@0: * This procedure is called to handle command changes that have sl@0: * been traced using the "trace" command, when using the sl@0: * 'rename' or 'delete' options. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Depends on the command associated with the trace. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static void sl@0: TraceCommandProc(clientData, interp, oldName, newName, flags) sl@0: ClientData clientData; /* Information about the command trace. */ sl@0: Tcl_Interp *interp; /* Interpreter containing command. */ sl@0: CONST char *oldName; /* Name of command being changed. */ sl@0: CONST char *newName; /* New name of command. Empty string sl@0: * or NULL means command is being deleted sl@0: * (renamed to ""). */ sl@0: int flags; /* OR-ed bits giving operation and other sl@0: * information. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: int stateCode; sl@0: Tcl_SavedResult state; sl@0: TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; sl@0: int code; sl@0: Tcl_DString cmd; sl@0: sl@0: tcmdPtr->refCount++; sl@0: sl@0: if ((tcmdPtr->flags & flags) && !Tcl_InterpDeleted(interp)) { sl@0: /* sl@0: * Generate a command to execute by appending list elements sl@0: * for the old and new command name and the operation. sl@0: */ sl@0: sl@0: Tcl_DStringInit(&cmd); sl@0: Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); sl@0: Tcl_DStringAppendElement(&cmd, oldName); sl@0: Tcl_DStringAppendElement(&cmd, (newName ? newName : "")); sl@0: if (flags & TCL_TRACE_RENAME) { sl@0: Tcl_DStringAppend(&cmd, " rename", 7); sl@0: } else if (flags & TCL_TRACE_DELETE) { sl@0: Tcl_DStringAppend(&cmd, " delete", 7); sl@0: } sl@0: sl@0: /* sl@0: * Execute the command. Save the interp's result used for the sl@0: * command, including the value of iPtr->returnCode which may be sl@0: * modified when Tcl_Eval is invoked. We discard any object sl@0: * result the command returns. sl@0: * sl@0: * Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to sl@0: * other areas that this will be destroyed by us, otherwise a sl@0: * double-free might occur depending on what the eval does. sl@0: */ sl@0: sl@0: Tcl_SaveResult(interp, &state); sl@0: stateCode = iPtr->returnCode; sl@0: if (flags & TCL_TRACE_DESTROYED) { sl@0: tcmdPtr->flags |= TCL_TRACE_DESTROYED; sl@0: } sl@0: sl@0: code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), sl@0: Tcl_DStringLength(&cmd), 0); sl@0: if (code != TCL_OK) { sl@0: /* We ignore errors in these traced commands */ sl@0: } sl@0: sl@0: Tcl_RestoreResult(interp, &state); sl@0: iPtr->returnCode = stateCode; sl@0: sl@0: Tcl_DStringFree(&cmd); sl@0: } sl@0: /* sl@0: * We delete when the trace was destroyed or if this is a delete trace, sl@0: * because command deletes are unconditional, so the trace must go away. sl@0: */ sl@0: if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) { sl@0: int untraceFlags = tcmdPtr->flags; sl@0: sl@0: if (tcmdPtr->stepTrace != NULL) { sl@0: Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); sl@0: tcmdPtr->stepTrace = NULL; sl@0: if (tcmdPtr->startCmd != NULL) { sl@0: ckfree((char *)tcmdPtr->startCmd); sl@0: } sl@0: } sl@0: if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { sl@0: /* Postpone deletion, until exec trace returns */ sl@0: tcmdPtr->flags = 0; sl@0: } sl@0: sl@0: /* sl@0: * We need to construct the same flags for Tcl_UntraceCommand sl@0: * as were passed to Tcl_TraceCommand. Reproduce the processing sl@0: * of [trace add execution/command]. Be careful to keep this sl@0: * code in sync with that. sl@0: */ sl@0: sl@0: if (untraceFlags & TCL_TRACE_ANY_EXEC) { sl@0: untraceFlags |= TCL_TRACE_DELETE; sl@0: if (untraceFlags & (TCL_TRACE_ENTER_DURING_EXEC sl@0: | TCL_TRACE_LEAVE_DURING_EXEC)) { sl@0: untraceFlags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); sl@0: } sl@0: } else if (untraceFlags & TCL_TRACE_RENAME) { sl@0: untraceFlags |= TCL_TRACE_DELETE; sl@0: } sl@0: sl@0: /* sl@0: * Remove the trace since TCL_TRACE_DESTROYED tells us to, or the sl@0: * command we're tracing has just gone away. Then decrement the sl@0: * clientData refCount that was set up by trace creation. sl@0: * sl@0: * Note that we save the (return) state of the interpreter to prevent sl@0: * bizarre error messages. sl@0: */ sl@0: sl@0: Tcl_SaveResult(interp, &state); sl@0: stateCode = iPtr->returnCode; sl@0: Tcl_UntraceCommand(interp, oldName, untraceFlags, sl@0: TraceCommandProc, clientData); sl@0: Tcl_RestoreResult(interp, &state); sl@0: iPtr->returnCode = stateCode; sl@0: sl@0: tcmdPtr->refCount--; sl@0: } sl@0: tcmdPtr->refCount--; sl@0: if (tcmdPtr->refCount < 0) { sl@0: Tcl_Panic("TraceCommandProc: negative TraceCommandInfo refCount"); sl@0: } sl@0: if (tcmdPtr->refCount == 0) { sl@0: ckfree((char*)tcmdPtr); sl@0: } sl@0: return; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclCheckExecutionTraces -- sl@0: * sl@0: * Checks on all current command execution traces, and invokes sl@0: * procedures which have been registered. This procedure can be sl@0: * used by other code which performs execution to unify the sl@0: * tracing system, so that execution traces will function for that sl@0: * other code. sl@0: * sl@0: * For instance extensions like [incr Tcl] which use their sl@0: * own execution technique can make use of Tcl's tracing. sl@0: * sl@0: * This procedure is called by 'TclEvalObjvInternal' sl@0: * sl@0: * Results: sl@0: * The return value is a standard Tcl completion code such as sl@0: * TCL_OK or TCL_ERROR, etc. sl@0: * sl@0: * Side effects: sl@0: * Those side effects made by any trace procedures called. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: int sl@0: TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, sl@0: traceFlags, objc, objv) sl@0: Tcl_Interp *interp; /* The current interpreter. */ sl@0: CONST char *command; /* Pointer to beginning of the current sl@0: * command string. */ sl@0: int numChars; /* The number of characters in 'command' sl@0: * which are part of the command string. */ sl@0: Command *cmdPtr; /* Points to command's Command struct. */ sl@0: int code; /* The current result code. */ sl@0: int traceFlags; /* Current tracing situation. */ sl@0: int objc; /* Number of arguments for the command. */ sl@0: Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: CommandTrace *tracePtr, *lastTracePtr; sl@0: ActiveCommandTrace active; sl@0: int curLevel; sl@0: int traceCode = TCL_OK; sl@0: TraceCommandInfo* tcmdPtr; sl@0: sl@0: if (command == NULL || cmdPtr->tracePtr == NULL) { sl@0: return traceCode; sl@0: } sl@0: sl@0: curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level); sl@0: sl@0: active.nextPtr = iPtr->activeCmdTracePtr; sl@0: iPtr->activeCmdTracePtr = &active; sl@0: sl@0: active.cmdPtr = cmdPtr; sl@0: lastTracePtr = NULL; sl@0: for (tracePtr = cmdPtr->tracePtr; sl@0: (traceCode == TCL_OK) && (tracePtr != NULL); sl@0: tracePtr = active.nextTracePtr) { sl@0: if (traceFlags & TCL_TRACE_LEAVE_EXEC) { sl@0: /* execute the trace command in order of creation for "leave" */ sl@0: active.reverseScan = 1; sl@0: active.nextTracePtr = NULL; sl@0: tracePtr = cmdPtr->tracePtr; sl@0: while (tracePtr->nextPtr != lastTracePtr) { sl@0: active.nextTracePtr = tracePtr; sl@0: tracePtr = tracePtr->nextPtr; sl@0: } sl@0: } else { sl@0: active.reverseScan = 0; sl@0: active.nextTracePtr = tracePtr->nextPtr; sl@0: } sl@0: if (tracePtr->traceProc == TraceCommandProc) { sl@0: tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; sl@0: if (tcmdPtr->flags != 0) { sl@0: tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; sl@0: tcmdPtr->curCode = code; sl@0: tcmdPtr->refCount++; sl@0: traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, sl@0: curLevel, command, (Tcl_Command)cmdPtr, objc, objv); sl@0: tcmdPtr->refCount--; sl@0: if (tcmdPtr->refCount < 0) { sl@0: Tcl_Panic("TclCheckExecutionTraces: negative TraceCommandInfo refCount"); sl@0: } sl@0: if (tcmdPtr->refCount == 0) { sl@0: ckfree((char*)tcmdPtr); sl@0: } sl@0: } sl@0: } sl@0: if (active.nextTracePtr) { sl@0: lastTracePtr = active.nextTracePtr->nextPtr; sl@0: } sl@0: } sl@0: iPtr->activeCmdTracePtr = active.nextPtr; sl@0: return(traceCode); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclCheckInterpTraces -- sl@0: * sl@0: * Checks on all current traces, and invokes procedures which sl@0: * have been registered. This procedure can be used by other sl@0: * code which performs execution to unify the tracing system. sl@0: * For instance extensions like [incr Tcl] which use their sl@0: * own execution technique can make use of Tcl's tracing. sl@0: * sl@0: * This procedure is called by 'TclEvalObjvInternal' sl@0: * sl@0: * Results: sl@0: * The return value is a standard Tcl completion code such as sl@0: * TCL_OK or TCL_ERROR, etc. sl@0: * sl@0: * Side effects: sl@0: * Those side effects made by any trace procedures called. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: int sl@0: TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, sl@0: traceFlags, objc, objv) sl@0: Tcl_Interp *interp; /* The current interpreter. */ sl@0: CONST char *command; /* Pointer to beginning of the current sl@0: * command string. */ sl@0: int numChars; /* The number of characters in 'command' sl@0: * which are part of the command string. */ sl@0: Command *cmdPtr; /* Points to command's Command struct. */ sl@0: int code; /* The current result code. */ sl@0: int traceFlags; /* Current tracing situation. */ sl@0: int objc; /* Number of arguments for the command. */ sl@0: Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Trace *tracePtr, *lastTracePtr; sl@0: ActiveInterpTrace active; sl@0: int curLevel; sl@0: int traceCode = TCL_OK; sl@0: sl@0: if (command == NULL || iPtr->tracePtr == NULL || sl@0: (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) { sl@0: return(traceCode); sl@0: } sl@0: sl@0: curLevel = iPtr->numLevels; sl@0: sl@0: active.nextPtr = iPtr->activeInterpTracePtr; sl@0: iPtr->activeInterpTracePtr = &active; sl@0: sl@0: lastTracePtr = NULL; sl@0: for ( tracePtr = iPtr->tracePtr; sl@0: (traceCode == TCL_OK) && (tracePtr != NULL); sl@0: tracePtr = active.nextTracePtr) { sl@0: if (traceFlags & TCL_TRACE_ENTER_EXEC) { sl@0: /* sl@0: * Execute the trace command in reverse order of creation sl@0: * for "enterstep" operation. The order is changed for sl@0: * "enterstep" instead of for "leavestep" as was done in sl@0: * TclCheckExecutionTraces because for step traces, sl@0: * Tcl_CreateObjTrace creates one more linked list of traces sl@0: * which results in one more reversal of trace invocation. sl@0: */ sl@0: active.reverseScan = 1; sl@0: active.nextTracePtr = NULL; sl@0: tracePtr = iPtr->tracePtr; sl@0: while (tracePtr->nextPtr != lastTracePtr) { sl@0: active.nextTracePtr = tracePtr; sl@0: tracePtr = tracePtr->nextPtr; sl@0: } sl@0: } else { sl@0: active.reverseScan = 0; sl@0: active.nextTracePtr = tracePtr->nextPtr; sl@0: } sl@0: if (tracePtr->level > 0 && curLevel > tracePtr->level) { sl@0: continue; sl@0: } sl@0: if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) { sl@0: /* sl@0: * The proc invoked might delete the traced command which sl@0: * which might try to free tracePtr. We want to use tracePtr sl@0: * until the end of this if section, so we use sl@0: * Tcl_Preserve() and Tcl_Release() to be sure it is not sl@0: * freed while we still need it. sl@0: */ sl@0: Tcl_Preserve((ClientData) tracePtr); sl@0: tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; sl@0: sl@0: if (tracePtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) { sl@0: /* New style trace */ sl@0: if (tracePtr->flags & traceFlags) { sl@0: if (tracePtr->proc == TraceExecutionProc) { sl@0: TraceCommandInfo *tcmdPtr = sl@0: (TraceCommandInfo *) tracePtr->clientData; sl@0: tcmdPtr->curFlags = traceFlags; sl@0: tcmdPtr->curCode = code; sl@0: } sl@0: traceCode = (tracePtr->proc)(tracePtr->clientData, sl@0: interp, curLevel, command, (Tcl_Command)cmdPtr, sl@0: objc, objv); sl@0: } sl@0: } else { sl@0: /* Old-style trace */ sl@0: sl@0: if (traceFlags & TCL_TRACE_ENTER_EXEC) { sl@0: /* sl@0: * Old-style interpreter-wide traces only trigger sl@0: * before the command is executed. sl@0: */ sl@0: traceCode = CallTraceProcedure(interp, tracePtr, cmdPtr, sl@0: command, numChars, objc, objv); sl@0: } sl@0: } sl@0: tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; sl@0: Tcl_Release((ClientData) tracePtr); sl@0: } sl@0: if (active.nextTracePtr) { sl@0: lastTracePtr = active.nextTracePtr->nextPtr; sl@0: } sl@0: } sl@0: iPtr->activeInterpTracePtr = active.nextPtr; sl@0: return(traceCode); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * CallTraceProcedure -- sl@0: * sl@0: * Invokes a trace procedure registered with an interpreter. These sl@0: * procedures trace command execution. Currently this trace procedure sl@0: * is called with the address of the string-based Tcl_CmdProc for the sl@0: * command, not the Tcl_ObjCmdProc. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Those side effects made by the trace procedure. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) sl@0: Tcl_Interp *interp; /* The current interpreter. */ sl@0: register Trace *tracePtr; /* Describes the trace procedure to call. */ sl@0: Command *cmdPtr; /* Points to command's Command struct. */ sl@0: CONST char *command; /* Points to the first character of the sl@0: * command's source before substitutions. */ sl@0: int numChars; /* The number of characters in the sl@0: * command's source. */ sl@0: register int objc; /* Number of arguments for the command. */ sl@0: Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: char *commandCopy; sl@0: int traceCode; sl@0: sl@0: /* sl@0: * Copy the command characters into a new string. sl@0: */ sl@0: sl@0: commandCopy = (char *) ckalloc((unsigned) (numChars + 1)); sl@0: memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars); sl@0: commandCopy[numChars] = '\0'; sl@0: sl@0: /* sl@0: * Call the trace procedure then free allocated storage. sl@0: */ sl@0: sl@0: traceCode = (tracePtr->proc)( tracePtr->clientData, (Tcl_Interp*) iPtr, sl@0: iPtr->numLevels, commandCopy, sl@0: (Tcl_Command) cmdPtr, objc, objv ); sl@0: sl@0: ckfree((char *) commandCopy); sl@0: return(traceCode); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * CommandObjTraceDeleted -- sl@0: * sl@0: * Ensure the trace is correctly deleted by decrementing its sl@0: * refCount and only deleting if no other references exist. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * May release memory. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: static void sl@0: CommandObjTraceDeleted(ClientData clientData) { sl@0: TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; sl@0: tcmdPtr->refCount--; sl@0: if (tcmdPtr->refCount < 0) { sl@0: Tcl_Panic("CommandObjTraceDeleted: negative TraceCommandInfo refCount"); sl@0: } sl@0: if (tcmdPtr->refCount == 0) { sl@0: ckfree((char*)tcmdPtr); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TraceExecutionProc -- sl@0: * sl@0: * This procedure is invoked whenever code relevant to a sl@0: * 'trace execution' command is executed. It is called in one sl@0: * of two ways in Tcl's core: sl@0: * sl@0: * (i) by the TclCheckExecutionTraces, when an execution trace sl@0: * has been triggered. sl@0: * (ii) by TclCheckInterpTraces, when a prior execution trace has sl@0: * created a trace of the internals of a procedure, passing in sl@0: * this procedure as the one to be called. sl@0: * sl@0: * Results: sl@0: * The return value is a standard Tcl completion code such as sl@0: * TCL_OK or TCL_ERROR, etc. sl@0: * sl@0: * Side effects: sl@0: * May invoke an arbitrary Tcl procedure, and may create or sl@0: * delete an interpreter-wide trace. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: static int sl@0: TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, sl@0: int level, CONST char* command, Tcl_Command cmdInfo, sl@0: int objc, struct Tcl_Obj *CONST objv[]) { sl@0: int call = 0; sl@0: Interp *iPtr = (Interp *) interp; sl@0: TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; sl@0: int flags = tcmdPtr->curFlags; sl@0: int code = tcmdPtr->curCode; sl@0: int traceCode = TCL_OK; sl@0: sl@0: if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { sl@0: /* sl@0: * Inside any kind of execution trace callback, we do sl@0: * not allow any further execution trace callbacks to sl@0: * be called for the same trace. sl@0: */ sl@0: return traceCode; sl@0: } sl@0: sl@0: if (!Tcl_InterpDeleted(interp)) { sl@0: /* sl@0: * Check whether the current call is going to eval arbitrary sl@0: * Tcl code with a generated trace, or whether we are only sl@0: * going to setup interpreter-wide traces to implement the sl@0: * 'step' traces. This latter situation can happen if sl@0: * we create a command trace without either before or after sl@0: * operations, but with either of the step operations. sl@0: */ sl@0: if (flags & TCL_TRACE_EXEC_DIRECT) { sl@0: call = flags & tcmdPtr->flags sl@0: & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); sl@0: } else { sl@0: call = 1; sl@0: } sl@0: /* sl@0: * First, if we have returned back to the level at which we sl@0: * created an interpreter trace for enterstep and/or leavestep sl@0: * execution traces, we remove it here. sl@0: */ sl@0: if (flags & TCL_TRACE_LEAVE_EXEC) { sl@0: if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel) sl@0: && (strcmp(command, tcmdPtr->startCmd) == 0)) { sl@0: Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); sl@0: tcmdPtr->stepTrace = NULL; sl@0: if (tcmdPtr->startCmd != NULL) { sl@0: ckfree((char *)tcmdPtr->startCmd); sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Second, create the tcl callback, if required. sl@0: */ sl@0: if (call) { sl@0: Tcl_SavedResult state; sl@0: int stateCode, i, saveInterpFlags; sl@0: Tcl_DString cmd; sl@0: Tcl_DString sub; sl@0: sl@0: Tcl_DStringInit(&cmd); sl@0: Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length); sl@0: /* Append command with arguments */ sl@0: Tcl_DStringInit(&sub); sl@0: for (i = 0; i < objc; i++) { sl@0: char* str; sl@0: int len; sl@0: str = Tcl_GetStringFromObj(objv[i],&len); sl@0: Tcl_DStringAppendElement(&sub, str); sl@0: } sl@0: Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub)); sl@0: Tcl_DStringFree(&sub); sl@0: sl@0: if (flags & TCL_TRACE_ENTER_EXEC) { sl@0: /* Append trace operation */ sl@0: if (flags & TCL_TRACE_EXEC_DIRECT) { sl@0: Tcl_DStringAppendElement(&cmd, "enter"); sl@0: } else { sl@0: Tcl_DStringAppendElement(&cmd, "enterstep"); sl@0: } sl@0: } else if (flags & TCL_TRACE_LEAVE_EXEC) { sl@0: Tcl_Obj* resultCode; sl@0: char* resultCodeStr; sl@0: sl@0: /* Append result code */ sl@0: resultCode = Tcl_NewIntObj(code); sl@0: resultCodeStr = Tcl_GetString(resultCode); sl@0: Tcl_DStringAppendElement(&cmd, resultCodeStr); sl@0: Tcl_DecrRefCount(resultCode); sl@0: sl@0: /* Append result string */ sl@0: Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp)); sl@0: /* Append trace operation */ sl@0: if (flags & TCL_TRACE_EXEC_DIRECT) { sl@0: Tcl_DStringAppendElement(&cmd, "leave"); sl@0: } else { sl@0: Tcl_DStringAppendElement(&cmd, "leavestep"); sl@0: } sl@0: } else { sl@0: panic("TraceExecutionProc: bad flag combination"); sl@0: } sl@0: sl@0: /* sl@0: * Execute the command. Save the interp's result used for sl@0: * the command, including the value of iPtr->returnCode which sl@0: * may be modified when Tcl_Eval is invoked. We discard any sl@0: * object result the command returns. sl@0: */ sl@0: sl@0: Tcl_SaveResult(interp, &state); sl@0: stateCode = iPtr->returnCode; sl@0: sl@0: saveInterpFlags = iPtr->flags; sl@0: iPtr->flags |= INTERP_TRACE_IN_PROGRESS; sl@0: tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; sl@0: tcmdPtr->refCount++; sl@0: /* sl@0: * This line can have quite arbitrary side-effects, sl@0: * including deleting the trace, the command being sl@0: * traced, or even the interpreter. sl@0: */ sl@0: traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); sl@0: tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; sl@0: sl@0: /* sl@0: * Restore the interp tracing flag to prevent cmd traces sl@0: * from affecting interp traces sl@0: */ sl@0: iPtr->flags = saveInterpFlags;; sl@0: if (tcmdPtr->flags == 0) { sl@0: flags |= TCL_TRACE_DESTROYED; sl@0: } sl@0: sl@0: if (traceCode == TCL_OK) { sl@0: /* Restore result if trace execution was successful */ sl@0: Tcl_RestoreResult(interp, &state); sl@0: iPtr->returnCode = stateCode; sl@0: } else { sl@0: Tcl_DiscardResult(&state); sl@0: } sl@0: sl@0: Tcl_DStringFree(&cmd); sl@0: } sl@0: sl@0: /* sl@0: * Third, if there are any step execution traces for this proc, sl@0: * we register an interpreter trace to invoke enterstep and/or sl@0: * leavestep traces. sl@0: * We also need to save the current stack level and the proc sl@0: * string in startLevel and startCmd so that we can delete this sl@0: * interpreter trace when it reaches the end of this proc. sl@0: */ sl@0: if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL) sl@0: && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | sl@0: TCL_TRACE_LEAVE_DURING_EXEC))) { sl@0: tcmdPtr->startLevel = level; sl@0: tcmdPtr->startCmd = sl@0: (char *) ckalloc((unsigned) (strlen(command) + 1)); sl@0: strcpy(tcmdPtr->startCmd, command); sl@0: tcmdPtr->refCount++; sl@0: tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, sl@0: (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, sl@0: TraceExecutionProc, (ClientData)tcmdPtr, sl@0: CommandObjTraceDeleted); sl@0: } sl@0: } sl@0: if (flags & TCL_TRACE_DESTROYED) { sl@0: if (tcmdPtr->stepTrace != NULL) { sl@0: Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); sl@0: tcmdPtr->stepTrace = NULL; sl@0: if (tcmdPtr->startCmd != NULL) { sl@0: ckfree((char *)tcmdPtr->startCmd); sl@0: } sl@0: } sl@0: } sl@0: if (call) { sl@0: tcmdPtr->refCount--; sl@0: if (tcmdPtr->refCount < 0) { sl@0: Tcl_Panic("TraceExecutionProc: negative TraceCommandInfo refCount"); sl@0: } sl@0: if (tcmdPtr->refCount == 0) { sl@0: ckfree((char*)tcmdPtr); sl@0: } sl@0: } sl@0: return traceCode; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TraceVarProc -- sl@0: * sl@0: * This procedure is called to handle variable accesses that have sl@0: * been traced using the "trace" command. sl@0: * sl@0: * Results: sl@0: * Normally returns NULL. If the trace command returns an error, sl@0: * then this procedure returns an error string. sl@0: * sl@0: * Side effects: sl@0: * Depends on the command associated with the trace. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: static char * sl@0: TraceVarProc(clientData, interp, name1, name2, flags) sl@0: ClientData clientData; /* Information about the variable trace. */ sl@0: Tcl_Interp *interp; /* Interpreter containing variable. */ sl@0: CONST char *name1; /* Name of variable or array. */ sl@0: CONST char *name2; /* Name of element within array; NULL means sl@0: * scalar variable is being referenced. */ sl@0: int flags; /* OR-ed bits giving operation and other sl@0: * information. */ sl@0: { sl@0: Tcl_SavedResult state; sl@0: TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; sl@0: char *result; sl@0: int code, destroy = 0; sl@0: Tcl_DString cmd; sl@0: sl@0: /* sl@0: * We might call Tcl_Eval() below, and that might evaluate [trace sl@0: * vdelete] which might try to free tvarPtr. However we do not sl@0: * need to protect anything here; it's done by our caller because sl@0: * the TraceVarInfo is really part of a CompoundVarTrace. [Bug 1348775] sl@0: */ sl@0: sl@0: result = NULL; sl@0: if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp)) { sl@0: if (tvarPtr->length != (size_t) 0) { sl@0: /* sl@0: * Generate a command to execute by appending list elements sl@0: * for the two variable names and the operation. sl@0: */ sl@0: sl@0: Tcl_DStringInit(&cmd); sl@0: Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); sl@0: Tcl_DStringAppendElement(&cmd, name1); sl@0: Tcl_DStringAppendElement(&cmd, (name2 ? name2 : "")); sl@0: #ifndef TCL_REMOVE_OBSOLETE_TRACES sl@0: if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) { sl@0: if (flags & TCL_TRACE_ARRAY) { sl@0: Tcl_DStringAppend(&cmd, " a", 2); sl@0: } else if (flags & TCL_TRACE_READS) { sl@0: Tcl_DStringAppend(&cmd, " r", 2); sl@0: } else if (flags & TCL_TRACE_WRITES) { sl@0: Tcl_DStringAppend(&cmd, " w", 2); sl@0: } else if (flags & TCL_TRACE_UNSETS) { sl@0: Tcl_DStringAppend(&cmd, " u", 2); sl@0: } sl@0: } else { sl@0: #endif sl@0: if (flags & TCL_TRACE_ARRAY) { sl@0: Tcl_DStringAppend(&cmd, " array", 6); sl@0: } else if (flags & TCL_TRACE_READS) { sl@0: Tcl_DStringAppend(&cmd, " read", 5); sl@0: } else if (flags & TCL_TRACE_WRITES) { sl@0: Tcl_DStringAppend(&cmd, " write", 6); sl@0: } else if (flags & TCL_TRACE_UNSETS) { sl@0: Tcl_DStringAppend(&cmd, " unset", 6); sl@0: } sl@0: #ifndef TCL_REMOVE_OBSOLETE_TRACES sl@0: } sl@0: #endif sl@0: sl@0: /* sl@0: * Execute the command. Save the interp's result used for sl@0: * the command. We discard any object result the command returns. sl@0: * sl@0: * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to sl@0: * other areas that this will be destroyed by us, otherwise a sl@0: * double-free might occur depending on what the eval does. sl@0: */ sl@0: sl@0: Tcl_SaveResult(interp, &state); sl@0: if ((flags & TCL_TRACE_DESTROYED) sl@0: && !(tvarPtr->flags & TCL_TRACE_DESTROYED)) { sl@0: destroy = 1; sl@0: tvarPtr->flags |= TCL_TRACE_DESTROYED; sl@0: } sl@0: sl@0: code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), sl@0: Tcl_DStringLength(&cmd), 0); sl@0: if (code != TCL_OK) { /* copy error msg to result */ sl@0: register Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); sl@0: Tcl_IncrRefCount(errMsgObj); sl@0: result = (char *) errMsgObj; sl@0: } sl@0: sl@0: Tcl_RestoreResult(interp, &state); sl@0: sl@0: Tcl_DStringFree(&cmd); sl@0: } sl@0: } sl@0: if (destroy) { sl@0: if (result != NULL) { sl@0: register Tcl_Obj *errMsgObj = (Tcl_Obj *) result; sl@0: sl@0: Tcl_DecrRefCount(errMsgObj); sl@0: result = NULL; sl@0: } sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_WhileObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "while" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * With the bytecode compiler, this procedure is only called when sl@0: * a command name is computed at runtime, and is "while" or the name sl@0: * to which "while" was renamed: e.g., "set z while; $z {$i<100} {}" sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_WhileObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int result, value; sl@0: #ifdef TCL_TIP280 sl@0: Interp* iPtr = (Interp*) interp; sl@0: #endif sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "test command"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: while (1) { sl@0: result = Tcl_ExprBooleanObj(interp, objv[1], &value); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: if (!value) { sl@0: break; sl@0: } sl@0: #ifndef TCL_TIP280 sl@0: result = Tcl_EvalObjEx(interp, objv[2], 0); sl@0: #else sl@0: /* TIP #280. */ sl@0: result = TclEvalObjEx(interp, objv[2], 0, iPtr->cmdFramePtr,2); sl@0: #endif sl@0: if ((result != TCL_OK) && (result != TCL_CONTINUE)) { sl@0: if (result == TCL_ERROR) { sl@0: char msg[32 + TCL_INTEGER_SPACE]; sl@0: sl@0: sprintf(msg, "\n (\"while\" body line %d)", sl@0: interp->errorLine); sl@0: Tcl_AddErrorInfo(interp, msg); sl@0: } sl@0: break; sl@0: } sl@0: } sl@0: if (result == TCL_BREAK) { sl@0: result = TCL_OK; sl@0: } sl@0: if (result == TCL_OK) { sl@0: Tcl_ResetResult(interp); sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: #ifdef TCL_TIP280 sl@0: static void sl@0: ListLines(listStr, line, n, lines) sl@0: CONST char* listStr; /* Pointer to string with list structure. sl@0: * Assumed to be valid. Assumed to contain sl@0: * n elements. sl@0: */ sl@0: int line; /* line the list as a whole starts on */ sl@0: int n; /* #elements in lines */ sl@0: int* lines; /* Array of line numbers, to fill */ sl@0: { sl@0: int i; sl@0: int length = strlen( listStr); sl@0: CONST char *element = NULL; sl@0: CONST char* next = NULL; sl@0: sl@0: for (i = 0; i < n; i++) { sl@0: TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL); sl@0: sl@0: TclAdvanceLines (&line, listStr, element); /* Leading whitespace */ sl@0: lines [i] = line; sl@0: length -= (next - listStr); sl@0: TclAdvanceLines (&line, element, next); /* Element */ sl@0: listStr = next; sl@0: sl@0: if (*element == 0) { sl@0: /* ASSERT i == n */ sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: #endif sl@0: sl@0: /* sl@0: * Local Variables: sl@0: * mode: c sl@0: * c-basic-offset: 4 sl@0: * fill-column: 78 sl@0: * End: sl@0: */ sl@0: