Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCmdMZ.c@bde4ae8d615e (annotated)

sl@0	1	/*
sl@0	2	* tclCmdMZ.c --
sl@0	3	*
sl@0	4	* This file contains the top-level command routines for most of
sl@0	5	* the Tcl built-in commands whose names begin with the letters
sl@0	6	* M to Z. It contains only commands in the generic core (i.e.
sl@0	7	* those that don't depend much upon UNIX facilities).
sl@0	8	*
sl@0	9	* Copyright (c) 1987-1993 The Regents of the University of California.
sl@0	10	* Copyright (c) 1994-1997 Sun Microsystems, Inc.
sl@0	11	* Copyright (c) 1998-2000 Scriptics Corporation.
sl@0	12	* Copyright (c) 2002 ActiveState Corporation.
sl@0	13	* Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
sl@0	14	*
sl@0	15	* See the file "license.terms" for information on usage and redistribution
sl@0	16	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0	17	*
sl@0	18	* RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.28 2007/05/10 18:23:58 dgp Exp $
sl@0	19	*/
sl@0	20
sl@0	21	#include "tclInt.h"
sl@0	22	#include "tclPort.h"
sl@0	23	#include "tclRegexp.h"
sl@0	24	#include "tclCompile.h"
sl@0	25
sl@0	26	/*
sl@0	27	* Structures used to hold information about variable traces:
sl@0	28	*/
sl@0	29
sl@0	30	typedef struct {
sl@0	31	int flags; /* Operations for which Tcl command is
sl@0	32	* to be invoked. */
sl@0	33	size_t length; /* Number of non-NULL chars. in command. */
sl@0	34	char command[4]; /* Space for Tcl command to invoke. Actual
sl@0	35	* size will be as large as necessary to
sl@0	36	* hold command. This field must be the
sl@0	37	* last in the structure, so that it can
sl@0	38	* be larger than 4 bytes. */
sl@0	39	} TraceVarInfo;
sl@0	40
sl@0	41	typedef struct {
sl@0	42	VarTrace trace;
sl@0	43	TraceVarInfo tvar;
sl@0	44	} CompoundVarTrace;
sl@0	45
sl@0	46	/*
sl@0	47	* Structure used to hold information about command traces:
sl@0	48	*/
sl@0	49
sl@0	50	typedef struct {
sl@0	51	int flags; /* Operations for which Tcl command is
sl@0	52	* to be invoked. */
sl@0	53	size_t length; /* Number of non-NULL chars. in command. */
sl@0	54	Tcl_Trace stepTrace; /* Used for execution traces, when tracing
sl@0	55	* inside the given command */
sl@0	56	int startLevel; /* Used for bookkeeping with step execution
sl@0	57	* traces, store the level at which the step
sl@0	58	* trace was invoked */
sl@0	59	char startCmd; / Used for bookkeeping with step execution
sl@0	60	* traces, store the command name which invoked
sl@0	61	* step trace */
sl@0	62	int curFlags; /* Trace flags for the current command */
sl@0	63	int curCode; /* Return code for the current command */
sl@0	64	int refCount; /* Used to ensure this structure is
sl@0	65	* not deleted too early. Keeps track
sl@0	66	* of how many pieces of code have
sl@0	67	* a pointer to this structure. */
sl@0	68	char command[4]; /* Space for Tcl command to invoke. Actual
sl@0	69	* size will be as large as necessary to
sl@0	70	* hold command. This field must be the
sl@0	71	* last in the structure, so that it can
sl@0	72	* be larger than 4 bytes. */
sl@0	73	} TraceCommandInfo;
sl@0	74
sl@0	75	/*
sl@0	76	* Used by command execution traces. Note that we assume in the code
sl@0	77	* that the first two defines are exactly 4 times the
sl@0	78	* 'TCL_TRACE_ENTER_EXEC' and 'TCL_TRACE_LEAVE_EXEC' constants.
sl@0	79	*
sl@0	80	* TCL_TRACE_ENTER_DURING_EXEC - Trace each command inside the command
sl@0	81	* currently being traced, before execution.
sl@0	82	* TCL_TRACE_LEAVE_DURING_EXEC - Trace each command inside the command
sl@0	83	* currently being traced, after execution.
sl@0	84	* TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags.
sl@0	85	* TCL_TRACE_EXEC_IN_PROGRESS - The callback procedure on this trace
sl@0	86	* is currently executing. Therefore we
sl@0	87	* don't let further traces execute.
sl@0	88	* TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly
sl@0	89	* by the command being traced, not because
sl@0	90	* of an internal trace.
sl@0	91	* The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also
sl@0	92	* be used in command execution traces.
sl@0	93	*/
sl@0	94	#define TCL_TRACE_ENTER_DURING_EXEC 4
sl@0	95	#define TCL_TRACE_LEAVE_DURING_EXEC 8
sl@0	96	#define TCL_TRACE_ANY_EXEC 15
sl@0	97	#define TCL_TRACE_EXEC_IN_PROGRESS 0x10
sl@0	98	#define TCL_TRACE_EXEC_DIRECT 0x20
sl@0	99
sl@0	100	/*
sl@0	101	* Forward declarations for procedures defined in this file:
sl@0	102	*/
sl@0	103
sl@0	104	typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	105	int optionIndex, int objc, Tcl_Obj *CONST objv[]));
sl@0	106
sl@0	107	Tcl_TraceTypeObjCmd TclTraceVariableObjCmd;
sl@0	108	Tcl_TraceTypeObjCmd TclTraceCommandObjCmd;
sl@0	109	Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd;
sl@0	110
sl@0	111	/*
sl@0	112	* Each subcommand has a number of 'types' to which it can apply.
sl@0	113	* Currently 'execution', 'command' and 'variable' are the only
sl@0	114	* types supported. These three arrays MUST be kept in sync!
sl@0	115	* In the future we may provide an API to add to the list of
sl@0	116	* supported trace types.
sl@0	117	*/
sl@0	118	static CONST char *traceTypeOptions[] = {
sl@0	119	"execution", "command", "variable", (char*) NULL
sl@0	120	};
sl@0	121	static Tcl_TraceTypeObjCmd* traceSubCmds[] = {
sl@0	122	TclTraceExecutionObjCmd,
sl@0	123	TclTraceCommandObjCmd,
sl@0	124	TclTraceVariableObjCmd,
sl@0	125	};
sl@0	126
sl@0	127	/*
sl@0	128	* Declarations for local procedures to this file:
sl@0	129	*/
sl@0	130	static int CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	131	Trace tracePtr, Command cmdPtr,
sl@0	132	CONST char *command, int numChars,
sl@0	133	int objc, Tcl_Obj *CONST objv[]));
sl@0	134	static char * TraceVarProc _ANSI_ARGS_((ClientData clientData,
sl@0	135	Tcl_Interp interp, CONST char name1,
sl@0	136	CONST char *name2, int flags));
sl@0	137	static void TraceCommandProc _ANSI_ARGS_((ClientData clientData,
sl@0	138	Tcl_Interp interp, CONST char oldName,
sl@0	139	CONST char *newName, int flags));
sl@0	140	static Tcl_CmdObjTraceProc TraceExecutionProc;
sl@0	141
sl@0	142	#ifdef TCL_TIP280
sl@0	143	static void ListLines _ANSI_ARGS_((CONST char* listStr, int line,
sl@0	144	int n, int* lines));
sl@0	145	#endif
sl@0	146	/*
sl@0	147	*----------------------------------------------------------------------
sl@0	148	*
sl@0	149	* Tcl_PwdObjCmd --
sl@0	150	*
sl@0	151	* This procedure is invoked to process the "pwd" Tcl command.
sl@0	152	* See the user documentation for details on what it does.
sl@0	153	*
sl@0	154	* Results:
sl@0	155	* A standard Tcl result.
sl@0	156	*
sl@0	157	* Side effects:
sl@0	158	* See the user documentation.
sl@0	159	*
sl@0	160	*----------------------------------------------------------------------
sl@0	161	*/
sl@0	162
sl@0	163	/* ARGSUSED */
sl@0	164	int
sl@0	165	Tcl_PwdObjCmd(dummy, interp, objc, objv)
sl@0	166	ClientData dummy; /* Not used. */
sl@0	167	Tcl_Interp interp; / Current interpreter. */
sl@0	168	int objc; /* Number of arguments. */
sl@0	169	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	170	{
sl@0	171	Tcl_Obj *retVal;
sl@0	172
sl@0	173	if (objc != 1) {
sl@0	174	Tcl_WrongNumArgs(interp, 1, objv, NULL);
sl@0	175	return TCL_ERROR;
sl@0	176	}
sl@0	177
sl@0	178	retVal = Tcl_FSGetCwd(interp);
sl@0	179	if (retVal == NULL) {
sl@0	180	return TCL_ERROR;
sl@0	181	}
sl@0	182	Tcl_SetObjResult(interp, retVal);
sl@0	183	Tcl_DecrRefCount(retVal);
sl@0	184	return TCL_OK;
sl@0	185	}
sl@0	186
sl@0	187	/*
sl@0	188	*----------------------------------------------------------------------
sl@0	189	*
sl@0	190	* Tcl_RegexpObjCmd --
sl@0	191	*
sl@0	192	* This procedure is invoked to process the "regexp" Tcl command.
sl@0	193	* See the user documentation for details on what it does.
sl@0	194	*
sl@0	195	* Results:
sl@0	196	* A standard Tcl result.
sl@0	197	*
sl@0	198	* Side effects:
sl@0	199	* See the user documentation.
sl@0	200	*
sl@0	201	*----------------------------------------------------------------------
sl@0	202	*/
sl@0	203
sl@0	204	/* ARGSUSED */
sl@0	205	int
sl@0	206	Tcl_RegexpObjCmd(dummy, interp, objc, objv)
sl@0	207	ClientData dummy; /* Not used. */
sl@0	208	Tcl_Interp interp; / Current interpreter. */
sl@0	209	int objc; /* Number of arguments. */
sl@0	210	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	211	{
sl@0	212	int i, indices, match, about, offset, all, doinline, numMatchesSaved;
sl@0	213	int cflags, eflags, stringLength;
sl@0	214	Tcl_RegExp regExpr;
sl@0	215	Tcl_Obj objPtr, resultPtr;
sl@0	216	Tcl_RegExpInfo info;
sl@0	217	static CONST char *options[] = {
sl@0	218	"-all", "-about", "-indices", "-inline",
sl@0	219	"-expanded", "-line", "-linestop", "-lineanchor",
sl@0	220	"-nocase", "-start", "--", (char *) NULL
sl@0	221	};
sl@0	222	enum options {
sl@0	223	REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE,
sl@0	224	REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR,
sl@0	225	REGEXP_NOCASE, REGEXP_START, REGEXP_LAST
sl@0	226	};
sl@0	227
sl@0	228	indices = 0;
sl@0	229	about = 0;
sl@0	230	cflags = TCL_REG_ADVANCED;
sl@0	231	eflags = 0;
sl@0	232	offset = 0;
sl@0	233	all = 0;
sl@0	234	doinline = 0;
sl@0	235
sl@0	236	for (i = 1; i < objc; i++) {
sl@0	237	char *name;
sl@0	238	int index;
sl@0	239
sl@0	240	name = Tcl_GetString(objv[i]);
sl@0	241	if (name[0] != '-') {
sl@0	242	break;
sl@0	243	}
sl@0	244	if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
sl@0	245	&index) != TCL_OK) {
sl@0	246	return TCL_ERROR;
sl@0	247	}
sl@0	248	switch ((enum options) index) {
sl@0	249	case REGEXP_ALL: {
sl@0	250	all = 1;
sl@0	251	break;
sl@0	252	}
sl@0	253	case REGEXP_INDICES: {
sl@0	254	indices = 1;
sl@0	255	break;
sl@0	256	}
sl@0	257	case REGEXP_INLINE: {
sl@0	258	doinline = 1;
sl@0	259	break;
sl@0	260	}
sl@0	261	case REGEXP_NOCASE: {
sl@0	262	cflags \|= TCL_REG_NOCASE;
sl@0	263	break;
sl@0	264	}
sl@0	265	case REGEXP_ABOUT: {
sl@0	266	about = 1;
sl@0	267	break;
sl@0	268	}
sl@0	269	case REGEXP_EXPANDED: {
sl@0	270	cflags \|= TCL_REG_EXPANDED;
sl@0	271	break;
sl@0	272	}
sl@0	273	case REGEXP_LINE: {
sl@0	274	cflags \|= TCL_REG_NEWLINE;
sl@0	275	break;
sl@0	276	}
sl@0	277	case REGEXP_LINESTOP: {
sl@0	278	cflags \|= TCL_REG_NLSTOP;
sl@0	279	break;
sl@0	280	}
sl@0	281	case REGEXP_LINEANCHOR: {
sl@0	282	cflags \|= TCL_REG_NLANCH;
sl@0	283	break;
sl@0	284	}
sl@0	285	case REGEXP_START: {
sl@0	286	if (++i >= objc) {
sl@0	287	goto endOfForLoop;
sl@0	288	}
sl@0	289	if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) {
sl@0	290	return TCL_ERROR;
sl@0	291	}
sl@0	292	if (offset < 0) {
sl@0	293	offset = 0;
sl@0	294	}
sl@0	295	break;
sl@0	296	}
sl@0	297	case REGEXP_LAST: {
sl@0	298	i++;
sl@0	299	goto endOfForLoop;
sl@0	300	}
sl@0	301	}
sl@0	302	}
sl@0	303
sl@0	304	endOfForLoop:
sl@0	305	if ((objc - i) < (2 - about)) {
sl@0	306	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	307	"?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
sl@0	308	return TCL_ERROR;
sl@0	309	}
sl@0	310	objc -= i;
sl@0	311	objv += i;
sl@0	312
sl@0	313	if (doinline && ((objc - 2) != 0)) {
sl@0	314	/*
sl@0	315	* User requested -inline, but specified match variables - a no-no.
sl@0	316	*/
sl@0	317	Tcl_AppendResult(interp, "regexp match variables not allowed",
sl@0	318	" when using -inline", (char *) NULL);
sl@0	319	return TCL_ERROR;
sl@0	320	}
sl@0	321
sl@0	322	/*
sl@0	323	* Handle the odd about case separately.
sl@0	324	*/
sl@0	325	if (about) {
sl@0	326	regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
sl@0	327	if ((regExpr == NULL) \|\| (TclRegAbout(interp, regExpr) < 0)) {
sl@0	328	return TCL_ERROR;
sl@0	329	}
sl@0	330	return TCL_OK;
sl@0	331	}
sl@0	332
sl@0	333	/*
sl@0	334	* Get the length of the string that we are matching against so
sl@0	335	* we can do the termination test for -all matches. Do this before
sl@0	336	* getting the regexp to avoid shimmering problems.
sl@0	337	*/
sl@0	338	objPtr = objv[1];
sl@0	339	stringLength = Tcl_GetCharLength(objPtr);
sl@0	340
sl@0	341	regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
sl@0	342	if (regExpr == NULL) {
sl@0	343	return TCL_ERROR;
sl@0	344	}
sl@0	345
sl@0	346	if (offset > 0) {
sl@0	347	/*
sl@0	348	* Add flag if using offset (string is part of a larger string),
sl@0	349	* so that "^" won't match.
sl@0	350	*/
sl@0	351	eflags \|= TCL_REG_NOTBOL;
sl@0	352	}
sl@0	353
sl@0	354	objc -= 2;
sl@0	355	objv += 2;
sl@0	356	resultPtr = Tcl_GetObjResult(interp);
sl@0	357
sl@0	358	if (doinline) {
sl@0	359	/*
sl@0	360	* Save all the subexpressions, as we will return them as a list
sl@0	361	*/
sl@0	362	numMatchesSaved = -1;
sl@0	363	} else {
sl@0	364	/*
sl@0	365	* Save only enough subexpressions for matches we want to keep,
sl@0	366	* expect in the case of -all, where we need to keep at least
sl@0	367	* one to know where to move the offset.
sl@0	368	*/
sl@0	369	numMatchesSaved = (objc == 0) ? all : objc;
sl@0	370	}
sl@0	371
sl@0	372	/*
sl@0	373	* The following loop is to handle multiple matches within the
sl@0	374	* same source string; each iteration handles one match. If "-all"
sl@0	375	* hasn't been specified then the loop body only gets executed once.
sl@0	376	* We terminate the loop when the starting offset is past the end of the
sl@0	377	* string.
sl@0	378	*/
sl@0	379
sl@0	380	while (1) {
sl@0	381	match = Tcl_RegExpExecObj(interp, regExpr, objPtr,
sl@0	382	offset /* offset */, numMatchesSaved, eflags
sl@0	383	\| ((offset > 0 &&
sl@0	384	(Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n'))
sl@0	385	? TCL_REG_NOTBOL : 0));
sl@0	386
sl@0	387	if (match < 0) {
sl@0	388	return TCL_ERROR;
sl@0	389	}
sl@0	390
sl@0	391	if (match == 0) {
sl@0	392	/*
sl@0	393	* We want to set the value of the intepreter result only when
sl@0	394	* this is the first time through the loop.
sl@0	395	*/
sl@0	396	if (all <= 1) {
sl@0	397	/*
sl@0	398	* If inlining, set the interpreter's object result to an
sl@0	399	* empty list, otherwise set it to an integer object w/
sl@0	400	* value 0.
sl@0	401	*/
sl@0	402	if (doinline) {
sl@0	403	Tcl_SetListObj(resultPtr, 0, NULL);
sl@0	404	} else {
sl@0	405	Tcl_SetIntObj(resultPtr, 0);
sl@0	406	}
sl@0	407	return TCL_OK;
sl@0	408	}
sl@0	409	break;
sl@0	410	}
sl@0	411
sl@0	412	/*
sl@0	413	* If additional variable names have been specified, return
sl@0	414	* index information in those variables.
sl@0	415	*/
sl@0	416
sl@0	417	Tcl_RegExpGetInfo(regExpr, &info);
sl@0	418	if (doinline) {
sl@0	419	/*
sl@0	420	* It's the number of substitutions, plus one for the matchVar
sl@0	421	* at index 0
sl@0	422	*/
sl@0	423	objc = info.nsubs + 1;
sl@0	424	}
sl@0	425	for (i = 0; i < objc; i++) {
sl@0	426	Tcl_Obj *newPtr;
sl@0	427
sl@0	428	if (indices) {
sl@0	429	int start, end;
sl@0	430	Tcl_Obj *objs[2];
sl@0	431
sl@0	432	/*
sl@0	433	* Only adjust the match area if there was a match for
sl@0	434	* that area. (Scriptics Bug 4391/SF Bug #219232)
sl@0	435	*/
sl@0	436	if (i <= info.nsubs && info.matches[i].start >= 0) {
sl@0	437	start = offset + info.matches[i].start;
sl@0	438	end = offset + info.matches[i].end;
sl@0	439
sl@0	440	/*
sl@0	441	* Adjust index so it refers to the last character in the
sl@0	442	* match instead of the first character after the match.
sl@0	443	*/
sl@0	444
sl@0	445	if (end >= offset) {
sl@0	446	end--;
sl@0	447	}
sl@0	448	} else {
sl@0	449	start = -1;
sl@0	450	end = -1;
sl@0	451	}
sl@0	452
sl@0	453	objs[0] = Tcl_NewLongObj(start);
sl@0	454	objs[1] = Tcl_NewLongObj(end);
sl@0	455
sl@0	456	newPtr = Tcl_NewListObj(2, objs);
sl@0	457	} else {
sl@0	458	if (i <= info.nsubs) {
sl@0	459	newPtr = Tcl_GetRange(objPtr,
sl@0	460	offset + info.matches[i].start,
sl@0	461	offset + info.matches[i].end - 1);
sl@0	462	} else {
sl@0	463	newPtr = Tcl_NewObj();
sl@0	464	}
sl@0	465	}
sl@0	466	if (doinline) {
sl@0	467	if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
sl@0	468	!= TCL_OK) {
sl@0	469	Tcl_DecrRefCount(newPtr);
sl@0	470	return TCL_ERROR;
sl@0	471	}
sl@0	472	} else {
sl@0	473	Tcl_Obj *valuePtr;
sl@0	474	Tcl_IncrRefCount(newPtr);
sl@0	475	valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0);
sl@0	476	Tcl_DecrRefCount(newPtr);
sl@0	477	if (valuePtr == NULL) {
sl@0	478	Tcl_AppendResult(interp, "couldn't set variable \"",
sl@0	479	Tcl_GetString(objv[i]), "\"", (char *) NULL);
sl@0	480	return TCL_ERROR;
sl@0	481	}
sl@0	482	}
sl@0	483	}
sl@0	484
sl@0	485	if (all == 0) {
sl@0	486	break;
sl@0	487	}
sl@0	488	/*
sl@0	489	* Adjust the offset to the character just after the last one
sl@0	490	* in the matchVar and increment all to count how many times
sl@0	491	* we are making a match. We always increment the offset by at least
sl@0	492	* one to prevent endless looping (as in the case:
sl@0	493	* regexp -all {a*} a). Otherwise, when we match the NULL string at
sl@0	494	* the end of the input string, we will loop indefinately (because the
sl@0	495	* length of the match is 0, so offset never changes).
sl@0	496	*/
sl@0	497	if (info.matches[0].end == 0) {
sl@0	498	offset++;
sl@0	499	}
sl@0	500	offset += info.matches[0].end;
sl@0	501	all++;
sl@0	502	eflags \|= TCL_REG_NOTBOL;
sl@0	503	if (offset >= stringLength) {
sl@0	504	break;
sl@0	505	}
sl@0	506	}
sl@0	507
sl@0	508	/*
sl@0	509	* Set the interpreter's object result to an integer object
sl@0	510	* with value 1 if -all wasn't specified, otherwise it's all-1
sl@0	511	* (the number of times through the while - 1).
sl@0	512	* Get the resultPtr again as the Tcl_ObjSetVar2 above may have
sl@0	513	* cause the result to change. [Patch #558324] (watson).
sl@0	514	*/
sl@0	515
sl@0	516	if (!doinline) {
sl@0	517	resultPtr = Tcl_GetObjResult(interp);
sl@0	518	Tcl_SetIntObj(resultPtr, (all ? all-1 : 1));
sl@0	519	}
sl@0	520	return TCL_OK;
sl@0	521	}
sl@0	522
sl@0	523	/*
sl@0	524	*----------------------------------------------------------------------
sl@0	525	*
sl@0	526	* Tcl_RegsubObjCmd --
sl@0	527	*
sl@0	528	* This procedure is invoked to process the "regsub" Tcl command.
sl@0	529	* See the user documentation for details on what it does.
sl@0	530	*
sl@0	531	* Results:
sl@0	532	* A standard Tcl result.
sl@0	533	*
sl@0	534	* Side effects:
sl@0	535	* See the user documentation.
sl@0	536	*
sl@0	537	*----------------------------------------------------------------------
sl@0	538	*/
sl@0	539
sl@0	540	/* ARGSUSED */
sl@0	541	int
sl@0	542	Tcl_RegsubObjCmd(dummy, interp, objc, objv)
sl@0	543	ClientData dummy; /* Not used. */
sl@0	544	Tcl_Interp interp; / Current interpreter. */
sl@0	545	int objc; /* Number of arguments. */
sl@0	546	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	547	{
sl@0	548	int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
sl@0	549	int start, end, subStart, subEnd, match;
sl@0	550	Tcl_RegExp regExpr;
sl@0	551	Tcl_RegExpInfo info;
sl@0	552	Tcl_Obj resultPtr, subPtr, *objPtr;
sl@0	553	Tcl_UniChar ch, wsrc, wfirstChar, wstring, wsubspec, *wend;
sl@0	554
sl@0	555	static CONST char *options[] = {
sl@0	556	"-all", "-nocase", "-expanded",
sl@0	557	"-line", "-linestop", "-lineanchor", "-start",
sl@0	558	"--", NULL
sl@0	559	};
sl@0	560	enum options {
sl@0	561	REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED,
sl@0	562	REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START,
sl@0	563	REGSUB_LAST
sl@0	564	};
sl@0	565
sl@0	566	cflags = TCL_REG_ADVANCED;
sl@0	567	all = 0;
sl@0	568	offset = 0;
sl@0	569	resultPtr = NULL;
sl@0	570
sl@0	571	for (idx = 1; idx < objc; idx++) {
sl@0	572	char *name;
sl@0	573	int index;
sl@0	574
sl@0	575	name = Tcl_GetString(objv[idx]);
sl@0	576	if (name[0] != '-') {
sl@0	577	break;
sl@0	578	}
sl@0	579	if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch",
sl@0	580	TCL_EXACT, &index) != TCL_OK) {
sl@0	581	return TCL_ERROR;
sl@0	582	}
sl@0	583	switch ((enum options) index) {
sl@0	584	case REGSUB_ALL: {
sl@0	585	all = 1;
sl@0	586	break;
sl@0	587	}
sl@0	588	case REGSUB_NOCASE: {
sl@0	589	cflags \|= TCL_REG_NOCASE;
sl@0	590	break;
sl@0	591	}
sl@0	592	case REGSUB_EXPANDED: {
sl@0	593	cflags \|= TCL_REG_EXPANDED;
sl@0	594	break;
sl@0	595	}
sl@0	596	case REGSUB_LINE: {
sl@0	597	cflags \|= TCL_REG_NEWLINE;
sl@0	598	break;
sl@0	599	}
sl@0	600	case REGSUB_LINESTOP: {
sl@0	601	cflags \|= TCL_REG_NLSTOP;
sl@0	602	break;
sl@0	603	}
sl@0	604	case REGSUB_LINEANCHOR: {
sl@0	605	cflags \|= TCL_REG_NLANCH;
sl@0	606	break;
sl@0	607	}
sl@0	608	case REGSUB_START: {
sl@0	609	if (++idx >= objc) {
sl@0	610	goto endOfForLoop;
sl@0	611	}
sl@0	612	if (Tcl_GetIntFromObj(interp, objv[idx], &offset) != TCL_OK) {
sl@0	613	return TCL_ERROR;
sl@0	614	}
sl@0	615	if (offset < 0) {
sl@0	616	offset = 0;
sl@0	617	}
sl@0	618	break;
sl@0	619	}
sl@0	620	case REGSUB_LAST: {
sl@0	621	idx++;
sl@0	622	goto endOfForLoop;
sl@0	623	}
sl@0	624	}
sl@0	625	}
sl@0	626	endOfForLoop:
sl@0	627	if (objc-idx < 3 \|\| objc-idx > 4) {
sl@0	628	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	629	"?switches? exp string subSpec ?varName?");
sl@0	630	return TCL_ERROR;
sl@0	631	}
sl@0	632
sl@0	633	objc -= idx;
sl@0	634	objv += idx;
sl@0	635
sl@0	636	if (all && (offset == 0)
sl@0	637	&& (strpbrk(Tcl_GetString(objv[2]), "&\\") == NULL)
sl@0	638	&& (strpbrk(Tcl_GetString(objv[0]), "*+?{}()[].\\\|^$") == NULL)) {
sl@0	639	/*
sl@0	640	* This is a simple one pair string map situation. We make use of
sl@0	641	* a slightly modified version of the one pair STR_MAP code.
sl@0	642	*/
sl@0	643	int slen, nocase;
sl@0	644	int (strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar , CONST Tcl_UniChar *,
sl@0	645	unsigned long));
sl@0	646	Tcl_UniChar *p, wsrclc;
sl@0	647
sl@0	648	numMatches = 0;
sl@0	649	nocase = (cflags & TCL_REG_NOCASE);
sl@0	650	strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
sl@0	651
sl@0	652	wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen);
sl@0	653	wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen);
sl@0	654	wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen);
sl@0	655	wend = wstring + wlen - (slen ? slen - 1 : 0);
sl@0	656	result = TCL_OK;
sl@0	657
sl@0	658	if (slen == 0) {
sl@0	659	/*
sl@0	660	* regsub behavior for "" matches between each character.
sl@0	661	* 'string map' skips the "" case.
sl@0	662	*/
sl@0	663	if (wstring < wend) {
sl@0	664	resultPtr = Tcl_NewUnicodeObj(wstring, 0);
sl@0	665	Tcl_IncrRefCount(resultPtr);
sl@0	666	for (; wstring < wend; wstring++) {
sl@0	667	Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
sl@0	668	Tcl_AppendUnicodeToObj(resultPtr, wstring, 1);
sl@0	669	numMatches++;
sl@0	670	}
sl@0	671	wlen = 0;
sl@0	672	}
sl@0	673	} else {
sl@0	674	wsrclc = Tcl_UniCharToLower(*wsrc);
sl@0	675	for (p = wfirstChar = wstring; wstring < wend; wstring++) {
sl@0	676	if (((wstring == wsrc) \|\|
sl@0	677	(nocase && (Tcl_UniCharToLower(*wstring) ==
sl@0	678	wsrclc))) &&
sl@0	679	((slen == 1) \|\| (strCmpFn(wstring, wsrc,
sl@0	680	(unsigned long) slen) == 0))) {
sl@0	681	if (numMatches == 0) {
sl@0	682	resultPtr = Tcl_NewUnicodeObj(wstring, 0);
sl@0	683	Tcl_IncrRefCount(resultPtr);
sl@0	684	}
sl@0	685	if (p != wstring) {
sl@0	686	Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p);
sl@0	687	p = wstring + slen;
sl@0	688	} else {
sl@0	689	p += slen;
sl@0	690	}
sl@0	691	wstring = p - 1;
sl@0	692
sl@0	693	Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
sl@0	694	numMatches++;
sl@0	695	}
sl@0	696	}
sl@0	697	if (numMatches) {
sl@0	698	wlen = wfirstChar + wlen - p;
sl@0	699	wstring = p;
sl@0	700	}
sl@0	701	}
sl@0	702	objPtr = NULL;
sl@0	703	subPtr = NULL;
sl@0	704	goto regsubDone;
sl@0	705	}
sl@0	706
sl@0	707	regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
sl@0	708	if (regExpr == NULL) {
sl@0	709	return TCL_ERROR;
sl@0	710	}
sl@0	711
sl@0	712	/*
sl@0	713	* Make sure to avoid problems where the objects are shared. This
sl@0	714	* can cause RegExpObj <> UnicodeObj shimmering that causes data
sl@0	715	* corruption. [Bug #461322]
sl@0	716	*/
sl@0	717
sl@0	718	if (objv[1] == objv[0]) {
sl@0	719	objPtr = Tcl_DuplicateObj(objv[1]);
sl@0	720	} else {
sl@0	721	objPtr = objv[1];
sl@0	722	}
sl@0	723	wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen);
sl@0	724	if (objv[2] == objv[0]) {
sl@0	725	subPtr = Tcl_DuplicateObj(objv[2]);
sl@0	726	} else {
sl@0	727	subPtr = objv[2];
sl@0	728	}
sl@0	729	wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);
sl@0	730
sl@0	731	result = TCL_OK;
sl@0	732
sl@0	733	/*
sl@0	734	* The following loop is to handle multiple matches within the
sl@0	735	* same source string; each iteration handles one match and its
sl@0	736	* corresponding substitution. If "-all" hasn't been specified
sl@0	737	* then the loop body only gets executed once. We must use
sl@0	738	* 'offset <= wlen' in particular for the case where the regexp
sl@0	739	* pattern can match the empty string - this is useful when
sl@0	740	* doing, say, 'regsub -- ^ $str ...' when $str might be empty.
sl@0	741	*/
sl@0	742
sl@0	743	numMatches = 0;
sl@0	744	for ( ; offset <= wlen; ) {
sl@0	745
sl@0	746	/*
sl@0	747	* The flags argument is set if string is part of a larger string,
sl@0	748	* so that "^" won't match.
sl@0	749	*/
sl@0	750
sl@0	751	match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset,
sl@0	752	10 /* matches */, ((offset > 0 &&
sl@0	753	(wstring[offset-1] != (Tcl_UniChar)'\n'))
sl@0	754	? TCL_REG_NOTBOL : 0));
sl@0	755
sl@0	756	if (match < 0) {
sl@0	757	result = TCL_ERROR;
sl@0	758	goto done;
sl@0	759	}
sl@0	760	if (match == 0) {
sl@0	761	break;
sl@0	762	}
sl@0	763	if (numMatches == 0) {
sl@0	764	resultPtr = Tcl_NewUnicodeObj(wstring, 0);
sl@0	765	Tcl_IncrRefCount(resultPtr);
sl@0	766	if (offset > 0) {
sl@0	767	/*
sl@0	768	* Copy the initial portion of the string in if an offset
sl@0	769	* was specified.
sl@0	770	*/
sl@0	771	Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
sl@0	772	}
sl@0	773	}
sl@0	774	numMatches++;
sl@0	775
sl@0	776	/*
sl@0	777	* Copy the portion of the source string before the match to the
sl@0	778	* result variable.
sl@0	779	*/
sl@0	780
sl@0	781	Tcl_RegExpGetInfo(regExpr, &info);
sl@0	782	start = info.matches[0].start;
sl@0	783	end = info.matches[0].end;
sl@0	784	Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start);
sl@0	785
sl@0	786	/*
sl@0	787	* Append the subSpec argument to the variable, making appropriate
sl@0	788	* substitutions. This code is a bit hairy because of the backslash
sl@0	789	* conventions and because the code saves up ranges of characters in
sl@0	790	* subSpec to reduce the number of calls to Tcl_SetVar.
sl@0	791	*/
sl@0	792
sl@0	793	wsrc = wfirstChar = wsubspec;
sl@0	794	wend = wsubspec + wsublen;
sl@0	795	for (ch = wsrc; wsrc != wend; wsrc++, ch = wsrc) {
sl@0	796	if (ch == '&') {
sl@0	797	idx = 0;
sl@0	798	} else if (ch == '\\') {
sl@0	799	ch = wsrc[1];
sl@0	800	if ((ch >= '0') && (ch <= '9')) {
sl@0	801	idx = ch - '0';
sl@0	802	} else if ((ch == '\\') \|\| (ch == '&')) {
sl@0	803	*wsrc = ch;
sl@0	804	Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
sl@0	805	wsrc - wfirstChar + 1);
sl@0	806	*wsrc = '\\';
sl@0	807	wfirstChar = wsrc + 2;
sl@0	808	wsrc++;
sl@0	809	continue;
sl@0	810	} else {
sl@0	811	continue;
sl@0	812	}
sl@0	813	} else {
sl@0	814	continue;
sl@0	815	}
sl@0	816	if (wfirstChar != wsrc) {
sl@0	817	Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
sl@0	818	wsrc - wfirstChar);
sl@0	819	}
sl@0	820	if (idx <= info.nsubs) {
sl@0	821	subStart = info.matches[idx].start;
sl@0	822	subEnd = info.matches[idx].end;
sl@0	823	if ((subStart >= 0) && (subEnd >= 0)) {
sl@0	824	Tcl_AppendUnicodeToObj(resultPtr,
sl@0	825	wstring + offset + subStart, subEnd - subStart);
sl@0	826	}
sl@0	827	}
sl@0	828	if (*wsrc == '\\') {
sl@0	829	wsrc++;
sl@0	830	}
sl@0	831	wfirstChar = wsrc + 1;
sl@0	832	}
sl@0	833	if (wfirstChar != wsrc) {
sl@0	834	Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar);
sl@0	835	}
sl@0	836	if (end == 0) {
sl@0	837	/*
sl@0	838	* Always consume at least one character of the input string
sl@0	839	* in order to prevent infinite loops.
sl@0	840	*/
sl@0	841
sl@0	842	if (offset < wlen) {
sl@0	843	Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
sl@0	844	}
sl@0	845	offset++;
sl@0	846	} else {
sl@0	847	offset += end;
sl@0	848	if (start == end) {
sl@0	849	/*
sl@0	850	* We matched an empty string, which means we must go
sl@0	851	* forward one more step so we don't match again at the
sl@0	852	* same spot.
sl@0	853	*/
sl@0	854	if (offset < wlen) {
sl@0	855	Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
sl@0	856	}
sl@0	857	offset++;
sl@0	858	}
sl@0	859	}
sl@0	860	if (!all) {
sl@0	861	break;
sl@0	862	}
sl@0	863	}
sl@0	864
sl@0	865	/*
sl@0	866	* Copy the portion of the source string after the last match to the
sl@0	867	* result variable.
sl@0	868	*/
sl@0	869	regsubDone:
sl@0	870	if (numMatches == 0) {
sl@0	871	/*
sl@0	872	* On zero matches, just ignore the offset, since it shouldn't
sl@0	873	* matter to us in this case, and the user may have skewed it.
sl@0	874	*/
sl@0	875	resultPtr = objv[1];
sl@0	876	Tcl_IncrRefCount(resultPtr);
sl@0	877	} else if (offset < wlen) {
sl@0	878	Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
sl@0	879	}
sl@0	880	if (objc == 4) {
sl@0	881	if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) {
sl@0	882	Tcl_AppendResult(interp, "couldn't set variable \"",
sl@0	883	Tcl_GetString(objv[3]), "\"", (char *) NULL);
sl@0	884	result = TCL_ERROR;
sl@0	885	} else {
sl@0	886	/*
sl@0	887	* Set the interpreter's object result to an integer object
sl@0	888	* holding the number of matches.
sl@0	889	*/
sl@0	890
sl@0	891	Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches);
sl@0	892	}
sl@0	893	} else {
sl@0	894	/*
sl@0	895	* No varname supplied, so just return the modified string.
sl@0	896	*/
sl@0	897	Tcl_SetObjResult(interp, resultPtr);
sl@0	898	}
sl@0	899
sl@0	900	done:
sl@0	901	if (objPtr && (objv[1] == objv[0])) { Tcl_DecrRefCount(objPtr); }
sl@0	902	if (subPtr && (objv[2] == objv[0])) { Tcl_DecrRefCount(subPtr); }
sl@0	903	if (resultPtr) { Tcl_DecrRefCount(resultPtr); }
sl@0	904	return result;
sl@0	905	}
sl@0	906
sl@0	907	/*
sl@0	908	*----------------------------------------------------------------------
sl@0	909	*
sl@0	910	* Tcl_RenameObjCmd --
sl@0	911	*
sl@0	912	* This procedure is invoked to process the "rename" Tcl command.
sl@0	913	* See the user documentation for details on what it does.
sl@0	914	*
sl@0	915	* Results:
sl@0	916	* A standard Tcl object result.
sl@0	917	*
sl@0	918	* Side effects:
sl@0	919	* See the user documentation.
sl@0	920	*
sl@0	921	*----------------------------------------------------------------------
sl@0	922	*/
sl@0	923
sl@0	924	/* ARGSUSED */
sl@0	925	int
sl@0	926	Tcl_RenameObjCmd(dummy, interp, objc, objv)
sl@0	927	ClientData dummy; /* Arbitrary value passed to the command. */
sl@0	928	Tcl_Interp interp; / Current interpreter. */
sl@0	929	int objc; /* Number of arguments. */
sl@0	930	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	931	{
sl@0	932	char oldName, newName;
sl@0	933
sl@0	934	if (objc != 3) {
sl@0	935	Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
sl@0	936	return TCL_ERROR;
sl@0	937	}
sl@0	938
sl@0	939	oldName = Tcl_GetString(objv[1]);
sl@0	940	newName = Tcl_GetString(objv[2]);
sl@0	941	return TclRenameCommand(interp, oldName, newName);
sl@0	942	}
sl@0	943
sl@0	944	/*
sl@0	945	*----------------------------------------------------------------------
sl@0	946	*
sl@0	947	* Tcl_ReturnObjCmd --
sl@0	948	*
sl@0	949	* This object-based procedure is invoked to process the "return" Tcl
sl@0	950	* command. See the user documentation for details on what it does.
sl@0	951	*
sl@0	952	* Results:
sl@0	953	* A standard Tcl object result.
sl@0	954	*
sl@0	955	* Side effects:
sl@0	956	* See the user documentation.
sl@0	957	*
sl@0	958	*----------------------------------------------------------------------
sl@0	959	*/
sl@0	960
sl@0	961	/* ARGSUSED */
sl@0	962	int
sl@0	963	Tcl_ReturnObjCmd(dummy, interp, objc, objv)
sl@0	964	ClientData dummy; /* Not used. */
sl@0	965	Tcl_Interp interp; / Current interpreter. */
sl@0	966	int objc; /* Number of arguments. */
sl@0	967	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	968	{
sl@0	969	Interp iPtr = (Interp ) interp;
sl@0	970	int optionLen, argLen, code, result;
sl@0	971
sl@0	972	if (iPtr->errorInfo != NULL) {
sl@0	973	ckfree(iPtr->errorInfo);
sl@0	974	iPtr->errorInfo = NULL;
sl@0	975	}
sl@0	976	if (iPtr->errorCode != NULL) {
sl@0	977	ckfree(iPtr->errorCode);
sl@0	978	iPtr->errorCode = NULL;
sl@0	979	}
sl@0	980	code = TCL_OK;
sl@0	981
sl@0	982	for (objv++, objc--; objc > 1; objv += 2, objc -= 2) {
sl@0	983	char *option = Tcl_GetStringFromObj(objv[0], &optionLen);
sl@0	984	char *arg = Tcl_GetStringFromObj(objv[1], &argLen);
sl@0	985
sl@0	986	if (strcmp(option, "-code") == 0) {
sl@0	987	register int c = arg[0];
sl@0	988	if ((c == 'o') && (strcmp(arg, "ok") == 0)) {
sl@0	989	code = TCL_OK;
sl@0	990	} else if ((c == 'e') && (strcmp(arg, "error") == 0)) {
sl@0	991	code = TCL_ERROR;
sl@0	992	} else if ((c == 'r') && (strcmp(arg, "return") == 0)) {
sl@0	993	code = TCL_RETURN;
sl@0	994	} else if ((c == 'b') && (strcmp(arg, "break") == 0)) {
sl@0	995	code = TCL_BREAK;
sl@0	996	} else if ((c == 'c') && (strcmp(arg, "continue") == 0)) {
sl@0	997	code = TCL_CONTINUE;
sl@0	998	} else {
sl@0	999	result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1],
sl@0	1000	&code);
sl@0	1001	if (result != TCL_OK) {
sl@0	1002	Tcl_ResetResult(interp);
sl@0	1003	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1004	"bad completion code \"",
sl@0	1005	Tcl_GetString(objv[1]),
sl@0	1006	"\": must be ok, error, return, break, ",
sl@0	1007	"continue, or an integer", (char *) NULL);
sl@0	1008	return result;
sl@0	1009	}
sl@0	1010	}
sl@0	1011	} else if (strcmp(option, "-errorinfo") == 0) {
sl@0	1012	iPtr->errorInfo =
sl@0	1013	(char *) ckalloc((unsigned) (strlen(arg) + 1));
sl@0	1014	strcpy(iPtr->errorInfo, arg);
sl@0	1015	} else if (strcmp(option, "-errorcode") == 0) {
sl@0	1016	iPtr->errorCode =
sl@0	1017	(char *) ckalloc((unsigned) (strlen(arg) + 1));
sl@0	1018	strcpy(iPtr->errorCode, arg);
sl@0	1019	} else {
sl@0	1020	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1021	"bad option \"", option,
sl@0	1022	"\": must be -code, -errorcode, or -errorinfo",
sl@0	1023	(char *) NULL);
sl@0	1024	return TCL_ERROR;
sl@0	1025	}
sl@0	1026	}
sl@0	1027
sl@0	1028	if (objc == 1) {
sl@0	1029	/*
sl@0	1030	* Set the interpreter's object result. An inline version of
sl@0	1031	* Tcl_SetObjResult.
sl@0	1032	*/
sl@0	1033
sl@0	1034	Tcl_SetObjResult(interp, objv[0]);
sl@0	1035	}
sl@0	1036	iPtr->returnCode = code;
sl@0	1037	return TCL_RETURN;
sl@0	1038	}
sl@0	1039
sl@0	1040	/*
sl@0	1041	*----------------------------------------------------------------------
sl@0	1042	*
sl@0	1043	* Tcl_SourceObjCmd --
sl@0	1044	*
sl@0	1045	* This procedure is invoked to process the "source" Tcl command.
sl@0	1046	* See the user documentation for details on what it does.
sl@0	1047	*
sl@0	1048	* Results:
sl@0	1049	* A standard Tcl object result.
sl@0	1050	*
sl@0	1051	* Side effects:
sl@0	1052	* See the user documentation.
sl@0	1053	*
sl@0	1054	*----------------------------------------------------------------------
sl@0	1055	*/
sl@0	1056
sl@0	1057	/* ARGSUSED */
sl@0	1058	int
sl@0	1059	Tcl_SourceObjCmd(dummy, interp, objc, objv)
sl@0	1060	ClientData dummy; /* Not used. */
sl@0	1061	Tcl_Interp interp; / Current interpreter. */
sl@0	1062	int objc; /* Number of arguments. */
sl@0	1063	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1064	{
sl@0	1065	if (objc != 2) {
sl@0	1066	Tcl_WrongNumArgs(interp, 1, objv, "fileName");
sl@0	1067	return TCL_ERROR;
sl@0	1068	}
sl@0	1069
sl@0	1070	return Tcl_FSEvalFile(interp, objv[1]);
sl@0	1071	}
sl@0	1072
sl@0	1073	/*
sl@0	1074	*----------------------------------------------------------------------
sl@0	1075	*
sl@0	1076	* Tcl_SplitObjCmd --
sl@0	1077	*
sl@0	1078	* This procedure is invoked to process the "split" Tcl command.
sl@0	1079	* See the user documentation for details on what it does.
sl@0	1080	*
sl@0	1081	* Results:
sl@0	1082	* A standard Tcl result.
sl@0	1083	*
sl@0	1084	* Side effects:
sl@0	1085	* See the user documentation.
sl@0	1086	*
sl@0	1087	*----------------------------------------------------------------------
sl@0	1088	*/
sl@0	1089
sl@0	1090	/* ARGSUSED */
sl@0	1091	int
sl@0	1092	Tcl_SplitObjCmd(dummy, interp, objc, objv)
sl@0	1093	ClientData dummy; /* Not used. */
sl@0	1094	Tcl_Interp interp; / Current interpreter. */
sl@0	1095	int objc; /* Number of arguments. */
sl@0	1096	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1097	{
sl@0	1098	Tcl_UniChar ch;
sl@0	1099	int len;
sl@0	1100	char splitChars, string, *end;
sl@0	1101	int splitCharLen, stringLen;
sl@0	1102	Tcl_Obj listPtr, objPtr;
sl@0	1103
sl@0	1104	if (objc == 2) {
sl@0	1105	splitChars = " \n\t\r";
sl@0	1106	splitCharLen = 4;
sl@0	1107	} else if (objc == 3) {
sl@0	1108	splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
sl@0	1109	} else {
sl@0	1110	Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
sl@0	1111	return TCL_ERROR;
sl@0	1112	}
sl@0	1113
sl@0	1114	string = Tcl_GetStringFromObj(objv[1], &stringLen);
sl@0	1115	end = string + stringLen;
sl@0	1116	listPtr = Tcl_GetObjResult(interp);
sl@0	1117
sl@0	1118	if (stringLen == 0) {
sl@0	1119	/*
sl@0	1120	* Do nothing.
sl@0	1121	*/
sl@0	1122	} else if (splitCharLen == 0) {
sl@0	1123	Tcl_HashTable charReuseTable;
sl@0	1124	Tcl_HashEntry *hPtr;
sl@0	1125	int isNew;
sl@0	1126
sl@0	1127	/*
sl@0	1128	* Handle the special case of splitting on every character.
sl@0	1129	*
sl@0	1130	* Uses a hash table to ensure that each kind of character has
sl@0	1131	* only one Tcl_Obj instance (multiply-referenced) in the
sl@0	1132	* final list. This is a major win when splitting on a long
sl@0	1133	* string (especially in the megabyte range!) - DKF
sl@0	1134	*/
sl@0	1135
sl@0	1136	Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
sl@0	1137	for ( ; string < end; string += len) {
sl@0	1138	len = TclUtfToUniChar(string, &ch);
sl@0	1139	/* Assume Tcl_UniChar is an integral type... */
sl@0	1140	hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew);
sl@0	1141	if (isNew) {
sl@0	1142	objPtr = Tcl_NewStringObj(string, len);
sl@0	1143	/* Don't need to fiddle with refcount... */
sl@0	1144	Tcl_SetHashValue(hPtr, (ClientData) objPtr);
sl@0	1145	} else {
sl@0	1146	objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr);
sl@0	1147	}
sl@0	1148	Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
sl@0	1149	}
sl@0	1150	Tcl_DeleteHashTable(&charReuseTable);
sl@0	1151	} else if (splitCharLen == 1) {
sl@0	1152	char *p;
sl@0	1153
sl@0	1154	/*
sl@0	1155	* Handle the special case of splitting on a single character.
sl@0	1156	* This is only true for the one-char ASCII case, as one unicode
sl@0	1157	* char is > 1 byte in length.
sl@0	1158	*/
sl@0	1159
sl@0	1160	while (string && (p = strchr(string, (int) splitChars)) != NULL) {
sl@0	1161	objPtr = Tcl_NewStringObj(string, p - string);
sl@0	1162	Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
sl@0	1163	string = p + 1;
sl@0	1164	}
sl@0	1165	objPtr = Tcl_NewStringObj(string, end - string);
sl@0	1166	Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
sl@0	1167	} else {
sl@0	1168	char element, p, *splitEnd;
sl@0	1169	int splitLen;
sl@0	1170	Tcl_UniChar splitChar;
sl@0	1171
sl@0	1172	/*
sl@0	1173	* Normal case: split on any of a given set of characters.
sl@0	1174	* Discard instances of the split characters.
sl@0	1175	*/
sl@0	1176
sl@0	1177	splitEnd = splitChars + splitCharLen;
sl@0	1178
sl@0	1179	for (element = string; string < end; string += len) {
sl@0	1180	len = TclUtfToUniChar(string, &ch);
sl@0	1181	for (p = splitChars; p < splitEnd; p += splitLen) {
sl@0	1182	splitLen = TclUtfToUniChar(p, &splitChar);
sl@0	1183	if (ch == splitChar) {
sl@0	1184	objPtr = Tcl_NewStringObj(element, string - element);
sl@0	1185	Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
sl@0	1186	element = string + len;
sl@0	1187	break;
sl@0	1188	}
sl@0	1189	}
sl@0	1190	}
sl@0	1191	objPtr = Tcl_NewStringObj(element, string - element);
sl@0	1192	Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
sl@0	1193	}
sl@0	1194	return TCL_OK;
sl@0	1195	}
sl@0	1196
sl@0	1197	/*
sl@0	1198	*----------------------------------------------------------------------
sl@0	1199	*
sl@0	1200	* Tcl_StringObjCmd --
sl@0	1201	*
sl@0	1202	* This procedure is invoked to process the "string" Tcl command.
sl@0	1203	* See the user documentation for details on what it does. Note
sl@0	1204	* that this command only functions correctly on properly formed
sl@0	1205	* Tcl UTF strings.
sl@0	1206	*
sl@0	1207	* Note that the primary methods here (equal, compare, match, ...)
sl@0	1208	* have bytecode equivalents. You will find the code for those in
sl@0	1209	* tclExecute.c. The code here will only be used in the non-bc
sl@0	1210	* case (like in an 'eval').
sl@0	1211	*
sl@0	1212	* Results:
sl@0	1213	* A standard Tcl result.
sl@0	1214	*
sl@0	1215	* Side effects:
sl@0	1216	* See the user documentation.
sl@0	1217	*
sl@0	1218	*----------------------------------------------------------------------
sl@0	1219	*/
sl@0	1220
sl@0	1221	/* ARGSUSED */
sl@0	1222	int
sl@0	1223	Tcl_StringObjCmd(dummy, interp, objc, objv)
sl@0	1224	ClientData dummy; /* Not used. */
sl@0	1225	Tcl_Interp interp; / Current interpreter. */
sl@0	1226	int objc; /* Number of arguments. */
sl@0	1227	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1228	{
sl@0	1229	int index, left, right;
sl@0	1230	Tcl_Obj *resultPtr;
sl@0	1231	char string1, string2;
sl@0	1232	int length1, length2;
sl@0	1233	static CONST char *options[] = {
sl@0	1234	"bytelength", "compare", "equal", "first",
sl@0	1235	"index", "is", "last", "length",
sl@0	1236	"map", "match", "range", "repeat",
sl@0	1237	"replace", "tolower", "toupper", "totitle",
sl@0	1238	"trim", "trimleft", "trimright",
sl@0	1239	"wordend", "wordstart", (char *) NULL
sl@0	1240	};
sl@0	1241	enum options {
sl@0	1242	STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST,
sl@0	1243	STR_INDEX, STR_IS, STR_LAST, STR_LENGTH,
sl@0	1244	STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT,
sl@0	1245	STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE,
sl@0	1246	STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
sl@0	1247	STR_WORDEND, STR_WORDSTART
sl@0	1248	};
sl@0	1249
sl@0	1250	if (objc < 2) {
sl@0	1251	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
sl@0	1252	return TCL_ERROR;
sl@0	1253	}
sl@0	1254
sl@0	1255	if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
sl@0	1256	&index) != TCL_OK) {
sl@0	1257	return TCL_ERROR;
sl@0	1258	}
sl@0	1259
sl@0	1260	resultPtr = Tcl_GetObjResult(interp);
sl@0	1261	switch ((enum options) index) {
sl@0	1262	case STR_EQUAL:
sl@0	1263	case STR_COMPARE: {
sl@0	1264	/*
sl@0	1265	* Remember to keep code here in some sync with the
sl@0	1266	* byte-compiled versions in tclExecute.c (INST_STR_EQ,
sl@0	1267	* INST_STR_NEQ and INST_STR_CMP as well as the expr string
sl@0	1268	* comparison in INST_EQ/INST_NEQ/INST_LT/...).
sl@0	1269	*/
sl@0	1270	int i, match, length, nocase = 0, reqlength = -1;
sl@0	1271	int (*strCmpFn)();
sl@0	1272
sl@0	1273	if (objc < 4 \|\| objc > 7) {
sl@0	1274	str_cmp_args:
sl@0	1275	Tcl_WrongNumArgs(interp, 2, objv,
sl@0	1276	"?-nocase? ?-length int? string1 string2");
sl@0	1277	return TCL_ERROR;
sl@0	1278	}
sl@0	1279
sl@0	1280	for (i = 2; i < objc-2; i++) {
sl@0	1281	string2 = Tcl_GetStringFromObj(objv[i], &length2);
sl@0	1282	if ((length2 > 1)
sl@0	1283	&& strncmp(string2, "-nocase", (size_t)length2) == 0) {
sl@0	1284	nocase = 1;
sl@0	1285	} else if ((length2 > 1)
sl@0	1286	&& strncmp(string2, "-length", (size_t)length2) == 0) {
sl@0	1287	if (i+1 >= objc-2) {
sl@0	1288	goto str_cmp_args;
sl@0	1289	}
sl@0	1290	if (Tcl_GetIntFromObj(interp, objv[++i],
sl@0	1291	&reqlength) != TCL_OK) {
sl@0	1292	return TCL_ERROR;
sl@0	1293	}
sl@0	1294	} else {
sl@0	1295	Tcl_AppendStringsToObj(resultPtr, "bad option \"",
sl@0	1296	string2, "\": must be -nocase or -length",
sl@0	1297	(char *) NULL);
sl@0	1298	return TCL_ERROR;
sl@0	1299	}
sl@0	1300	}
sl@0	1301
sl@0	1302	/*
sl@0	1303	* From now on, we only access the two objects at the end
sl@0	1304	* of the argument array.
sl@0	1305	*/
sl@0	1306	objv += objc-2;
sl@0	1307
sl@0	1308	if ((reqlength == 0) \|\| (objv[0] == objv[1])) {
sl@0	1309	/*
sl@0	1310	* Alway match at 0 chars of if it is the same obj.
sl@0	1311	*/
sl@0	1312
sl@0	1313	Tcl_SetBooleanObj(resultPtr,
sl@0	1314	((enum options) index == STR_EQUAL));
sl@0	1315	break;
sl@0	1316	} else if (!nocase && objv[0]->typePtr == &tclByteArrayType &&
sl@0	1317	objv[1]->typePtr == &tclByteArrayType) {
sl@0	1318	/*
sl@0	1319	* Use binary versions of comparisons since that won't
sl@0	1320	* cause undue type conversions and it is much faster.
sl@0	1321	* Only do this if we're case-sensitive (which is all
sl@0	1322	* that really makes sense with byte arrays anyway, and
sl@0	1323	* we have no memcasecmp() for some reason... :^)
sl@0	1324	*/
sl@0	1325	string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1);
sl@0	1326	string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2);
sl@0	1327	strCmpFn = memcmp;
sl@0	1328	} else if ((objv[0]->typePtr == &tclStringType)
sl@0	1329	&& (objv[1]->typePtr == &tclStringType)) {
sl@0	1330	/*
sl@0	1331	* Do a unicode-specific comparison if both of the args
sl@0	1332	* are of String type. In benchmark testing this proved
sl@0	1333	* the most efficient check between the unicode and
sl@0	1334	* string comparison operations.
sl@0	1335	*/
sl@0	1336	string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1);
sl@0	1337	string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2);
sl@0	1338	strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
sl@0	1339	} else {
sl@0	1340	/*
sl@0	1341	* As a catch-all we will work with UTF-8. We cannot use
sl@0	1342	* memcmp() as that is unsafe with any string containing
sl@0	1343	* NULL (\xC0\x80 in Tcl's utf rep). We can use the more
sl@0	1344	* efficient TclpUtfNcmp2 if we are case-sensitive and no
sl@0	1345	* specific length was requested.
sl@0	1346	*/
sl@0	1347	string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1);
sl@0	1348	string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2);
sl@0	1349	if ((reqlength < 0) && !nocase) {
sl@0	1350	strCmpFn = TclpUtfNcmp2;
sl@0	1351	} else {
sl@0	1352	length1 = Tcl_NumUtfChars(string1, length1);
sl@0	1353	length2 = Tcl_NumUtfChars(string2, length2);
sl@0	1354	strCmpFn = nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp;
sl@0	1355	}
sl@0	1356	}
sl@0	1357
sl@0	1358	if (((enum options) index == STR_EQUAL)
sl@0	1359	&& (reqlength < 0) && (length1 != length2)) {
sl@0	1360	match = 1; /* this will be reversed below */
sl@0	1361	} else {
sl@0	1362	length = (length1 < length2) ? length1 : length2;
sl@0	1363	if (reqlength > 0 && reqlength < length) {
sl@0	1364	length = reqlength;
sl@0	1365	} else if (reqlength < 0) {
sl@0	1366	/*
sl@0	1367	* The requested length is negative, so we ignore it by
sl@0	1368	* setting it to length + 1 so we correct the match var.
sl@0	1369	*/
sl@0	1370	reqlength = length + 1;
sl@0	1371	}
sl@0	1372	match = strCmpFn(string1, string2, (unsigned) length);
sl@0	1373	if ((match == 0) && (reqlength > length)) {
sl@0	1374	match = length1 - length2;
sl@0	1375	}
sl@0	1376	}
sl@0	1377
sl@0	1378	if ((enum options) index == STR_EQUAL) {
sl@0	1379	Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1);
sl@0	1380	} else {
sl@0	1381	Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 :
sl@0	1382	(match < 0) ? -1 : 0));
sl@0	1383	}
sl@0	1384	break;
sl@0	1385	}
sl@0	1386	case STR_FIRST: {
sl@0	1387	Tcl_UniChar ustring1, ustring2;
sl@0	1388	int match, start;
sl@0	1389
sl@0	1390	if (objc < 4 \|\| objc > 5) {
sl@0	1391	Tcl_WrongNumArgs(interp, 2, objv,
sl@0	1392	"subString string ?startIndex?");
sl@0	1393	return TCL_ERROR;
sl@0	1394	}
sl@0	1395
sl@0	1396	/*
sl@0	1397	* We are searching string2 for the sequence string1.
sl@0	1398	*/
sl@0	1399
sl@0	1400	match = -1;
sl@0	1401	start = 0;
sl@0	1402	length2 = -1;
sl@0	1403
sl@0	1404	ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
sl@0	1405	ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
sl@0	1406
sl@0	1407	if (objc == 5) {
sl@0	1408	/*
sl@0	1409	* If a startIndex is specified, we will need to fast
sl@0	1410	* forward to that point in the string before we think
sl@0	1411	* about a match
sl@0	1412	*/
sl@0	1413	if (TclGetIntForIndex(interp, objv[4], length2 - 1,
sl@0	1414	&start) != TCL_OK) {
sl@0	1415	return TCL_ERROR;
sl@0	1416	}
sl@0	1417	if (start >= length2) {
sl@0	1418	goto str_first_done;
sl@0	1419	} else if (start > 0) {
sl@0	1420	ustring2 += start;
sl@0	1421	length2 -= start;
sl@0	1422	} else if (start < 0) {
sl@0	1423	/*
sl@0	1424	* Invalid start index mapped to string start;
sl@0	1425	* Bug #423581
sl@0	1426	*/
sl@0	1427	start = 0;
sl@0	1428	}
sl@0	1429	}
sl@0	1430
sl@0	1431	if (length1 > 0) {
sl@0	1432	register Tcl_UniChar p, end;
sl@0	1433
sl@0	1434	end = ustring2 + length2 - length1 + 1;
sl@0	1435	for (p = ustring2; p < end; p++) {
sl@0	1436	/*
sl@0	1437	* Scan forward to find the first character.
sl@0	1438	*/
sl@0	1439	if ((p == ustring1) &&
sl@0	1440	(TclUniCharNcmp(ustring1, p,
sl@0	1441	(unsigned long) length1) == 0)) {
sl@0	1442	match = p - ustring2;
sl@0	1443	break;
sl@0	1444	}
sl@0	1445	}
sl@0	1446	}
sl@0	1447	/*
sl@0	1448	* Compute the character index of the matching string by
sl@0	1449	* counting the number of characters before the match.
sl@0	1450	*/
sl@0	1451	if ((match != -1) && (objc == 5)) {
sl@0	1452	match += start;
sl@0	1453	}
sl@0	1454
sl@0	1455	str_first_done:
sl@0	1456	Tcl_SetIntObj(resultPtr, match);
sl@0	1457	break;
sl@0	1458	}
sl@0	1459	case STR_INDEX: {
sl@0	1460	if (objc != 4) {
sl@0	1461	Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
sl@0	1462	return TCL_ERROR;
sl@0	1463	}
sl@0	1464
sl@0	1465	/*
sl@0	1466	* If we have a ByteArray object, avoid indexing in the
sl@0	1467	* Utf string since the byte array contains one byte per
sl@0	1468	* character. Otherwise, use the Unicode string rep to
sl@0	1469	* get the index'th char.
sl@0	1470	*/
sl@0	1471
sl@0	1472	if (objv[2]->typePtr == &tclByteArrayType) {
sl@0	1473	string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1);
sl@0	1474
sl@0	1475	if (TclGetIntForIndex(interp, objv[3], length1 - 1,
sl@0	1476	&index) != TCL_OK) {
sl@0	1477	return TCL_ERROR;
sl@0	1478	}
sl@0	1479	if ((index >= 0) && (index < length1)) {
sl@0	1480	Tcl_SetByteArrayObj(resultPtr,
sl@0	1481	(unsigned char *)(&string1[index]), 1);
sl@0	1482	}
sl@0	1483	} else {
sl@0	1484	/*
sl@0	1485	* Get Unicode char length to calulate what 'end' means.
sl@0	1486	*/
sl@0	1487	length1 = Tcl_GetCharLength(objv[2]);
sl@0	1488
sl@0	1489	if (TclGetIntForIndex(interp, objv[3], length1 - 1,
sl@0	1490	&index) != TCL_OK) {
sl@0	1491	return TCL_ERROR;
sl@0	1492	}
sl@0	1493	if ((index >= 0) && (index < length1)) {
sl@0	1494	char buf[TCL_UTF_MAX];
sl@0	1495	Tcl_UniChar ch;
sl@0	1496
sl@0	1497	ch = Tcl_GetUniChar(objv[2], index);
sl@0	1498	length1 = Tcl_UniCharToUtf(ch, buf);
sl@0	1499	Tcl_SetStringObj(resultPtr, buf, length1);
sl@0	1500	}
sl@0	1501	}
sl@0	1502	break;
sl@0	1503	}
sl@0	1504	case STR_IS: {
sl@0	1505	char *end;
sl@0	1506	Tcl_UniChar ch;
sl@0	1507
sl@0	1508	/*
sl@0	1509	* The UniChar comparison function
sl@0	1510	*/
sl@0	1511
sl@0	1512	int (*chcomp)_ANSI_ARGS_((int)) = NULL;
sl@0	1513	int i, failat = 0, result = 1, strict = 0;
sl@0	1514	Tcl_Obj objPtr, failVarObj = NULL;
sl@0	1515
sl@0	1516	static CONST char *isOptions[] = {
sl@0	1517	"alnum", "alpha", "ascii", "control",
sl@0	1518	"boolean", "digit", "double", "false",
sl@0	1519	"graph", "integer", "lower", "print",
sl@0	1520	"punct", "space", "true", "upper",
sl@0	1521	"wordchar", "xdigit", (char *) NULL
sl@0	1522	};
sl@0	1523	enum isOptions {
sl@0	1524	STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
sl@0	1525	STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE,
sl@0	1526	STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT,
sl@0	1527	STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER,
sl@0	1528	STR_IS_WORD, STR_IS_XDIGIT
sl@0	1529	};
sl@0	1530
sl@0	1531	if (objc < 4 \|\| objc > 7) {
sl@0	1532	Tcl_WrongNumArgs(interp, 2, objv,
sl@0	1533	"class ?-strict? ?-failindex var? str");
sl@0	1534	return TCL_ERROR;
sl@0	1535	}
sl@0	1536	if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0,
sl@0	1537	&index) != TCL_OK) {
sl@0	1538	return TCL_ERROR;
sl@0	1539	}
sl@0	1540	if (objc != 4) {
sl@0	1541	for (i = 3; i < objc-1; i++) {
sl@0	1542	string2 = Tcl_GetStringFromObj(objv[i], &length2);
sl@0	1543	if ((length2 > 1) &&
sl@0	1544	strncmp(string2, "-strict", (size_t) length2) == 0) {
sl@0	1545	strict = 1;
sl@0	1546	} else if ((length2 > 1) &&
sl@0	1547	strncmp(string2, "-failindex",
sl@0	1548	(size_t) length2) == 0) {
sl@0	1549	if (i+1 >= objc-1) {
sl@0	1550	Tcl_WrongNumArgs(interp, 3, objv,
sl@0	1551	"?-strict? ?-failindex var? str");
sl@0	1552	return TCL_ERROR;
sl@0	1553	}
sl@0	1554	failVarObj = objv[++i];
sl@0	1555	} else {
sl@0	1556	Tcl_AppendStringsToObj(resultPtr, "bad option \"",
sl@0	1557	string2, "\": must be -strict or -failindex",
sl@0	1558	(char *) NULL);
sl@0	1559	return TCL_ERROR;
sl@0	1560	}
sl@0	1561	}
sl@0	1562	}
sl@0	1563
sl@0	1564	/*
sl@0	1565	* We get the objPtr so that we can short-cut for some classes
sl@0	1566	* by checking the object type (int and double), but we need
sl@0	1567	* the string otherwise, because we don't want any conversion
sl@0	1568	* of type occuring (as, for example, Tcl_Get*FromObj would do
sl@0	1569	*/
sl@0	1570	objPtr = objv[objc-1];
sl@0	1571	string1 = Tcl_GetStringFromObj(objPtr, &length1);
sl@0	1572	if (length1 == 0) {
sl@0	1573	if (strict) {
sl@0	1574	result = 0;
sl@0	1575	}
sl@0	1576	goto str_is_done;
sl@0	1577	}
sl@0	1578	end = string1 + length1;
sl@0	1579
sl@0	1580	/*
sl@0	1581	* When entering here, result == 1 and failat == 0
sl@0	1582	*/
sl@0	1583	switch ((enum isOptions) index) {
sl@0	1584	case STR_IS_ALNUM:
sl@0	1585	chcomp = Tcl_UniCharIsAlnum;
sl@0	1586	break;
sl@0	1587	case STR_IS_ALPHA:
sl@0	1588	chcomp = Tcl_UniCharIsAlpha;
sl@0	1589	break;
sl@0	1590	case STR_IS_ASCII:
sl@0	1591	for (; string1 < end; string1++, failat++) {
sl@0	1592	/*
sl@0	1593	* This is a valid check in unicode, because all
sl@0	1594	* bytes < 0xC0 are single byte chars (but isascii
sl@0	1595	* limits that def'n to 0x80).
sl@0	1596	*/
sl@0	1597	if (((unsigned char )string1) >= 0x80) {
sl@0	1598	result = 0;
sl@0	1599	break;
sl@0	1600	}
sl@0	1601	}
sl@0	1602	break;
sl@0	1603	case STR_IS_BOOL:
sl@0	1604	case STR_IS_TRUE:
sl@0	1605	case STR_IS_FALSE:
sl@0	1606	/* Optimizers, beware Bug 1187123 ! */
sl@0	1607	if ((Tcl_GetBoolean(NULL, string1, &i)
sl@0	1608	== TCL_ERROR) \|\|
sl@0	1609	(((enum isOptions) index == STR_IS_TRUE) &&
sl@0	1610	i == 0) \|\|
sl@0	1611	(((enum isOptions) index == STR_IS_FALSE) &&
sl@0	1612	i != 0)) {
sl@0	1613	result = 0;
sl@0	1614	}
sl@0	1615	break;
sl@0	1616	case STR_IS_CONTROL:
sl@0	1617	chcomp = Tcl_UniCharIsControl;
sl@0	1618	break;
sl@0	1619	case STR_IS_DIGIT:
sl@0	1620	chcomp = Tcl_UniCharIsDigit;
sl@0	1621	break;
sl@0	1622	case STR_IS_DOUBLE: {
sl@0	1623	char *stop;
sl@0	1624
sl@0	1625	if ((objPtr->typePtr == &tclDoubleType) \|\|
sl@0	1626	(objPtr->typePtr == &tclIntType)) {
sl@0	1627	break;
sl@0	1628	}
sl@0	1629	/*
sl@0	1630	* This is adapted from Tcl_GetDouble
sl@0	1631	*
sl@0	1632	* The danger in this function is that
sl@0	1633	* "12345678901234567890" is an acceptable 'double',
sl@0	1634	* but will later be interp'd as an int by something
sl@0	1635	* like [expr]. Therefore, we check to see if it looks
sl@0	1636	* like an int, and if so we do a range check on it.
sl@0	1637	* If strtoul gets to the end, we know we either
sl@0	1638	* received an acceptable int, or over/underflow
sl@0	1639	*/
sl@0	1640	if (TclLooksLikeInt(string1, length1)) {
sl@0	1641	errno = 0;
sl@0	1642	#ifdef TCL_WIDE_INT_IS_LONG
sl@0	1643	strtoul(string1, &stop, 0); /* INTL: Tcl source. */
sl@0	1644	#else
sl@0	1645	strtoull(string1, &stop, 0); /* INTL: Tcl source. */
sl@0	1646	#endif
sl@0	1647	if (stop == end) {
sl@0	1648	if (errno == ERANGE) {
sl@0	1649	result = 0;
sl@0	1650	failat = -1;
sl@0	1651	}
sl@0	1652	break;
sl@0	1653	}
sl@0	1654	}
sl@0	1655	errno = 0;
sl@0	1656	strtod(string1, &stop); /* INTL: Tcl source. */
sl@0	1657	if (errno == ERANGE) {
sl@0	1658	/*
sl@0	1659	* if (errno == ERANGE), then it was an over/underflow
sl@0	1660	* problem, but in this method, we only want to know
sl@0	1661	* yes or no, so bad flow returns 0 (false) and sets
sl@0	1662	* the failVarObj to the string length.
sl@0	1663	*/
sl@0	1664	result = 0;
sl@0	1665	failat = -1;
sl@0	1666	} else if (stop == string1) {
sl@0	1667	/*
sl@0	1668	* In this case, nothing like a number was found
sl@0	1669	*/
sl@0	1670	result = 0;
sl@0	1671	failat = 0;
sl@0	1672	} else {
sl@0	1673	/*
sl@0	1674	* Assume we sucked up one char per byte
sl@0	1675	* and then we go onto SPACE, since we are
sl@0	1676	* allowed trailing whitespace
sl@0	1677	*/
sl@0	1678	failat = stop - string1;
sl@0	1679	string1 = stop;
sl@0	1680	chcomp = Tcl_UniCharIsSpace;
sl@0	1681	}
sl@0	1682	break;
sl@0	1683	}
sl@0	1684	case STR_IS_GRAPH:
sl@0	1685	chcomp = Tcl_UniCharIsGraph;
sl@0	1686	break;
sl@0	1687	case STR_IS_INT: {
sl@0	1688	char *stop;
sl@0	1689	long int l = 0;
sl@0	1690
sl@0	1691	if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) {
sl@0	1692	break;
sl@0	1693	}
sl@0	1694	/*
sl@0	1695	* Like STR_IS_DOUBLE, but we use strtoul.
sl@0	1696	* Since Tcl_GetIntFromObj already failed,
sl@0	1697	* we set result to 0.
sl@0	1698	*/
sl@0	1699	result = 0;
sl@0	1700	errno = 0;
sl@0	1701	l = strtol(string1, &stop, 0); /* INTL: Tcl source. */
sl@0	1702	if ((errno == ERANGE) \|\| (l > INT_MAX) \|\| (l < INT_MIN)) {
sl@0	1703	/*
sl@0	1704	* if (errno == ERANGE), then it was an over/underflow
sl@0	1705	* problem, but in this method, we only want to know
sl@0	1706	* yes or no, so bad flow returns 0 (false) and sets
sl@0	1707	* the failVarObj to the string length.
sl@0	1708	*/
sl@0	1709	failat = -1;
sl@0	1710
sl@0	1711	} else if (stop == string1) {
sl@0	1712	/*
sl@0	1713	* In this case, nothing like a number was found
sl@0	1714	*/
sl@0	1715	failat = 0;
sl@0	1716	} else {
sl@0	1717	/*
sl@0	1718	* Assume we sucked up one char per byte
sl@0	1719	* and then we go onto SPACE, since we are
sl@0	1720	* allowed trailing whitespace
sl@0	1721	*/
sl@0	1722	failat = stop - string1;
sl@0	1723	string1 = stop;
sl@0	1724	chcomp = Tcl_UniCharIsSpace;
sl@0	1725	}
sl@0	1726	break;
sl@0	1727	}
sl@0	1728	case STR_IS_LOWER:
sl@0	1729	chcomp = Tcl_UniCharIsLower;
sl@0	1730	break;
sl@0	1731	case STR_IS_PRINT:
sl@0	1732	chcomp = Tcl_UniCharIsPrint;
sl@0	1733	break;
sl@0	1734	case STR_IS_PUNCT:
sl@0	1735	chcomp = Tcl_UniCharIsPunct;
sl@0	1736	break;
sl@0	1737	case STR_IS_SPACE:
sl@0	1738	chcomp = Tcl_UniCharIsSpace;
sl@0	1739	break;
sl@0	1740	case STR_IS_UPPER:
sl@0	1741	chcomp = Tcl_UniCharIsUpper;
sl@0	1742	break;
sl@0	1743	case STR_IS_WORD:
sl@0	1744	chcomp = Tcl_UniCharIsWordChar;
sl@0	1745	break;
sl@0	1746	case STR_IS_XDIGIT: {
sl@0	1747	for (; string1 < end; string1++, failat++) {
sl@0	1748	/* INTL: We assume unicode is bad for this class */
sl@0	1749	if ((((unsigned char )string1) >= 0xC0) \|\|
sl@0	1750	!isxdigit((unsigned char )string1)) {
sl@0	1751	result = 0;
sl@0	1752	break;
sl@0	1753	}
sl@0	1754	}
sl@0	1755	break;
sl@0	1756	}
sl@0	1757	}
sl@0	1758	if (chcomp != NULL) {
sl@0	1759	for (; string1 < end; string1 += length2, failat++) {
sl@0	1760	length2 = TclUtfToUniChar(string1, &ch);
sl@0	1761	if (!chcomp(ch)) {
sl@0	1762	result = 0;
sl@0	1763	break;
sl@0	1764	}
sl@0	1765	}
sl@0	1766	}
sl@0	1767	str_is_done:
sl@0	1768	/*
sl@0	1769	* Only set the failVarObj when we will return 0
sl@0	1770	* and we have indicated a valid fail index (>= 0)
sl@0	1771	*/
sl@0	1772	if ((result == 0) && (failVarObj != NULL)) {
sl@0	1773	Tcl_Obj resPtr, tmpPtr = Tcl_NewIntObj(failat);
sl@0	1774
sl@0	1775	Tcl_IncrRefCount(tmpPtr);
sl@0	1776	resPtr = Tcl_ObjSetVar2(interp, failVarObj, NULL, tmpPtr,
sl@0	1777	TCL_LEAVE_ERR_MSG);
sl@0	1778	Tcl_DecrRefCount(tmpPtr);
sl@0	1779	if (resPtr == NULL) {
sl@0	1780	return TCL_ERROR;
sl@0	1781	}
sl@0	1782	}
sl@0	1783	Tcl_SetBooleanObj(resultPtr, result);
sl@0	1784	break;
sl@0	1785	}
sl@0	1786	case STR_LAST: {
sl@0	1787	Tcl_UniChar ustring1, ustring2, *p;
sl@0	1788	int match, start;
sl@0	1789
sl@0	1790	if (objc < 4 \|\| objc > 5) {
sl@0	1791	Tcl_WrongNumArgs(interp, 2, objv,
sl@0	1792	"subString string ?startIndex?");
sl@0	1793	return TCL_ERROR;
sl@0	1794	}
sl@0	1795
sl@0	1796	/*
sl@0	1797	* We are searching string2 for the sequence string1.
sl@0	1798	*/
sl@0	1799
sl@0	1800	match = -1;
sl@0	1801	start = 0;
sl@0	1802	length2 = -1;
sl@0	1803
sl@0	1804	ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
sl@0	1805	ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
sl@0	1806
sl@0	1807	if (objc == 5) {
sl@0	1808	/*
sl@0	1809	* If a startIndex is specified, we will need to restrict
sl@0	1810	* the string range to that char index in the string
sl@0	1811	*/
sl@0	1812	if (TclGetIntForIndex(interp, objv[4], length2 - 1,
sl@0	1813	&start) != TCL_OK) {
sl@0	1814	return TCL_ERROR;
sl@0	1815	}
sl@0	1816	if (start < 0) {
sl@0	1817	goto str_last_done;
sl@0	1818	} else if (start < length2) {
sl@0	1819	p = ustring2 + start + 1 - length1;
sl@0	1820	} else {
sl@0	1821	p = ustring2 + length2 - length1;
sl@0	1822	}
sl@0	1823	} else {
sl@0	1824	p = ustring2 + length2 - length1;
sl@0	1825	}
sl@0	1826
sl@0	1827	if (length1 > 0) {
sl@0	1828	for (; p >= ustring2; p--) {
sl@0	1829	/*
sl@0	1830	* Scan backwards to find the first character.
sl@0	1831	*/
sl@0	1832	if ((p == ustring1) &&
sl@0	1833	(memcmp((char ) ustring1, (char ) p, (size_t)
sl@0	1834	(length1 * sizeof(Tcl_UniChar))) == 0)) {
sl@0	1835	match = p - ustring2;
sl@0	1836	break;
sl@0	1837	}
sl@0	1838	}
sl@0	1839	}
sl@0	1840
sl@0	1841	str_last_done:
sl@0	1842	Tcl_SetIntObj(resultPtr, match);
sl@0	1843	break;
sl@0	1844	}
sl@0	1845	case STR_BYTELENGTH:
sl@0	1846	case STR_LENGTH: {
sl@0	1847	if (objc != 3) {
sl@0	1848	Tcl_WrongNumArgs(interp, 2, objv, "string");
sl@0	1849	return TCL_ERROR;
sl@0	1850	}
sl@0	1851
sl@0	1852	if ((enum options) index == STR_BYTELENGTH) {
sl@0	1853	(void) Tcl_GetStringFromObj(objv[2], &length1);
sl@0	1854	} else {
sl@0	1855	/*
sl@0	1856	* If we have a ByteArray object, avoid recomputing the
sl@0	1857	* string since the byte array contains one byte per
sl@0	1858	* character. Otherwise, use the Unicode string rep to
sl@0	1859	* calculate the length.
sl@0	1860	*/
sl@0	1861
sl@0	1862	if (objv[2]->typePtr == &tclByteArrayType) {
sl@0	1863	(void) Tcl_GetByteArrayFromObj(objv[2], &length1);
sl@0	1864	} else {
sl@0	1865	length1 = Tcl_GetCharLength(objv[2]);
sl@0	1866	}
sl@0	1867	}
sl@0	1868	Tcl_SetIntObj(resultPtr, length1);
sl@0	1869	break;
sl@0	1870	}
sl@0	1871	case STR_MAP: {
sl@0	1872	int mapElemc, nocase = 0, copySource = 0;
sl@0	1873	Tcl_Obj *mapElemv, sourceObj;
sl@0	1874	Tcl_UniChar ustring1, ustring2, p, end;
sl@0	1875	int (strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar,
sl@0	1876	CONST Tcl_UniChar*, unsigned long));
sl@0	1877
sl@0	1878	if (objc < 4 \|\| objc > 5) {
sl@0	1879	Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string");
sl@0	1880	return TCL_ERROR;
sl@0	1881	}
sl@0	1882
sl@0	1883	if (objc == 5) {
sl@0	1884	string2 = Tcl_GetStringFromObj(objv[2], &length2);
sl@0	1885	if ((length2 > 1) &&
sl@0	1886	strncmp(string2, "-nocase", (size_t) length2) == 0) {
sl@0	1887	nocase = 1;
sl@0	1888	} else {
sl@0	1889	Tcl_AppendStringsToObj(resultPtr, "bad option \"",
sl@0	1890	string2, "\": must be -nocase",
sl@0	1891	(char *) NULL);
sl@0	1892	return TCL_ERROR;
sl@0	1893	}
sl@0	1894	}
sl@0	1895
sl@0	1896	if (Tcl_ListObjGetElements(interp, objv[objc-2], &mapElemc,
sl@0	1897	&mapElemv) != TCL_OK) {
sl@0	1898	return TCL_ERROR;
sl@0	1899	}
sl@0	1900	if (mapElemc == 0) {
sl@0	1901	/*
sl@0	1902	* empty charMap, just return whatever string was given
sl@0	1903	*/
sl@0	1904	Tcl_SetObjResult(interp, objv[objc-1]);
sl@0	1905	return TCL_OK;
sl@0	1906	} else if (mapElemc & 1) {
sl@0	1907	/*
sl@0	1908	* The charMap must be an even number of key/value items
sl@0	1909	*/
sl@0	1910	Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1);
sl@0	1911	return TCL_ERROR;
sl@0	1912	}
sl@0	1913
sl@0	1914	/*
sl@0	1915	* Take a copy of the source string object if it is the
sl@0	1916	* same as the map string to cut out nasty sharing
sl@0	1917	* crashes. [Bug 1018562]
sl@0	1918	*/
sl@0	1919	if (objv[objc-2] == objv[objc-1]) {
sl@0	1920	sourceObj = Tcl_DuplicateObj(objv[objc-1]);
sl@0	1921	copySource = 1;
sl@0	1922	} else {
sl@0	1923	sourceObj = objv[objc-1];
sl@0	1924	}
sl@0	1925	ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1);
sl@0	1926	if (length1 == 0) {
sl@0	1927	/*
sl@0	1928	* Empty input string, just stop now
sl@0	1929	*/
sl@0	1930	if (copySource) {
sl@0	1931	Tcl_DecrRefCount(sourceObj);
sl@0	1932	}
sl@0	1933	break;
sl@0	1934	}
sl@0	1935	end = ustring1 + length1;
sl@0	1936
sl@0	1937	strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
sl@0	1938
sl@0	1939	/*
sl@0	1940	* Force result to be Unicode
sl@0	1941	*/
sl@0	1942	Tcl_SetUnicodeObj(resultPtr, ustring1, 0);
sl@0	1943
sl@0	1944	if (mapElemc == 2) {
sl@0	1945	/*
sl@0	1946	* Special case for one map pair which avoids the extra
sl@0	1947	* for loop and extra calls to get Unicode data. The
sl@0	1948	* algorithm is otherwise identical to the multi-pair case.
sl@0	1949	* This will be >30% faster on larger strings.
sl@0	1950	*/
sl@0	1951	int mapLen;
sl@0	1952	Tcl_UniChar *mapString, u2lc;
sl@0	1953
sl@0	1954	ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
sl@0	1955	p = ustring1;
sl@0	1956	if ((length2 > length1) \|\| (length2 == 0)) {
sl@0	1957	/* match string is either longer than input or empty */
sl@0	1958	ustring1 = end;
sl@0	1959	} else {
sl@0	1960	mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen);
sl@0	1961	u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0);
sl@0	1962	for (; ustring1 < end; ustring1++) {
sl@0	1963	if (((ustring1 == ustring2) \|\|
sl@0	1964	(nocase && (Tcl_UniCharToLower(*ustring1) ==
sl@0	1965	u2lc))) &&
sl@0	1966	((length2 == 1) \|\| strCmpFn(ustring1, ustring2,
sl@0	1967	(unsigned long) length2) == 0)) {
sl@0	1968	if (p != ustring1) {
sl@0	1969	Tcl_AppendUnicodeToObj(resultPtr, p,
sl@0	1970	ustring1 - p);
sl@0	1971	p = ustring1 + length2;
sl@0	1972	} else {
sl@0	1973	p += length2;
sl@0	1974	}
sl@0	1975	ustring1 = p - 1;
sl@0	1976
sl@0	1977	Tcl_AppendUnicodeToObj(resultPtr, mapString,
sl@0	1978	mapLen);
sl@0	1979	}
sl@0	1980	}
sl@0	1981	}
sl@0	1982	} else {
sl@0	1983	Tcl_UniChar *mapStrings, u2lc = NULL;
sl@0	1984	int *mapLens;
sl@0	1985	/*
sl@0	1986	* Precompute pointers to the unicode string and length.
sl@0	1987	* This saves us repeated function calls later,
sl@0	1988	* significantly speeding up the algorithm. We only need
sl@0	1989	* the lowercase first char in the nocase case.
sl@0	1990	*/
sl@0	1991	mapStrings = (Tcl_UniChar *) ckalloc((mapElemc 2)
sl@0	1992	* sizeof(Tcl_UniChar *));
sl@0	1993	mapLens = (int ) ckalloc((mapElemc 2) * sizeof(int));
sl@0	1994	if (nocase) {
sl@0	1995	u2lc = (Tcl_UniChar *)
sl@0	1996	ckalloc((mapElemc) * sizeof(Tcl_UniChar));
sl@0	1997	}
sl@0	1998	for (index = 0; index < mapElemc; index++) {
sl@0	1999	mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
sl@0	2000	&(mapLens[index]));
sl@0	2001	if (nocase && ((index % 2) == 0)) {
sl@0	2002	u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]);
sl@0	2003	}
sl@0	2004	}
sl@0	2005	for (p = ustring1; ustring1 < end; ustring1++) {
sl@0	2006	for (index = 0; index < mapElemc; index += 2) {
sl@0	2007	/*
sl@0	2008	* Get the key string to match on.
sl@0	2009	*/
sl@0	2010	ustring2 = mapStrings[index];
sl@0	2011	length2 = mapLens[index];
sl@0	2012	if ((length2 > 0) && ((ustring1 == ustring2) \|\|
sl@0	2013	(nocase && (Tcl_UniCharToLower(*ustring1) ==
sl@0	2014	u2lc[index/2]))) &&
sl@0	2015	/* restrict max compare length */
sl@0	2016	((end - ustring1) >= length2) &&
sl@0	2017	((length2 == 1) \|\| strCmpFn(ustring2, ustring1,
sl@0	2018	(unsigned long) length2) == 0)) {
sl@0	2019	if (p != ustring1) {
sl@0	2020	/*
sl@0	2021	* Put the skipped chars onto the result first
sl@0	2022	*/
sl@0	2023	Tcl_AppendUnicodeToObj(resultPtr, p,
sl@0	2024	ustring1 - p);
sl@0	2025	p = ustring1 + length2;
sl@0	2026	} else {
sl@0	2027	p += length2;
sl@0	2028	}
sl@0	2029	/*
sl@0	2030	* Adjust len to be full length of matched string
sl@0	2031	*/
sl@0	2032	ustring1 = p - 1;
sl@0	2033
sl@0	2034	/*
sl@0	2035	* Append the map value to the unicode string
sl@0	2036	*/
sl@0	2037	Tcl_AppendUnicodeToObj(resultPtr,
sl@0	2038	mapStrings[index+1], mapLens[index+1]);
sl@0	2039	break;
sl@0	2040	}
sl@0	2041	}
sl@0	2042	}
sl@0	2043	ckfree((char *) mapStrings);
sl@0	2044	ckfree((char *) mapLens);
sl@0	2045	if (nocase) {
sl@0	2046	ckfree((char *) u2lc);
sl@0	2047	}
sl@0	2048	}
sl@0	2049	if (p != ustring1) {
sl@0	2050	/*
sl@0	2051	* Put the rest of the unmapped chars onto result
sl@0	2052	*/
sl@0	2053	Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
sl@0	2054	}
sl@0	2055	if (copySource) {
sl@0	2056	Tcl_DecrRefCount(sourceObj);
sl@0	2057	}
sl@0	2058	break;
sl@0	2059	}
sl@0	2060	case STR_MATCH: {
sl@0	2061	Tcl_UniChar ustring1, ustring2;
sl@0	2062	int nocase = 0;
sl@0	2063
sl@0	2064	if (objc < 4 \|\| objc > 5) {
sl@0	2065	Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string");
sl@0	2066	return TCL_ERROR;
sl@0	2067	}
sl@0	2068
sl@0	2069	if (objc == 5) {
sl@0	2070	string2 = Tcl_GetStringFromObj(objv[2], &length2);
sl@0	2071	if ((length2 > 1) &&
sl@0	2072	strncmp(string2, "-nocase", (size_t) length2) == 0) {
sl@0	2073	nocase = 1;
sl@0	2074	} else {
sl@0	2075	Tcl_AppendStringsToObj(resultPtr, "bad option \"",
sl@0	2076	string2, "\": must be -nocase",
sl@0	2077	(char *) NULL);
sl@0	2078	return TCL_ERROR;
sl@0	2079	}
sl@0	2080	}
sl@0	2081	ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1);
sl@0	2082	ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2);
sl@0	2083	Tcl_SetBooleanObj(resultPtr, TclUniCharMatch(ustring1, length1,
sl@0	2084	ustring2, length2, nocase));
sl@0	2085	break;
sl@0	2086	}
sl@0	2087	case STR_RANGE: {
sl@0	2088	int first, last;
sl@0	2089
sl@0	2090	if (objc != 5) {
sl@0	2091	Tcl_WrongNumArgs(interp, 2, objv, "string first last");
sl@0	2092	return TCL_ERROR;
sl@0	2093	}
sl@0	2094
sl@0	2095	/*
sl@0	2096	* If we have a ByteArray object, avoid indexing in the
sl@0	2097	* Utf string since the byte array contains one byte per
sl@0	2098	* character. Otherwise, use the Unicode string rep to
sl@0	2099	* get the range.
sl@0	2100	*/
sl@0	2101
sl@0	2102	if (objv[2]->typePtr == &tclByteArrayType) {
sl@0	2103	string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1);
sl@0	2104	length1--;
sl@0	2105	} else {
sl@0	2106	/*
sl@0	2107	* Get the length in actual characters.
sl@0	2108	*/
sl@0	2109	string1 = NULL;
sl@0	2110	length1 = Tcl_GetCharLength(objv[2]) - 1;
sl@0	2111	}
sl@0	2112
sl@0	2113	if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
sl@0	2114	\|\| (TclGetIntForIndex(interp, objv[4], length1,
sl@0	2115	&last) != TCL_OK)) {
sl@0	2116	return TCL_ERROR;
sl@0	2117	}
sl@0	2118
sl@0	2119	if (first < 0) {
sl@0	2120	first = 0;
sl@0	2121	}
sl@0	2122	if (last >= length1) {
sl@0	2123	last = length1;
sl@0	2124	}
sl@0	2125	if (last >= first) {
sl@0	2126	if (string1 != NULL) {
sl@0	2127	int numBytes = last - first + 1;
sl@0	2128	resultPtr = Tcl_NewByteArrayObj(
sl@0	2129	(unsigned char *) &string1[first], numBytes);
sl@0	2130	Tcl_SetObjResult(interp, resultPtr);
sl@0	2131	} else {
sl@0	2132	Tcl_SetObjResult(interp,
sl@0	2133	Tcl_GetRange(objv[2], first, last));
sl@0	2134	}
sl@0	2135	}
sl@0	2136	break;
sl@0	2137	}
sl@0	2138	case STR_REPEAT: {
sl@0	2139	int count;
sl@0	2140
sl@0	2141	if (objc != 4) {
sl@0	2142	Tcl_WrongNumArgs(interp, 2, objv, "string count");
sl@0	2143	return TCL_ERROR;
sl@0	2144	}
sl@0	2145
sl@0	2146	if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) {
sl@0	2147	return TCL_ERROR;
sl@0	2148	}
sl@0	2149
sl@0	2150	if (count == 1) {
sl@0	2151	Tcl_SetObjResult(interp, objv[2]);
sl@0	2152	} else if (count > 1) {
sl@0	2153	string1 = Tcl_GetStringFromObj(objv[2], &length1);
sl@0	2154	if (length1 > 0) {
sl@0	2155	/*
sl@0	2156	* Only build up a string that has data. Instead of
sl@0	2157	* building it up with repeated appends, we just allocate
sl@0	2158	* the necessary space once and copy the string value in.
sl@0	2159	* Check for overflow with back-division. [Bug #714106]
sl@0	2160	*/
sl@0	2161	length2 = length1 * count;
sl@0	2162	if ((length2 / count) != length1) {
sl@0	2163	char buf[TCL_INTEGER_SPACE+1];
sl@0	2164	sprintf(buf, "%d", INT_MAX);
sl@0	2165	Tcl_AppendStringsToObj(resultPtr,
sl@0	2166	"string size overflow, must be less than ",
sl@0	2167	buf, (char *) NULL);
sl@0	2168	return TCL_ERROR;
sl@0	2169	}
sl@0	2170	/*
sl@0	2171	* Include space for the NULL
sl@0	2172	*/
sl@0	2173	string2 = (char *) ckalloc((size_t) length2+1);
sl@0	2174	for (index = 0; index < count; index++) {
sl@0	2175	memcpy(string2 + (length1 * index), string1,
sl@0	2176	(size_t) length1);
sl@0	2177	}
sl@0	2178	string2[length2] = '\0';
sl@0	2179	/*
sl@0	2180	* We have to directly assign this instead of using
sl@0	2181	* Tcl_SetStringObj (and indirectly TclInitStringRep)
sl@0	2182	* because that makes another copy of the data.
sl@0	2183	*/
sl@0	2184	resultPtr = Tcl_NewObj();
sl@0	2185	resultPtr->bytes = string2;
sl@0	2186	resultPtr->length = length2;
sl@0	2187	Tcl_SetObjResult(interp, resultPtr);
sl@0	2188	}
sl@0	2189	}
sl@0	2190	break;
sl@0	2191	}
sl@0	2192	case STR_REPLACE: {
sl@0	2193	Tcl_UniChar *ustring1;
sl@0	2194	int first, last;
sl@0	2195
sl@0	2196	if (objc < 5 \|\| objc > 6) {
sl@0	2197	Tcl_WrongNumArgs(interp, 2, objv,
sl@0	2198	"string first last ?string?");
sl@0	2199	return TCL_ERROR;
sl@0	2200	}
sl@0	2201
sl@0	2202	ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
sl@0	2203	length1--;
sl@0	2204
sl@0	2205	if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
sl@0	2206	\|\| (TclGetIntForIndex(interp, objv[4], length1,
sl@0	2207	&last) != TCL_OK)) {
sl@0	2208	return TCL_ERROR;
sl@0	2209	}
sl@0	2210
sl@0	2211	if ((last < first) \|\| (last < 0) \|\| (first > length1)) {
sl@0	2212	Tcl_SetObjResult(interp, objv[2]);
sl@0	2213	} else {
sl@0	2214	if (first < 0) {
sl@0	2215	first = 0;
sl@0	2216	}
sl@0	2217
sl@0	2218	Tcl_SetUnicodeObj(resultPtr, ustring1, first);
sl@0	2219	if (objc == 6) {
sl@0	2220	Tcl_AppendObjToObj(resultPtr, objv[5]);
sl@0	2221	}
sl@0	2222	if (last < length1) {
sl@0	2223	Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1,
sl@0	2224	length1 - last);
sl@0	2225	}
sl@0	2226	}
sl@0	2227	break;
sl@0	2228	}
sl@0	2229	case STR_TOLOWER:
sl@0	2230	case STR_TOUPPER:
sl@0	2231	case STR_TOTITLE:
sl@0	2232	if (objc < 3 \|\| objc > 5) {
sl@0	2233	Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?");
sl@0	2234	return TCL_ERROR;
sl@0	2235	}
sl@0	2236
sl@0	2237	string1 = Tcl_GetStringFromObj(objv[2], &length1);
sl@0	2238
sl@0	2239	if (objc == 3) {
sl@0	2240	/*
sl@0	2241	* Since the result object is not a shared object, it is
sl@0	2242	* safe to copy the string into the result and do the
sl@0	2243	* conversion in place. The conversion may change the length
sl@0	2244	* of the string, so reset the length after conversion.
sl@0	2245	*/
sl@0	2246
sl@0	2247	Tcl_SetStringObj(resultPtr, string1, length1);
sl@0	2248	if ((enum options) index == STR_TOLOWER) {
sl@0	2249	length1 = Tcl_UtfToLower(Tcl_GetString(resultPtr));
sl@0	2250	} else if ((enum options) index == STR_TOUPPER) {
sl@0	2251	length1 = Tcl_UtfToUpper(Tcl_GetString(resultPtr));
sl@0	2252	} else {
sl@0	2253	length1 = Tcl_UtfToTitle(Tcl_GetString(resultPtr));
sl@0	2254	}
sl@0	2255	Tcl_SetObjLength(resultPtr, length1);
sl@0	2256	} else {
sl@0	2257	int first, last;
sl@0	2258	CONST char start, end;
sl@0	2259
sl@0	2260	length1 = Tcl_NumUtfChars(string1, length1) - 1;
sl@0	2261	if (TclGetIntForIndex(interp, objv[3], length1,
sl@0	2262	&first) != TCL_OK) {
sl@0	2263	return TCL_ERROR;
sl@0	2264	}
sl@0	2265	if (first < 0) {
sl@0	2266	first = 0;
sl@0	2267	}
sl@0	2268	last = first;
sl@0	2269	if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1,
sl@0	2270	&last) != TCL_OK)) {
sl@0	2271	return TCL_ERROR;
sl@0	2272	}
sl@0	2273	if (last >= length1) {
sl@0	2274	last = length1;
sl@0	2275	}
sl@0	2276	if (last < first) {
sl@0	2277	Tcl_SetObjResult(interp, objv[2]);
sl@0	2278	break;
sl@0	2279	}
sl@0	2280	start = Tcl_UtfAtIndex(string1, first);
sl@0	2281	end = Tcl_UtfAtIndex(start, last - first + 1);
sl@0	2282	length2 = end-start;
sl@0	2283	string2 = ckalloc((size_t) length2+1);
sl@0	2284	memcpy(string2, start, (size_t) length2);
sl@0	2285	string2[length2] = '\0';
sl@0	2286	if ((enum options) index == STR_TOLOWER) {
sl@0	2287	length2 = Tcl_UtfToLower(string2);
sl@0	2288	} else if ((enum options) index == STR_TOUPPER) {
sl@0	2289	length2 = Tcl_UtfToUpper(string2);
sl@0	2290	} else {
sl@0	2291	length2 = Tcl_UtfToTitle(string2);
sl@0	2292	}
sl@0	2293	Tcl_SetStringObj(resultPtr, string1, start - string1);
sl@0	2294	Tcl_AppendToObj(resultPtr, string2, length2);
sl@0	2295	Tcl_AppendToObj(resultPtr, end, -1);
sl@0	2296	ckfree(string2);
sl@0	2297	}
sl@0	2298	break;
sl@0	2299
sl@0	2300	case STR_TRIM: {
sl@0	2301	Tcl_UniChar ch, trim;
sl@0	2302	register CONST char p, end;
sl@0	2303	char check, checkEnd;
sl@0	2304	int offset;
sl@0	2305
sl@0	2306	left = 1;
sl@0	2307	right = 1;
sl@0	2308
sl@0	2309	dotrim:
sl@0	2310	if (objc == 4) {
sl@0	2311	string2 = Tcl_GetStringFromObj(objv[3], &length2);
sl@0	2312	} else if (objc == 3) {
sl@0	2313	string2 = " \t\n\r";
sl@0	2314	length2 = strlen(string2);
sl@0	2315	} else {
sl@0	2316	Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?");
sl@0	2317	return TCL_ERROR;
sl@0	2318	}
sl@0	2319	string1 = Tcl_GetStringFromObj(objv[2], &length1);
sl@0	2320	checkEnd = string2 + length2;
sl@0	2321
sl@0	2322	if (left) {
sl@0	2323	end = string1 + length1;
sl@0	2324	/*
sl@0	2325	* The outer loop iterates over the string. The inner
sl@0	2326	* loop iterates over the trim characters. The loops
sl@0	2327	* terminate as soon as a non-trim character is discovered
sl@0	2328	* and string1 is left pointing at the first non-trim
sl@0	2329	* character.
sl@0	2330	*/
sl@0	2331
sl@0	2332	for (p = string1; p < end; p += offset) {
sl@0	2333	offset = TclUtfToUniChar(p, &ch);
sl@0	2334
sl@0	2335	for (check = string2; ; ) {
sl@0	2336	if (check >= checkEnd) {
sl@0	2337	p = end;
sl@0	2338	break;
sl@0	2339	}
sl@0	2340	check += TclUtfToUniChar(check, &trim);
sl@0	2341	if (ch == trim) {
sl@0	2342	length1 -= offset;
sl@0	2343	string1 += offset;
sl@0	2344	break;
sl@0	2345	}
sl@0	2346	}
sl@0	2347	}
sl@0	2348	}
sl@0	2349	if (right) {
sl@0	2350	end = string1;
sl@0	2351
sl@0	2352	/*
sl@0	2353	* The outer loop iterates over the string. The inner
sl@0	2354	* loop iterates over the trim characters. The loops
sl@0	2355	* terminate as soon as a non-trim character is discovered
sl@0	2356	* and length1 marks the last non-trim character.
sl@0	2357	*/
sl@0	2358
sl@0	2359	for (p = string1 + length1; p > end; ) {
sl@0	2360	p = Tcl_UtfPrev(p, string1);
sl@0	2361	offset = TclUtfToUniChar(p, &ch);
sl@0	2362	for (check = string2; ; ) {
sl@0	2363	if (check >= checkEnd) {
sl@0	2364	p = end;
sl@0	2365	break;
sl@0	2366	}
sl@0	2367	check += TclUtfToUniChar(check, &trim);
sl@0	2368	if (ch == trim) {
sl@0	2369	length1 -= offset;
sl@0	2370	break;
sl@0	2371	}
sl@0	2372	}
sl@0	2373	}
sl@0	2374	}
sl@0	2375	Tcl_SetStringObj(resultPtr, string1, length1);
sl@0	2376	break;
sl@0	2377	}
sl@0	2378	case STR_TRIMLEFT: {
sl@0	2379	left = 1;
sl@0	2380	right = 0;
sl@0	2381	goto dotrim;
sl@0	2382	}
sl@0	2383	case STR_TRIMRIGHT: {
sl@0	2384	left = 0;
sl@0	2385	right = 1;
sl@0	2386	goto dotrim;
sl@0	2387	}
sl@0	2388	case STR_WORDEND: {
sl@0	2389	int cur;
sl@0	2390	Tcl_UniChar ch;
sl@0	2391	CONST char p, end;
sl@0	2392	int numChars;
sl@0	2393
sl@0	2394	if (objc != 4) {
sl@0	2395	Tcl_WrongNumArgs(interp, 2, objv, "string index");
sl@0	2396	return TCL_ERROR;
sl@0	2397	}
sl@0	2398
sl@0	2399	string1 = Tcl_GetStringFromObj(objv[2], &length1);
sl@0	2400	numChars = Tcl_NumUtfChars(string1, length1);
sl@0	2401	if (TclGetIntForIndex(interp, objv[3], numChars-1,
sl@0	2402	&index) != TCL_OK) {
sl@0	2403	return TCL_ERROR;
sl@0	2404	}
sl@0	2405	if (index < 0) {
sl@0	2406	index = 0;
sl@0	2407	}
sl@0	2408	if (index < numChars) {
sl@0	2409	p = Tcl_UtfAtIndex(string1, index);
sl@0	2410	end = string1+length1;
sl@0	2411	for (cur = index; p < end; cur++) {
sl@0	2412	p += TclUtfToUniChar(p, &ch);
sl@0	2413	if (!Tcl_UniCharIsWordChar(ch)) {
sl@0	2414	break;
sl@0	2415	}
sl@0	2416	}
sl@0	2417	if (cur == index) {
sl@0	2418	cur++;
sl@0	2419	}
sl@0	2420	} else {
sl@0	2421	cur = numChars;
sl@0	2422	}
sl@0	2423	Tcl_SetIntObj(resultPtr, cur);
sl@0	2424	break;
sl@0	2425	}
sl@0	2426	case STR_WORDSTART: {
sl@0	2427	int cur;
sl@0	2428	Tcl_UniChar ch;
sl@0	2429	CONST char *p;
sl@0	2430	int numChars;
sl@0	2431
sl@0	2432	if (objc != 4) {
sl@0	2433	Tcl_WrongNumArgs(interp, 2, objv, "string index");
sl@0	2434	return TCL_ERROR;
sl@0	2435	}
sl@0	2436
sl@0	2437	string1 = Tcl_GetStringFromObj(objv[2], &length1);
sl@0	2438	numChars = Tcl_NumUtfChars(string1, length1);
sl@0	2439	if (TclGetIntForIndex(interp, objv[3], numChars-1,
sl@0	2440	&index) != TCL_OK) {
sl@0	2441	return TCL_ERROR;
sl@0	2442	}
sl@0	2443	if (index >= numChars) {
sl@0	2444	index = numChars - 1;
sl@0	2445	}
sl@0	2446	cur = 0;
sl@0	2447	if (index > 0) {
sl@0	2448	p = Tcl_UtfAtIndex(string1, index);
sl@0	2449	for (cur = index; cur >= 0; cur--) {
sl@0	2450	TclUtfToUniChar(p, &ch);
sl@0	2451	if (!Tcl_UniCharIsWordChar(ch)) {
sl@0	2452	break;
sl@0	2453	}
sl@0	2454	p = Tcl_UtfPrev(p, string1);
sl@0	2455	}
sl@0	2456	if (cur != index) {
sl@0	2457	cur += 1;
sl@0	2458	}
sl@0	2459	}
sl@0	2460	Tcl_SetIntObj(resultPtr, cur);
sl@0	2461	break;
sl@0	2462	}
sl@0	2463	}
sl@0	2464	return TCL_OK;
sl@0	2465	}
sl@0	2466
sl@0	2467	/*
sl@0	2468	*----------------------------------------------------------------------
sl@0	2469	*
sl@0	2470	* Tcl_SubstObjCmd --
sl@0	2471	*
sl@0	2472	* This procedure is invoked to process the "subst" Tcl command.
sl@0	2473	* See the user documentation for details on what it does. This
sl@0	2474	* command relies on Tcl_SubstObj() for its implementation.
sl@0	2475	*
sl@0	2476	* Results:
sl@0	2477	* A standard Tcl result.
sl@0	2478	*
sl@0	2479	* Side effects:
sl@0	2480	* See the user documentation.
sl@0	2481	*
sl@0	2482	*----------------------------------------------------------------------
sl@0	2483	*/
sl@0	2484
sl@0	2485	/* ARGSUSED */
sl@0	2486	int
sl@0	2487	Tcl_SubstObjCmd(dummy, interp, objc, objv)
sl@0	2488	ClientData dummy; /* Not used. */
sl@0	2489	Tcl_Interp interp; / Current interpreter. */
sl@0	2490	int objc; /* Number of arguments. */
sl@0	2491	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2492	{
sl@0	2493	static CONST char *substOptions[] = {
sl@0	2494	"-nobackslashes", "-nocommands", "-novariables", (char *) NULL
sl@0	2495	};
sl@0	2496	enum substOptions {
sl@0	2497	SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
sl@0	2498	};
sl@0	2499	Tcl_Obj *resultPtr;
sl@0	2500	int optionIndex, flags, i;
sl@0	2501
sl@0	2502	/*
sl@0	2503	* Parse command-line options.
sl@0	2504	*/
sl@0	2505
sl@0	2506	flags = TCL_SUBST_ALL;
sl@0	2507	for (i = 1; i < (objc-1); i++) {
sl@0	2508	if (Tcl_GetIndexFromObj(interp, objv[i], substOptions,
sl@0	2509	"switch", 0, &optionIndex) != TCL_OK) {
sl@0	2510
sl@0	2511	return TCL_ERROR;
sl@0	2512	}
sl@0	2513	switch (optionIndex) {
sl@0	2514	case SUBST_NOBACKSLASHES: {
sl@0	2515	flags &= ~TCL_SUBST_BACKSLASHES;
sl@0	2516	break;
sl@0	2517	}
sl@0	2518	case SUBST_NOCOMMANDS: {
sl@0	2519	flags &= ~TCL_SUBST_COMMANDS;
sl@0	2520	break;
sl@0	2521	}
sl@0	2522	case SUBST_NOVARS: {
sl@0	2523	flags &= ~TCL_SUBST_VARIABLES;
sl@0	2524	break;
sl@0	2525	}
sl@0	2526	default: {
sl@0	2527	panic("Tcl_SubstObjCmd: bad option index to SubstOptions");
sl@0	2528	}
sl@0	2529	}
sl@0	2530	}
sl@0	2531	if (i != (objc-1)) {
sl@0	2532	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	2533	"?-nobackslashes? ?-nocommands? ?-novariables? string");
sl@0	2534	return TCL_ERROR;
sl@0	2535	}
sl@0	2536
sl@0	2537	/*
sl@0	2538	* Perform the substitution.
sl@0	2539	*/
sl@0	2540	resultPtr = Tcl_SubstObj(interp, objv[i], flags);
sl@0	2541
sl@0	2542	if (resultPtr == NULL) {
sl@0	2543	return TCL_ERROR;
sl@0	2544	}
sl@0	2545	Tcl_SetObjResult(interp, resultPtr);
sl@0	2546	return TCL_OK;
sl@0	2547	}
sl@0	2548
sl@0	2549	/*
sl@0	2550	*----------------------------------------------------------------------
sl@0	2551	*
sl@0	2552	* Tcl_SubstObj --
sl@0	2553	*
sl@0	2554	* This function performs the substitutions specified on the
sl@0	2555	* given string as described in the user documentation for the
sl@0	2556	* "subst" Tcl command. This code is heavily based on an
sl@0	2557	* implementation by Andrew Payne. Note that if a command
sl@0	2558	* substitution returns TCL_CONTINUE or TCL_RETURN from its
sl@0	2559	* evaluation and is not completely well-formed, the results are
sl@0	2560	* not defined (or at least hard to characterise.) This fault
sl@0	2561	* will be fixed at some point, but the cost of the only sane
sl@0	2562	* fix (well-formedness check first) is such that you need to
sl@0	2563	* "precompile and cache" to stop everyone from being hit with
sl@0	2564	* the consequences every time through. Note that the current
sl@0	2565	* behaviour is not a security hole; it just restarts parsing
sl@0	2566	* the string following the substitution in a mildly surprising
sl@0	2567	* place, and it is a very bad idea to count on this remaining
sl@0	2568	* the same in future...
sl@0	2569	*
sl@0	2570	* Results:
sl@0	2571	* A Tcl_Obj* containing the substituted string, or NULL to
sl@0	2572	* indicate that an error occurred.
sl@0	2573	*
sl@0	2574	* Side effects:
sl@0	2575	* See the user documentation.
sl@0	2576	*
sl@0	2577	*----------------------------------------------------------------------
sl@0	2578	*/
sl@0	2579
sl@0	2580	EXPORT_C Tcl_Obj *
sl@0	2581	Tcl_SubstObj(interp, objPtr, flags)
sl@0	2582	Tcl_Interp *interp;
sl@0	2583	Tcl_Obj *objPtr;
sl@0	2584	int flags;
sl@0	2585	{
sl@0	2586	Tcl_Obj *resultObj;
sl@0	2587	char p, old;
sl@0	2588	int length;
sl@0	2589
sl@0	2590	old = p = Tcl_GetStringFromObj(objPtr, &length);
sl@0	2591	resultObj = Tcl_NewStringObj("", 0);
sl@0	2592	while (length) {
sl@0	2593	switch (*p) {
sl@0	2594	case '\\':
sl@0	2595	if (flags & TCL_SUBST_BACKSLASHES) {
sl@0	2596	char buf[TCL_UTF_MAX];
sl@0	2597	int count;
sl@0	2598
sl@0	2599	if (p != old) {
sl@0	2600	Tcl_AppendToObj(resultObj, old, p-old);
sl@0	2601	}
sl@0	2602	Tcl_AppendToObj(resultObj, buf,
sl@0	2603	Tcl_UtfBackslash(p, &count, buf));
sl@0	2604	p += count; length -= count;
sl@0	2605	old = p;
sl@0	2606	} else {
sl@0	2607	p++; length--;
sl@0	2608	}
sl@0	2609	break;
sl@0	2610
sl@0	2611	case '$':
sl@0	2612	if (flags & TCL_SUBST_VARIABLES) {
sl@0	2613	Tcl_Parse parse;
sl@0	2614	int code;
sl@0	2615
sl@0	2616	/*
sl@0	2617	* Code is simpler overall if we (effectively) inline
sl@0	2618	* Tcl_ParseVar, particularly as that allows us to use
sl@0	2619	* a non-string interface when we come to appending
sl@0	2620	* the variable contents to the result object. There
sl@0	2621	* are a few other optimisations that doing this
sl@0	2622	* enables (like being able to continue the run of
sl@0	2623	* unsubstituted characters straight through if a '$'
sl@0	2624	* does not precede a variable name.)
sl@0	2625	*/
sl@0	2626	if (Tcl_ParseVarName(interp, p, -1, &parse, 0) != TCL_OK) {
sl@0	2627	goto errorResult;
sl@0	2628	}
sl@0	2629	if (parse.numTokens == 1) {
sl@0	2630	/*
sl@0	2631	* There isn't a variable name after all: the $ is
sl@0	2632	* just a $.
sl@0	2633	*/
sl@0	2634	p++; length--;
sl@0	2635	break;
sl@0	2636	}
sl@0	2637	if (p != old) {
sl@0	2638	Tcl_AppendToObj(resultObj, old, p-old);
sl@0	2639	}
sl@0	2640	p += parse.tokenPtr->size;
sl@0	2641	length -= parse.tokenPtr->size;
sl@0	2642	code = Tcl_EvalTokensStandard(interp, parse.tokenPtr,
sl@0	2643	parse.numTokens);
sl@0	2644	if (code == TCL_ERROR) {
sl@0	2645	goto errorResult;
sl@0	2646	}
sl@0	2647	if (code == TCL_BREAK) {
sl@0	2648	Tcl_ResetResult(interp);
sl@0	2649	return resultObj;
sl@0	2650	}
sl@0	2651	if (code != TCL_CONTINUE) {
sl@0	2652	Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
sl@0	2653	}
sl@0	2654	Tcl_ResetResult(interp);
sl@0	2655	old = p;
sl@0	2656	} else {
sl@0	2657	p++; length--;
sl@0	2658	}
sl@0	2659	break;
sl@0	2660
sl@0	2661	case '[':
sl@0	2662	if (flags & TCL_SUBST_COMMANDS) {
sl@0	2663	Interp iPtr = (Interp ) interp;
sl@0	2664	int code;
sl@0	2665
sl@0	2666	if (p != old) {
sl@0	2667	Tcl_AppendToObj(resultObj, old, p-old);
sl@0	2668	}
sl@0	2669	iPtr->evalFlags = TCL_BRACKET_TERM;
sl@0	2670	iPtr->numLevels++;
sl@0	2671	code = TclInterpReady(interp);
sl@0	2672	if (code == TCL_OK) {
sl@0	2673	code = Tcl_EvalEx(interp, p+1, -1, 0);
sl@0	2674	}
sl@0	2675	iPtr->numLevels--;
sl@0	2676	switch (code) {
sl@0	2677	case TCL_ERROR:
sl@0	2678	goto errorResult;
sl@0	2679	case TCL_BREAK:
sl@0	2680	Tcl_ResetResult(interp);
sl@0	2681	return resultObj;
sl@0	2682	default:
sl@0	2683	Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
sl@0	2684	case TCL_CONTINUE:
sl@0	2685	Tcl_ResetResult(interp);
sl@0	2686	old = p = (p+1 + iPtr->termOffset + 1);
sl@0	2687	length -= (iPtr->termOffset + 2);
sl@0	2688	}
sl@0	2689	} else {
sl@0	2690	p++; length--;
sl@0	2691	}
sl@0	2692	break;
sl@0	2693	default:
sl@0	2694	p++; length--;
sl@0	2695	break;
sl@0	2696	}
sl@0	2697	}
sl@0	2698	if (p != old) {
sl@0	2699	Tcl_AppendToObj(resultObj, old, p-old);
sl@0	2700	}
sl@0	2701	return resultObj;
sl@0	2702
sl@0	2703	errorResult:
sl@0	2704	Tcl_DecrRefCount(resultObj);
sl@0	2705	return NULL;
sl@0	2706	}
sl@0	2707
sl@0	2708	/*
sl@0	2709	*----------------------------------------------------------------------
sl@0	2710	*
sl@0	2711	* Tcl_SwitchObjCmd --
sl@0	2712	*
sl@0	2713	* This object-based procedure is invoked to process the "switch" Tcl
sl@0	2714	* command. See the user documentation for details on what it does.
sl@0	2715	*
sl@0	2716	* Results:
sl@0	2717	* A standard Tcl object result.
sl@0	2718	*
sl@0	2719	* Side effects:
sl@0	2720	* See the user documentation.
sl@0	2721	*
sl@0	2722	*----------------------------------------------------------------------
sl@0	2723	*/
sl@0	2724
sl@0	2725	/* ARGSUSED */
sl@0	2726	int
sl@0	2727	Tcl_SwitchObjCmd(dummy, interp, objc, objv)
sl@0	2728	ClientData dummy; /* Not used. */
sl@0	2729	Tcl_Interp interp; / Current interpreter. */
sl@0	2730	int objc; /* Number of arguments. */
sl@0	2731	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2732	{
sl@0	2733	int i, j, index, mode, matched, result, splitObjs;
sl@0	2734	char string, pattern;
sl@0	2735	Tcl_Obj *stringObj;
sl@0	2736	Tcl_Obj CONST savedObjv = objv;
sl@0	2737	#ifdef TCL_TIP280
sl@0	2738	Interp* iPtr = (Interp*) interp;
sl@0	2739	int pc = 0;
sl@0	2740	int bidx = 0; /* Index of body argument */
sl@0	2741	Tcl_Obj* blist = NULL; /* List obj which is the body */
sl@0	2742	CmdFrame ctx; /* Copy of the topmost cmdframe,
sl@0	2743	* to allow us to mess with the
sl@0	2744	* line information */
sl@0	2745	#endif
sl@0	2746	static CONST char *options[] = {
sl@0	2747	"-exact", "-glob", "-regexp", "--",
sl@0	2748	NULL
sl@0	2749	};
sl@0	2750	enum options {
sl@0	2751	OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST
sl@0	2752	};
sl@0	2753
sl@0	2754	mode = OPT_EXACT;
sl@0	2755	for (i = 1; i < objc; i++) {
sl@0	2756	string = Tcl_GetString(objv[i]);
sl@0	2757	if (string[0] != '-') {
sl@0	2758	break;
sl@0	2759	}
sl@0	2760	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
sl@0	2761	&index) != TCL_OK) {
sl@0	2762	return TCL_ERROR;
sl@0	2763	}
sl@0	2764	if (index == OPT_LAST) {
sl@0	2765	i++;
sl@0	2766	break;
sl@0	2767	}
sl@0	2768	mode = index;
sl@0	2769	}
sl@0	2770
sl@0	2771	if (objc - i < 2) {
sl@0	2772	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	2773	"?switches? string pattern body ... ?default body?");
sl@0	2774	return TCL_ERROR;
sl@0	2775	}
sl@0	2776
sl@0	2777	stringObj = objv[i];
sl@0	2778	objc -= i + 1;
sl@0	2779	objv += i + 1;
sl@0	2780	#ifdef TCL_TIP280
sl@0	2781	bidx = i+1; /* First after the match string */
sl@0	2782	#endif
sl@0	2783
sl@0	2784	/*
sl@0	2785	* If all of the pattern/command pairs are lumped into a single
sl@0	2786	* argument, split them out again.
sl@0	2787	*
sl@0	2788	* TIP #280: Determine the lines the words in the list start at, based on
sl@0	2789	* the same data for the list word itself. The cmdFramePtr line information
sl@0	2790	* is manipulated directly.
sl@0	2791	*/
sl@0	2792
sl@0	2793	splitObjs = 0;
sl@0	2794	if (objc == 1) {
sl@0	2795	Tcl_Obj **listv;
sl@0	2796	#ifdef TCL_TIP280
sl@0	2797	blist = objv[0];
sl@0	2798	#endif
sl@0	2799	if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
sl@0	2800	return TCL_ERROR;
sl@0	2801	}
sl@0	2802
sl@0	2803	/*
sl@0	2804	* Ensure that the list is non-empty.
sl@0	2805	*/
sl@0	2806
sl@0	2807	if (objc < 1) {
sl@0	2808	Tcl_WrongNumArgs(interp, 1, savedObjv,
sl@0	2809	"?switches? string {pattern body ... ?default body?}");
sl@0	2810	return TCL_ERROR;
sl@0	2811	}
sl@0	2812	objv = listv;
sl@0	2813	splitObjs = 1;
sl@0	2814	}
sl@0	2815
sl@0	2816	/*
sl@0	2817	* Complain if there is an odd number of words in the list of
sl@0	2818	* patterns and bodies.
sl@0	2819	*/
sl@0	2820
sl@0	2821	if (objc % 2) {
sl@0	2822	Tcl_ResetResult(interp);
sl@0	2823	Tcl_AppendResult(interp, "extra switch pattern with no body", NULL);
sl@0	2824
sl@0	2825	/*
sl@0	2826	* Check if this can be due to a badly placed comment
sl@0	2827	* in the switch block.
sl@0	2828	*
sl@0	2829	* The following is an heuristic to detect the infamous
sl@0	2830	* "comment in switch" error: just check if a pattern
sl@0	2831	* begins with '#'.
sl@0	2832	*/
sl@0	2833
sl@0	2834	if (splitObjs) {
sl@0	2835	for (i=0 ; i<objc ; i+=2) {
sl@0	2836	if (Tcl_GetString(objv[i])[0] == '#') {
sl@0	2837	Tcl_AppendResult(interp, ", this may be due to a ",
sl@0	2838	"comment incorrectly placed outside of a ",
sl@0	2839	"switch body - see the \"switch\" ",
sl@0	2840	"documentation", NULL);
sl@0	2841	break;
sl@0	2842	}
sl@0	2843	}
sl@0	2844	}
sl@0	2845
sl@0	2846	return TCL_ERROR;
sl@0	2847	}
sl@0	2848
sl@0	2849	/*
sl@0	2850	* Complain if the last body is a continuation. Note that this
sl@0	2851	* check assumes that the list is non-empty!
sl@0	2852	*/
sl@0	2853
sl@0	2854	if (strcmp(Tcl_GetString(objv[objc-1]), "-") == 0) {
sl@0	2855	Tcl_ResetResult(interp);
sl@0	2856	Tcl_AppendResult(interp, "no body specified for pattern \"",
sl@0	2857	Tcl_GetString(objv[objc-2]), "\"", NULL);
sl@0	2858	return TCL_ERROR;
sl@0	2859	}
sl@0	2860
sl@0	2861	for (i = 0; i < objc; i += 2) {
sl@0	2862	/*
sl@0	2863	* See if the pattern matches the string.
sl@0	2864	*/
sl@0	2865
sl@0	2866	pattern = Tcl_GetString(objv[i]);
sl@0	2867
sl@0	2868	matched = 0;
sl@0	2869	if ((i == objc - 2)
sl@0	2870	&& (*pattern == 'd')
sl@0	2871	&& (strcmp(pattern, "default") == 0)) {
sl@0	2872	matched = 1;
sl@0	2873	} else {
sl@0	2874	switch (mode) {
sl@0	2875	case OPT_EXACT:
sl@0	2876	matched = (strcmp(Tcl_GetString(stringObj), pattern) == 0);
sl@0	2877	break;
sl@0	2878	case OPT_GLOB:
sl@0	2879	matched = Tcl_StringMatch(Tcl_GetString(stringObj),
sl@0	2880	pattern);
sl@0	2881	break;
sl@0	2882	case OPT_REGEXP:
sl@0	2883	matched = Tcl_RegExpMatchObj(interp, stringObj, objv[i]);
sl@0	2884	if (matched < 0) {
sl@0	2885	return TCL_ERROR;
sl@0	2886	}
sl@0	2887	break;
sl@0	2888	}
sl@0	2889	}
sl@0	2890	if (matched == 0) {
sl@0	2891	continue;
sl@0	2892	}
sl@0	2893
sl@0	2894	/*
sl@0	2895	* We've got a match. Find a body to execute, skipping bodies
sl@0	2896	* that are "-".
sl@0	2897	*
sl@0	2898	* TIP#280: Now is also the time to determine a line number for the
sl@0	2899	* single-word case.
sl@0	2900	*/
sl@0	2901
sl@0	2902	#ifdef TCL_TIP280
sl@0	2903	ctx = *iPtr->cmdFramePtr;
sl@0	2904
sl@0	2905	if (splitObjs) {
sl@0	2906	/* We have to perform the GetSrc and other type dependent handling
sl@0	2907	* of the frame here because we are munging with the line numbers,
sl@0	2908	* something the other commands like if, etc. are not doing. Them
sl@0	2909	* are fine with simply passing the CmdFrame through and having
sl@0	2910	* the special handling done in 'info frame', or the bc compiler
sl@0	2911	*/
sl@0	2912
sl@0	2913	if (ctx.type == TCL_LOCATION_BC) {
sl@0	2914	/* Note: Type BC => ctx.data.eval.path is not used.
sl@0	2915	* ctx.data.tebc.codePtr is used instead.
sl@0	2916	*/
sl@0	2917	TclGetSrcInfoForPc (&ctx);
sl@0	2918	pc = 1;
sl@0	2919	/* The line information in the cmdFrame is now a copy we do
sl@0	2920	* not own */
sl@0	2921	}
sl@0	2922
sl@0	2923	if (ctx.type == TCL_LOCATION_SOURCE) {
sl@0	2924	int bline = ctx.line [bidx];
sl@0	2925	if (bline >= 0) {
sl@0	2926	ctx.line = (int) ckalloc (objc sizeof(int));
sl@0	2927	ctx.nline = objc;
sl@0	2928
sl@0	2929	ListLines (Tcl_GetString (blist), bline, objc, ctx.line);
sl@0	2930	} else {
sl@0	2931	int k;
sl@0	2932	/* Dynamic code word ... All elements are relative to themselves */
sl@0	2933
sl@0	2934	ctx.line = (int) ckalloc (objc sizeof(int));
sl@0	2935	ctx.nline = objc;
sl@0	2936	for (k=0; k < objc; k++) {ctx.line[k] = -1;}
sl@0	2937	}
sl@0	2938	} else {
sl@0	2939	int k;
sl@0	2940	/* Anything else ... No information, or dynamic ... */
sl@0	2941
sl@0	2942	ctx.line = (int) ckalloc (objc sizeof(int));
sl@0	2943	ctx.nline = objc;
sl@0	2944	for (k=0; k < objc; k++) {ctx.line[k] = -1;}
sl@0	2945	}
sl@0	2946	}
sl@0	2947	#endif
sl@0	2948
sl@0	2949	for (j = i + 1; ; j += 2) {
sl@0	2950	if (j >= objc) {
sl@0	2951	/*
sl@0	2952	* This shouldn't happen since we've checked that the
sl@0	2953	* last body is not a continuation...
sl@0	2954	*/
sl@0	2955	panic("fall-out when searching for body to match pattern");
sl@0	2956	}
sl@0	2957	if (strcmp(Tcl_GetString(objv[j]), "-") != 0) {
sl@0	2958	break;
sl@0	2959	}
sl@0	2960	}
sl@0	2961	#ifndef TCL_TIP280
sl@0	2962	result = Tcl_EvalObjEx(interp, objv[j], 0);
sl@0	2963	#else
sl@0	2964	/* TIP #280. Make invoking context available to switch branch */
sl@0	2965	result = TclEvalObjEx(interp, objv[j], 0, &ctx, j);
sl@0	2966	if (splitObjs) {
sl@0	2967	ckfree ((char*) ctx.line);
sl@0	2968	if (pc && (ctx.type == TCL_LOCATION_SOURCE)) {
sl@0	2969	/* Death of SrcInfo reference */
sl@0	2970	Tcl_DecrRefCount (ctx.data.eval.path);
sl@0	2971	}
sl@0	2972	}
sl@0	2973	#endif
sl@0	2974	if (result == TCL_ERROR) {
sl@0	2975	char msg[100 + TCL_INTEGER_SPACE];
sl@0	2976
sl@0	2977	sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern,
sl@0	2978	interp->errorLine);
sl@0	2979	Tcl_AddObjErrorInfo(interp, msg, -1);
sl@0	2980	}
sl@0	2981	return result;
sl@0	2982	}
sl@0	2983	return TCL_OK;
sl@0	2984	}
sl@0	2985
sl@0	2986	/*
sl@0	2987	*----------------------------------------------------------------------
sl@0	2988	*
sl@0	2989	* Tcl_TimeObjCmd --
sl@0	2990	*
sl@0	2991	* This object-based procedure is invoked to process the "time" Tcl
sl@0	2992	* command. See the user documentation for details on what it does.
sl@0	2993	*
sl@0	2994	* Results:
sl@0	2995	* A standard Tcl object result.
sl@0	2996	*
sl@0	2997	* Side effects:
sl@0	2998	* See the user documentation.
sl@0	2999	*
sl@0	3000	*----------------------------------------------------------------------
sl@0	3001	*/
sl@0	3002
sl@0	3003	/* ARGSUSED */
sl@0	3004	int
sl@0	3005	Tcl_TimeObjCmd(dummy, interp, objc, objv)
sl@0	3006	ClientData dummy; /* Not used. */
sl@0	3007	Tcl_Interp interp; / Current interpreter. */
sl@0	3008	int objc; /* Number of arguments. */
sl@0	3009	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3010	{
sl@0	3011	register Tcl_Obj *objPtr;
sl@0	3012	Tcl_Obj *objs[4];
sl@0	3013	register int i, result;
sl@0	3014	int count;
sl@0	3015	double totalMicroSec;
sl@0	3016	Tcl_Time start, stop;
sl@0	3017
sl@0	3018	if (objc == 2) {
sl@0	3019	count = 1;
sl@0	3020	} else if (objc == 3) {
sl@0	3021	result = Tcl_GetIntFromObj(interp, objv[2], &count);
sl@0	3022	if (result != TCL_OK) {
sl@0	3023	return result;
sl@0	3024	}
sl@0	3025	} else {
sl@0	3026	Tcl_WrongNumArgs(interp, 1, objv, "command ?count?");
sl@0	3027	return TCL_ERROR;
sl@0	3028	}
sl@0	3029
sl@0	3030	objPtr = objv[1];
sl@0	3031	i = count;
sl@0	3032	Tcl_GetTime(&start);
sl@0	3033	while (i-- > 0) {
sl@0	3034	result = Tcl_EvalObjEx(interp, objPtr, 0);
sl@0	3035	if (result != TCL_OK) {
sl@0	3036	return result;
sl@0	3037	}
sl@0	3038	}
sl@0	3039	Tcl_GetTime(&stop);
sl@0	3040
sl@0	3041	totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6
sl@0	3042	+ ( stop.usec - start.usec ) );
sl@0	3043	if (count <= 1) {
sl@0	3044	/* Use int obj since we know time is not fractional [Bug 1202178] */
sl@0	3045	objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec);
sl@0	3046	} else {
sl@0	3047	objs[0] = Tcl_NewDoubleObj(totalMicroSec/count);
sl@0	3048	}
sl@0	3049	objs[1] = Tcl_NewStringObj("microseconds", -1);
sl@0	3050	objs[2] = Tcl_NewStringObj("per", -1);
sl@0	3051	objs[3] = Tcl_NewStringObj("iteration", -1);
sl@0	3052	Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs));
sl@0	3053	return TCL_OK;
sl@0	3054	}
sl@0	3055
sl@0	3056	/*
sl@0	3057	*----------------------------------------------------------------------
sl@0	3058	*
sl@0	3059	* Tcl_TraceObjCmd --
sl@0	3060	*
sl@0	3061	* This procedure is invoked to process the "trace" Tcl command.
sl@0	3062	* See the user documentation for details on what it does.
sl@0	3063	*
sl@0	3064	* Standard syntax as of Tcl 8.4 is
sl@0	3065	*
sl@0	3066	* trace {add\|info\|remove} {command\|variable} name ops cmd
sl@0	3067	*
sl@0	3068	*
sl@0	3069	* Results:
sl@0	3070	* A standard Tcl result.
sl@0	3071	*
sl@0	3072	* Side effects:
sl@0	3073	* See the user documentation.
sl@0	3074	*----------------------------------------------------------------------
sl@0	3075	*/
sl@0	3076
sl@0	3077	/* ARGSUSED */
sl@0	3078	int
sl@0	3079	Tcl_TraceObjCmd(dummy, interp, objc, objv)
sl@0	3080	ClientData dummy; /* Not used. */
sl@0	3081	Tcl_Interp interp; / Current interpreter. */
sl@0	3082	int objc; /* Number of arguments. */
sl@0	3083	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3084	{
sl@0	3085	int optionIndex;
sl@0	3086	char name, flagOps, *p;
sl@0	3087	/* Main sub commands to 'trace' */
sl@0	3088	static CONST char *traceOptions[] = {
sl@0	3089	"add", "info", "remove",
sl@0	3090	#ifndef TCL_REMOVE_OBSOLETE_TRACES
sl@0	3091	"variable", "vdelete", "vinfo",
sl@0	3092	#endif
sl@0	3093	(char *) NULL
sl@0	3094	};
sl@0	3095	/* 'OLD' options are pre-Tcl-8.4 style */
sl@0	3096	enum traceOptions {
sl@0	3097	TRACE_ADD, TRACE_INFO, TRACE_REMOVE,
sl@0	3098	#ifndef TCL_REMOVE_OBSOLETE_TRACES
sl@0	3099	TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
sl@0	3100	#endif
sl@0	3101	};
sl@0	3102
sl@0	3103	if (objc < 2) {
sl@0	3104	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
sl@0	3105	return TCL_ERROR;
sl@0	3106	}
sl@0	3107
sl@0	3108	if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions,
sl@0	3109	"option", 0, &optionIndex) != TCL_OK) {
sl@0	3110	return TCL_ERROR;
sl@0	3111	}
sl@0	3112	switch ((enum traceOptions) optionIndex) {
sl@0	3113	case TRACE_ADD:
sl@0	3114	case TRACE_REMOVE:
sl@0	3115	case TRACE_INFO: {
sl@0	3116	/*
sl@0	3117	* All sub commands of trace add/remove must take at least
sl@0	3118	* one more argument. Beyond that we let the subcommand itself
sl@0	3119	* control the argument structure.
sl@0	3120	*/
sl@0	3121	int typeIndex;
sl@0	3122	if (objc < 3) {
sl@0	3123	Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?");
sl@0	3124	return TCL_ERROR;
sl@0	3125	}
sl@0	3126	if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions,
sl@0	3127	"option", 0, &typeIndex) != TCL_OK) {
sl@0	3128	return TCL_ERROR;
sl@0	3129	}
sl@0	3130	return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv);
sl@0	3131	}
sl@0	3132	#ifndef TCL_REMOVE_OBSOLETE_TRACES
sl@0	3133	case TRACE_OLD_VARIABLE:
sl@0	3134	case TRACE_OLD_VDELETE: {
sl@0	3135	Tcl_Obj *copyObjv[6];
sl@0	3136	Tcl_Obj *opsList;
sl@0	3137	int code, numFlags;
sl@0	3138
sl@0	3139	if (objc != 5) {
sl@0	3140	Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
sl@0	3141	return TCL_ERROR;
sl@0	3142	}
sl@0	3143
sl@0	3144	opsList = Tcl_NewObj();
sl@0	3145	Tcl_IncrRefCount(opsList);
sl@0	3146	flagOps = Tcl_GetStringFromObj(objv[3], &numFlags);
sl@0	3147	if (numFlags == 0) {
sl@0	3148	Tcl_DecrRefCount(opsList);
sl@0	3149	goto badVarOps;
sl@0	3150	}
sl@0	3151	for (p = flagOps; *p != 0; p++) {
sl@0	3152	if (*p == 'r') {
sl@0	3153	Tcl_ListObjAppendElement(NULL, opsList,
sl@0	3154	Tcl_NewStringObj("read", -1));
sl@0	3155	} else if (*p == 'w') {
sl@0	3156	Tcl_ListObjAppendElement(NULL, opsList,
sl@0	3157	Tcl_NewStringObj("write", -1));
sl@0	3158	} else if (*p == 'u') {
sl@0	3159	Tcl_ListObjAppendElement(NULL, opsList,
sl@0	3160	Tcl_NewStringObj("unset", -1));
sl@0	3161	} else if (*p == 'a') {
sl@0	3162	Tcl_ListObjAppendElement(NULL, opsList,
sl@0	3163	Tcl_NewStringObj("array", -1));
sl@0	3164	} else {
sl@0	3165	Tcl_DecrRefCount(opsList);
sl@0	3166	goto badVarOps;
sl@0	3167	}
sl@0	3168	}
sl@0	3169	copyObjv[0] = NULL;
sl@0	3170	memcpy(copyObjv+1, objv, objcsizeof(Tcl_Obj ));
sl@0	3171	copyObjv[4] = opsList;
sl@0	3172	if (optionIndex == TRACE_OLD_VARIABLE) {
sl@0	3173	code = (traceSubCmds[2])(interp,TRACE_ADD,objc+1,copyObjv);
sl@0	3174	} else {
sl@0	3175	code = (traceSubCmds[2])(interp,TRACE_REMOVE,objc+1,copyObjv);
sl@0	3176	}
sl@0	3177	Tcl_DecrRefCount(opsList);
sl@0	3178	return code;
sl@0	3179	}
sl@0	3180	case TRACE_OLD_VINFO: {
sl@0	3181	ClientData clientData;
sl@0	3182	char ops[5];
sl@0	3183	Tcl_Obj resultListPtr, pairObjPtr, *elemObjPtr;
sl@0	3184
sl@0	3185	if (objc != 3) {
sl@0	3186	Tcl_WrongNumArgs(interp, 2, objv, "name");
sl@0	3187	return TCL_ERROR;
sl@0	3188	}
sl@0	3189	resultListPtr = Tcl_GetObjResult(interp);
sl@0	3190	clientData = 0;
sl@0	3191	name = Tcl_GetString(objv[2]);
sl@0	3192	while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
sl@0	3193	TraceVarProc, clientData)) != 0) {
sl@0	3194
sl@0	3195	TraceVarInfo tvarPtr = (TraceVarInfo ) clientData;
sl@0	3196
sl@0	3197	pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	3198	p = ops;
sl@0	3199	if (tvarPtr->flags & TCL_TRACE_READS) {
sl@0	3200	*p = 'r';
sl@0	3201	p++;
sl@0	3202	}
sl@0	3203	if (tvarPtr->flags & TCL_TRACE_WRITES) {
sl@0	3204	*p = 'w';
sl@0	3205	p++;
sl@0	3206	}
sl@0	3207	if (tvarPtr->flags & TCL_TRACE_UNSETS) {
sl@0	3208	*p = 'u';
sl@0	3209	p++;
sl@0	3210	}
sl@0	3211	if (tvarPtr->flags & TCL_TRACE_ARRAY) {
sl@0	3212	*p = 'a';
sl@0	3213	p++;
sl@0	3214	}
sl@0	3215	*p = '\0';
sl@0	3216
sl@0	3217	/*
sl@0	3218	* Build a pair (2-item list) with the ops string as
sl@0	3219	* the first obj element and the tvarPtr->command string
sl@0	3220	* as the second obj element. Append the pair (as an
sl@0	3221	* element) to the end of the result object list.
sl@0	3222	*/
sl@0	3223
sl@0	3224	elemObjPtr = Tcl_NewStringObj(ops, -1);
sl@0	3225	Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
sl@0	3226	elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
sl@0	3227	Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
sl@0	3228	Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr);
sl@0	3229	}
sl@0	3230	Tcl_SetObjResult(interp, resultListPtr);
sl@0	3231	break;
sl@0	3232	}
sl@0	3233	#endif /* TCL_REMOVE_OBSOLETE_TRACES */
sl@0	3234	}
sl@0	3235	return TCL_OK;
sl@0	3236
sl@0	3237	badVarOps:
sl@0	3238	Tcl_AppendResult(interp, "bad operations \"", flagOps,
sl@0	3239	"\": should be one or more of rwua", (char *) NULL);
sl@0	3240	return TCL_ERROR;
sl@0	3241	}
sl@0	3242
sl@0	3243
sl@0	3244	/*
sl@0	3245	*----------------------------------------------------------------------
sl@0	3246	*
sl@0	3247	* TclTraceExecutionObjCmd --
sl@0	3248	*
sl@0	3249	* Helper function for Tcl_TraceObjCmd; implements the
sl@0	3250	* [trace {add\|remove\|info} execution ...] subcommands.
sl@0	3251	* See the user documentation for details on what these do.
sl@0	3252	*
sl@0	3253	* Results:
sl@0	3254	* Standard Tcl result.
sl@0	3255	*
sl@0	3256	* Side effects:
sl@0	3257	* Depends on the operation (add, remove, or info) being performed;
sl@0	3258	* may add or remove command traces on a command.
sl@0	3259	*
sl@0	3260	*----------------------------------------------------------------------
sl@0	3261	*/
sl@0	3262
sl@0	3263	int
sl@0	3264	TclTraceExecutionObjCmd(interp, optionIndex, objc, objv)
sl@0	3265	Tcl_Interp interp; / Current interpreter. */
sl@0	3266	int optionIndex; /* Add, info or remove */
sl@0	3267	int objc; /* Number of arguments. */
sl@0	3268	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3269	{
sl@0	3270	int commandLength, index;
sl@0	3271	char name, command;
sl@0	3272	size_t length;
sl@0	3273	enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
sl@0	3274	static CONST char *opStrings[] = { "enter", "leave",
sl@0	3275	"enterstep", "leavestep", (char *) NULL };
sl@0	3276	enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE,
sl@0	3277	TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP };
sl@0	3278
sl@0	3279	switch ((enum traceOptions) optionIndex) {
sl@0	3280	case TRACE_ADD:
sl@0	3281	case TRACE_REMOVE: {
sl@0	3282	int flags = 0;
sl@0	3283	int i, listLen, result;
sl@0	3284	Tcl_Obj **elemPtrs;
sl@0	3285	if (objc != 6) {
sl@0	3286	Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
sl@0	3287	return TCL_ERROR;
sl@0	3288	}
sl@0	3289	/*
sl@0	3290	* Make sure the ops argument is a list object; get its length and
sl@0	3291	* a pointer to its array of element pointers.
sl@0	3292	*/
sl@0	3293
sl@0	3294	result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
sl@0	3295	&elemPtrs);
sl@0	3296	if (result != TCL_OK) {
sl@0	3297	return result;
sl@0	3298	}
sl@0	3299	if (listLen == 0) {
sl@0	3300	Tcl_SetResult(interp, "bad operation list \"\": must be "
sl@0	3301	"one or more of enter, leave, enterstep, or leavestep",
sl@0	3302	TCL_STATIC);
sl@0	3303	return TCL_ERROR;
sl@0	3304	}
sl@0	3305	for (i = 0; i < listLen; i++) {
sl@0	3306	if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
sl@0	3307	"operation", TCL_EXACT, &index) != TCL_OK) {
sl@0	3308	return TCL_ERROR;
sl@0	3309	}
sl@0	3310	switch ((enum operations) index) {
sl@0	3311	case TRACE_EXEC_ENTER:
sl@0	3312	flags \|= TCL_TRACE_ENTER_EXEC;
sl@0	3313	break;
sl@0	3314	case TRACE_EXEC_LEAVE:
sl@0	3315	flags \|= TCL_TRACE_LEAVE_EXEC;
sl@0	3316	break;
sl@0	3317	case TRACE_EXEC_ENTER_STEP:
sl@0	3318	flags \|= TCL_TRACE_ENTER_DURING_EXEC;
sl@0	3319	break;
sl@0	3320	case TRACE_EXEC_LEAVE_STEP:
sl@0	3321	flags \|= TCL_TRACE_LEAVE_DURING_EXEC;
sl@0	3322	break;
sl@0	3323	}
sl@0	3324	}
sl@0	3325	command = Tcl_GetStringFromObj(objv[5], &commandLength);
sl@0	3326	length = (size_t) commandLength;
sl@0	3327	if ((enum traceOptions) optionIndex == TRACE_ADD) {
sl@0	3328	TraceCommandInfo *tcmdPtr;
sl@0	3329	tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
sl@0	3330	(sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
sl@0	3331	+ length + 1));
sl@0	3332	tcmdPtr->flags = flags;
sl@0	3333	tcmdPtr->stepTrace = NULL;
sl@0	3334	tcmdPtr->startLevel = 0;
sl@0	3335	tcmdPtr->startCmd = NULL;
sl@0	3336	tcmdPtr->length = length;
sl@0	3337	tcmdPtr->refCount = 1;
sl@0	3338	flags \|= TCL_TRACE_DELETE;
sl@0	3339	if (flags & (TCL_TRACE_ENTER_DURING_EXEC \|
sl@0	3340	TCL_TRACE_LEAVE_DURING_EXEC)) {
sl@0	3341	flags \|= (TCL_TRACE_ENTER_EXEC \|
sl@0	3342	TCL_TRACE_LEAVE_EXEC);
sl@0	3343	}
sl@0	3344	strcpy(tcmdPtr->command, command);
sl@0	3345	name = Tcl_GetString(objv[3]);
sl@0	3346	if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
sl@0	3347	(ClientData) tcmdPtr) != TCL_OK) {
sl@0	3348	ckfree((char *) tcmdPtr);
sl@0	3349	return TCL_ERROR;
sl@0	3350	}
sl@0	3351	} else {
sl@0	3352	/*
sl@0	3353	* Search through all of our traces on this command to
sl@0	3354	* see if there's one with the given command. If so, then
sl@0	3355	* delete the first one that matches.
sl@0	3356	*/
sl@0	3357
sl@0	3358	TraceCommandInfo *tcmdPtr;
sl@0	3359	ClientData clientData = NULL;
sl@0	3360	name = Tcl_GetString(objv[3]);
sl@0	3361
sl@0	3362	/* First ensure the name given is valid */
sl@0	3363	if (Tcl_FindCommand(interp, name, NULL,
sl@0	3364	TCL_LEAVE_ERR_MSG) == NULL) {
sl@0	3365	return TCL_ERROR;
sl@0	3366	}
sl@0	3367
sl@0	3368	while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
sl@0	3369	TraceCommandProc, clientData)) != NULL) {
sl@0	3370	tcmdPtr = (TraceCommandInfo *) clientData;
sl@0	3371	/*
sl@0	3372	* In checking the 'flags' field we must remove any
sl@0	3373	* extraneous flags which may have been temporarily
sl@0	3374	* added by various pieces of the trace mechanism.
sl@0	3375	*/
sl@0	3376	if ((tcmdPtr->length == length)
sl@0	3377	&& ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC \|
sl@0	3378	TCL_TRACE_RENAME \|
sl@0	3379	TCL_TRACE_DELETE)) == flags)
sl@0	3380	&& (strncmp(command, tcmdPtr->command,
sl@0	3381	(size_t) length) == 0)) {
sl@0	3382	flags \|= TCL_TRACE_DELETE;
sl@0	3383	if (flags & (TCL_TRACE_ENTER_DURING_EXEC \|
sl@0	3384	TCL_TRACE_LEAVE_DURING_EXEC)) {
sl@0	3385	flags \|= (TCL_TRACE_ENTER_EXEC \|
sl@0	3386	TCL_TRACE_LEAVE_EXEC);
sl@0	3387	}
sl@0	3388	Tcl_UntraceCommand(interp, name,
sl@0	3389	flags, TraceCommandProc, clientData);
sl@0	3390	if (tcmdPtr->stepTrace != NULL) {
sl@0	3391	/*
sl@0	3392	* We need to remove the interpreter-wide trace
sl@0	3393	* which we created to allow 'step' traces.
sl@0	3394	*/
sl@0	3395	Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
sl@0	3396	tcmdPtr->stepTrace = NULL;
sl@0	3397	if (tcmdPtr->startCmd != NULL) {
sl@0	3398	ckfree((char *)tcmdPtr->startCmd);
sl@0	3399	}
sl@0	3400	}
sl@0	3401	if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
sl@0	3402	/* Postpone deletion */
sl@0	3403	tcmdPtr->flags = 0;
sl@0	3404	}
sl@0	3405	tcmdPtr->refCount--;
sl@0	3406	if (tcmdPtr->refCount < 0) {
sl@0	3407	Tcl_Panic("TclTraceExecutionObjCmd: negative TraceCommandInfo refCount");
sl@0	3408	}
sl@0	3409	if (tcmdPtr->refCount == 0) {
sl@0	3410	ckfree((char*)tcmdPtr);
sl@0	3411	}
sl@0	3412	break;
sl@0	3413	}
sl@0	3414	}
sl@0	3415	}
sl@0	3416	break;
sl@0	3417	}
sl@0	3418	case TRACE_INFO: {
sl@0	3419	ClientData clientData;
sl@0	3420	Tcl_Obj resultListPtr, eachTraceObjPtr, *elemObjPtr;
sl@0	3421	if (objc != 4) {
sl@0	3422	Tcl_WrongNumArgs(interp, 3, objv, "name");
sl@0	3423	return TCL_ERROR;
sl@0	3424	}
sl@0	3425
sl@0	3426	clientData = NULL;
sl@0	3427	name = Tcl_GetString(objv[3]);
sl@0	3428
sl@0	3429	/* First ensure the name given is valid */
sl@0	3430	if (Tcl_FindCommand(interp, name, NULL,
sl@0	3431	TCL_LEAVE_ERR_MSG) == NULL) {
sl@0	3432	return TCL_ERROR;
sl@0	3433	}
sl@0	3434
sl@0	3435	resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	3436	while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
sl@0	3437	TraceCommandProc, clientData)) != NULL) {
sl@0	3438	int numOps = 0;
sl@0	3439
sl@0	3440	TraceCommandInfo tcmdPtr = (TraceCommandInfo ) clientData;
sl@0	3441
sl@0	3442	/*
sl@0	3443	* Build a list with the ops list as the first obj
sl@0	3444	* element and the tcmdPtr->command string as the
sl@0	3445	* second obj element. Append this list (as an
sl@0	3446	* element) to the end of the result object list.
sl@0	3447	*/
sl@0	3448
sl@0	3449	elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	3450	Tcl_IncrRefCount(elemObjPtr);
sl@0	3451	if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) {
sl@0	3452	Tcl_ListObjAppendElement(NULL, elemObjPtr,
sl@0	3453	Tcl_NewStringObj("enter",5));
sl@0	3454	}
sl@0	3455	if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) {
sl@0	3456	Tcl_ListObjAppendElement(NULL, elemObjPtr,
sl@0	3457	Tcl_NewStringObj("leave",5));
sl@0	3458	}
sl@0	3459	if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) {
sl@0	3460	Tcl_ListObjAppendElement(NULL, elemObjPtr,
sl@0	3461	Tcl_NewStringObj("enterstep",9));
sl@0	3462	}
sl@0	3463	if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) {
sl@0	3464	Tcl_ListObjAppendElement(NULL, elemObjPtr,
sl@0	3465	Tcl_NewStringObj("leavestep",9));
sl@0	3466	}
sl@0	3467	Tcl_ListObjLength(NULL, elemObjPtr, &numOps);
sl@0	3468	if (0 == numOps) {
sl@0	3469	Tcl_DecrRefCount(elemObjPtr);
sl@0	3470	continue;
sl@0	3471	}
sl@0	3472	eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	3473	Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
sl@0	3474	Tcl_DecrRefCount(elemObjPtr);
sl@0	3475	elemObjPtr = NULL;
sl@0	3476
sl@0	3477	Tcl_ListObjAppendElement(NULL, eachTraceObjPtr,
sl@0	3478	Tcl_NewStringObj(tcmdPtr->command, -1));
sl@0	3479	Tcl_ListObjAppendElement(interp, resultListPtr,
sl@0	3480	eachTraceObjPtr);
sl@0	3481	}
sl@0	3482	Tcl_SetObjResult(interp, resultListPtr);
sl@0	3483	break;
sl@0	3484	}
sl@0	3485	}
sl@0	3486	return TCL_OK;
sl@0	3487	}
sl@0	3488
sl@0	3489
sl@0	3490	/*
sl@0	3491	*----------------------------------------------------------------------
sl@0	3492	*
sl@0	3493	* TclTraceCommandObjCmd --
sl@0	3494	*
sl@0	3495	* Helper function for Tcl_TraceObjCmd; implements the
sl@0	3496	* [trace {add\|info\|remove} command ...] subcommands.
sl@0	3497	* See the user documentation for details on what these do.
sl@0	3498	*
sl@0	3499	* Results:
sl@0	3500	* Standard Tcl result.
sl@0	3501	*
sl@0	3502	* Side effects:
sl@0	3503	* Depends on the operation (add, remove, or info) being performed;
sl@0	3504	* may add or remove command traces on a command.
sl@0	3505	*
sl@0	3506	*----------------------------------------------------------------------
sl@0	3507	*/
sl@0	3508
sl@0	3509	int
sl@0	3510	TclTraceCommandObjCmd(interp, optionIndex, objc, objv)
sl@0	3511	Tcl_Interp interp; / Current interpreter. */
sl@0	3512	int optionIndex; /* Add, info or remove */
sl@0	3513	int objc; /* Number of arguments. */
sl@0	3514	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3515	{
sl@0	3516	int commandLength, index;
sl@0	3517	char name, command;
sl@0	3518	size_t length;
sl@0	3519	enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
sl@0	3520	static CONST char opStrings[] = { "delete", "rename", (char ) NULL };
sl@0	3521	enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME };
sl@0	3522
sl@0	3523	switch ((enum traceOptions) optionIndex) {
sl@0	3524	case TRACE_ADD:
sl@0	3525	case TRACE_REMOVE: {
sl@0	3526	int flags = 0;
sl@0	3527	int i, listLen, result;
sl@0	3528	Tcl_Obj **elemPtrs;
sl@0	3529	if (objc != 6) {
sl@0	3530	Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
sl@0	3531	return TCL_ERROR;
sl@0	3532	}
sl@0	3533	/*
sl@0	3534	* Make sure the ops argument is a list object; get its length and
sl@0	3535	* a pointer to its array of element pointers.
sl@0	3536	*/
sl@0	3537
sl@0	3538	result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
sl@0	3539	&elemPtrs);
sl@0	3540	if (result != TCL_OK) {
sl@0	3541	return result;
sl@0	3542	}
sl@0	3543	if (listLen == 0) {
sl@0	3544	Tcl_SetResult(interp, "bad operation list \"\": must be "
sl@0	3545	"one or more of delete or rename", TCL_STATIC);
sl@0	3546	return TCL_ERROR;
sl@0	3547	}
sl@0	3548	for (i = 0; i < listLen; i++) {
sl@0	3549	if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
sl@0	3550	"operation", TCL_EXACT, &index) != TCL_OK) {
sl@0	3551	return TCL_ERROR;
sl@0	3552	}
sl@0	3553	switch ((enum operations) index) {
sl@0	3554	case TRACE_CMD_RENAME:
sl@0	3555	flags \|= TCL_TRACE_RENAME;
sl@0	3556	break;
sl@0	3557	case TRACE_CMD_DELETE:
sl@0	3558	flags \|= TCL_TRACE_DELETE;
sl@0	3559	break;
sl@0	3560	}
sl@0	3561	}
sl@0	3562	command = Tcl_GetStringFromObj(objv[5], &commandLength);
sl@0	3563	length = (size_t) commandLength;
sl@0	3564	if ((enum traceOptions) optionIndex == TRACE_ADD) {
sl@0	3565	TraceCommandInfo *tcmdPtr;
sl@0	3566	tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
sl@0	3567	(sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
sl@0	3568	+ length + 1));
sl@0	3569	tcmdPtr->flags = flags;
sl@0	3570	tcmdPtr->stepTrace = NULL;
sl@0	3571	tcmdPtr->startLevel = 0;
sl@0	3572	tcmdPtr->startCmd = NULL;
sl@0	3573	tcmdPtr->length = length;
sl@0	3574	tcmdPtr->refCount = 1;
sl@0	3575	flags \|= TCL_TRACE_DELETE;
sl@0	3576	strcpy(tcmdPtr->command, command);
sl@0	3577	name = Tcl_GetString(objv[3]);
sl@0	3578	if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
sl@0	3579	(ClientData) tcmdPtr) != TCL_OK) {
sl@0	3580	ckfree((char *) tcmdPtr);
sl@0	3581	return TCL_ERROR;
sl@0	3582	}
sl@0	3583	} else {
sl@0	3584	/*
sl@0	3585	* Search through all of our traces on this command to
sl@0	3586	* see if there's one with the given command. If so, then
sl@0	3587	* delete the first one that matches.
sl@0	3588	*/
sl@0	3589
sl@0	3590	TraceCommandInfo *tcmdPtr;
sl@0	3591	ClientData clientData = NULL;
sl@0	3592	name = Tcl_GetString(objv[3]);
sl@0	3593
sl@0	3594	/* First ensure the name given is valid */
sl@0	3595	if (Tcl_FindCommand(interp, name, NULL,
sl@0	3596	TCL_LEAVE_ERR_MSG) == NULL) {
sl@0	3597	return TCL_ERROR;
sl@0	3598	}
sl@0	3599
sl@0	3600	while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
sl@0	3601	TraceCommandProc, clientData)) != NULL) {
sl@0	3602	tcmdPtr = (TraceCommandInfo *) clientData;
sl@0	3603	if ((tcmdPtr->length == length)
sl@0	3604	&& (tcmdPtr->flags == flags)
sl@0	3605	&& (strncmp(command, tcmdPtr->command,
sl@0	3606	(size_t) length) == 0)) {
sl@0	3607	Tcl_UntraceCommand(interp, name,
sl@0	3608	flags \| TCL_TRACE_DELETE,
sl@0	3609	TraceCommandProc, clientData);
sl@0	3610	tcmdPtr->flags \|= TCL_TRACE_DESTROYED;
sl@0	3611	tcmdPtr->refCount--;
sl@0	3612	if (tcmdPtr->refCount < 0) {
sl@0	3613	Tcl_Panic("TclTraceCommandObjCmd: negative TraceCommandInfo refCount");
sl@0	3614	}
sl@0	3615	if (tcmdPtr->refCount == 0) {
sl@0	3616	ckfree((char *) tcmdPtr);
sl@0	3617	}
sl@0	3618	break;
sl@0	3619	}
sl@0	3620	}
sl@0	3621	}
sl@0	3622	break;
sl@0	3623	}
sl@0	3624	case TRACE_INFO: {
sl@0	3625	ClientData clientData;
sl@0	3626	Tcl_Obj resultListPtr, eachTraceObjPtr, *elemObjPtr;
sl@0	3627	if (objc != 4) {
sl@0	3628	Tcl_WrongNumArgs(interp, 3, objv, "name");
sl@0	3629	return TCL_ERROR;
sl@0	3630	}
sl@0	3631
sl@0	3632	clientData = NULL;
sl@0	3633	name = Tcl_GetString(objv[3]);
sl@0	3634
sl@0	3635	/* First ensure the name given is valid */
sl@0	3636	if (Tcl_FindCommand(interp, name, NULL,
sl@0	3637	TCL_LEAVE_ERR_MSG) == NULL) {
sl@0	3638	return TCL_ERROR;
sl@0	3639	}
sl@0	3640
sl@0	3641	resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	3642	while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
sl@0	3643	TraceCommandProc, clientData)) != NULL) {
sl@0	3644	int numOps = 0;
sl@0	3645
sl@0	3646	TraceCommandInfo tcmdPtr = (TraceCommandInfo ) clientData;
sl@0	3647
sl@0	3648	/*
sl@0	3649	* Build a list with the ops list as
sl@0	3650	* the first obj element and the tcmdPtr->command string
sl@0	3651	* as the second obj element. Append this list (as an
sl@0	3652	* element) to the end of the result object list.
sl@0	3653	*/
sl@0	3654
sl@0	3655	elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	3656	Tcl_IncrRefCount(elemObjPtr);
sl@0	3657	if (tcmdPtr->flags & TCL_TRACE_RENAME) {
sl@0	3658	Tcl_ListObjAppendElement(NULL, elemObjPtr,
sl@0	3659	Tcl_NewStringObj("rename",6));
sl@0	3660	}
sl@0	3661	if (tcmdPtr->flags & TCL_TRACE_DELETE) {
sl@0	3662	Tcl_ListObjAppendElement(NULL, elemObjPtr,
sl@0	3663	Tcl_NewStringObj("delete",6));
sl@0	3664	}
sl@0	3665	Tcl_ListObjLength(NULL, elemObjPtr, &numOps);
sl@0	3666	if (0 == numOps) {
sl@0	3667	Tcl_DecrRefCount(elemObjPtr);
sl@0	3668	continue;
sl@0	3669	}
sl@0	3670	eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	3671	Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
sl@0	3672	Tcl_DecrRefCount(elemObjPtr);
sl@0	3673
sl@0	3674	elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1);
sl@0	3675	Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
sl@0	3676	Tcl_ListObjAppendElement(interp, resultListPtr,
sl@0	3677	eachTraceObjPtr);
sl@0	3678	}
sl@0	3679	Tcl_SetObjResult(interp, resultListPtr);
sl@0	3680	break;
sl@0	3681	}
sl@0	3682	}
sl@0	3683	return TCL_OK;
sl@0	3684	}
sl@0	3685
sl@0	3686
sl@0	3687	/*
sl@0	3688	*----------------------------------------------------------------------
sl@0	3689	*
sl@0	3690	* TclTraceVariableObjCmd --
sl@0	3691	*
sl@0	3692	* Helper function for Tcl_TraceObjCmd; implements the
sl@0	3693	* [trace {add\|info\|remove} variable ...] subcommands.
sl@0	3694	* See the user documentation for details on what these do.
sl@0	3695	*
sl@0	3696	* Results:
sl@0	3697	* Standard Tcl result.
sl@0	3698	*
sl@0	3699	* Side effects:
sl@0	3700	* Depends on the operation (add, remove, or info) being performed;
sl@0	3701	* may add or remove variable traces on a variable.
sl@0	3702	*
sl@0	3703	*----------------------------------------------------------------------
sl@0	3704	*/
sl@0	3705
sl@0	3706	int
sl@0	3707	TclTraceVariableObjCmd(interp, optionIndex, objc, objv)
sl@0	3708	Tcl_Interp interp; / Current interpreter. */
sl@0	3709	int optionIndex; /* Add, info or remove */
sl@0	3710	int objc; /* Number of arguments. */
sl@0	3711	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3712	{
sl@0	3713	int commandLength, index;
sl@0	3714	char name, command;
sl@0	3715	size_t length;
sl@0	3716	enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
sl@0	3717	static CONST char *opStrings[] = { "array", "read", "unset", "write",
sl@0	3718	(char *) NULL };
sl@0	3719	enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET,
sl@0	3720	TRACE_VAR_WRITE };
sl@0	3721
sl@0	3722	switch ((enum traceOptions) optionIndex) {
sl@0	3723	case TRACE_ADD:
sl@0	3724	case TRACE_REMOVE: {
sl@0	3725	int flags = 0;
sl@0	3726	int i, listLen, result;
sl@0	3727	Tcl_Obj **elemPtrs;
sl@0	3728	if (objc != 6) {
sl@0	3729	Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
sl@0	3730	return TCL_ERROR;
sl@0	3731	}
sl@0	3732	/*
sl@0	3733	* Make sure the ops argument is a list object; get its length and
sl@0	3734	* a pointer to its array of element pointers.
sl@0	3735	*/
sl@0	3736
sl@0	3737	result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
sl@0	3738	&elemPtrs);
sl@0	3739	if (result != TCL_OK) {
sl@0	3740	return result;
sl@0	3741	}
sl@0	3742	if (listLen == 0) {
sl@0	3743	Tcl_SetResult(interp, "bad operation list \"\": must be "
sl@0	3744	"one or more of array, read, unset, or write",
sl@0	3745	TCL_STATIC);
sl@0	3746	return TCL_ERROR;
sl@0	3747	}
sl@0	3748	for (i = 0; i < listLen ; i++) {
sl@0	3749	if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
sl@0	3750	"operation", TCL_EXACT, &index) != TCL_OK) {
sl@0	3751	return TCL_ERROR;
sl@0	3752	}
sl@0	3753	switch ((enum operations) index) {
sl@0	3754	case TRACE_VAR_ARRAY:
sl@0	3755	flags \|= TCL_TRACE_ARRAY;
sl@0	3756	break;
sl@0	3757	case TRACE_VAR_READ:
sl@0	3758	flags \|= TCL_TRACE_READS;
sl@0	3759	break;
sl@0	3760	case TRACE_VAR_UNSET:
sl@0	3761	flags \|= TCL_TRACE_UNSETS;
sl@0	3762	break;
sl@0	3763	case TRACE_VAR_WRITE:
sl@0	3764	flags \|= TCL_TRACE_WRITES;
sl@0	3765	break;
sl@0	3766	}
sl@0	3767	}
sl@0	3768	command = Tcl_GetStringFromObj(objv[5], &commandLength);
sl@0	3769	length = (size_t) commandLength;
sl@0	3770	if ((enum traceOptions) optionIndex == TRACE_ADD) {
sl@0	3771	/*
sl@0	3772	* This code essentially mallocs together the VarTrace and the
sl@0	3773	* TraceVarInfo, then inlines the Tcl_TraceVar(). This is
sl@0	3774	* necessary in order to have the TraceVarInfo to be freed
sl@0	3775	* automatically when the VarTrace is freed [Bug 1348775]
sl@0	3776	*/
sl@0	3777
sl@0	3778	CompoundVarTrace *compTracePtr;
sl@0	3779	TraceVarInfo *tvarPtr;
sl@0	3780	Var varPtr, arrayPtr;
sl@0	3781	VarTrace *tracePtr;
sl@0	3782	int flagMask;
sl@0	3783
sl@0	3784	compTracePtr = (CompoundVarTrace *) ckalloc((unsigned)
sl@0	3785	(sizeof(CompoundVarTrace) - sizeof(tvarPtr->command)
sl@0	3786	+ length + 1));
sl@0	3787	tracePtr = &(compTracePtr->trace);
sl@0	3788	tvarPtr = &(compTracePtr->tvar);
sl@0	3789	tvarPtr->flags = flags;
sl@0	3790	if (objv[0] == NULL) {
sl@0	3791	tvarPtr->flags \|= TCL_TRACE_OLD_STYLE;
sl@0	3792	}
sl@0	3793	tvarPtr->length = length;
sl@0	3794	flags \|= TCL_TRACE_UNSETS \| TCL_TRACE_RESULT_OBJECT;
sl@0	3795	strcpy(tvarPtr->command, command);
sl@0	3796	name = Tcl_GetString(objv[3]);
sl@0	3797	flagMask = TCL_GLOBAL_ONLY \| TCL_NAMESPACE_ONLY;
sl@0	3798	varPtr = TclLookupVar(interp, name, NULL,
sl@0	3799	(flags & flagMask) \| TCL_LEAVE_ERR_MSG, "trace",
sl@0	3800	/createPart1/ 1, /createPart2/ 1, &arrayPtr);
sl@0	3801	if (varPtr == NULL) {
sl@0	3802	ckfree((char *) tracePtr);
sl@0	3803	return TCL_ERROR;
sl@0	3804	}
sl@0	3805	flagMask = TCL_TRACE_READS \| TCL_TRACE_WRITES
sl@0	3806	\| TCL_TRACE_UNSETS \| TCL_TRACE_ARRAY
sl@0	3807	\| TCL_TRACE_RESULT_DYNAMIC \| TCL_TRACE_RESULT_OBJECT;
sl@0	3808	#ifndef TCL_REMOVE_OBSOLETE_TRACES
sl@0	3809	flagMask \|= TCL_TRACE_OLD_STYLE;
sl@0	3810	#endif
sl@0	3811	tracePtr->traceProc = TraceVarProc;
sl@0	3812	tracePtr->clientData = (ClientData) tvarPtr;
sl@0	3813	tracePtr->flags = flags & flagMask;
sl@0	3814	tracePtr->nextPtr = varPtr->tracePtr;
sl@0	3815	varPtr->tracePtr = tracePtr;
sl@0	3816	} else {
sl@0	3817	/*
sl@0	3818	* Search through all of our traces on this variable to
sl@0	3819	* see if there's one with the given command. If so, then
sl@0	3820	* delete the first one that matches.
sl@0	3821	*/
sl@0	3822
sl@0	3823	TraceVarInfo *tvarPtr;
sl@0	3824	ClientData clientData = 0;
sl@0	3825	name = Tcl_GetString(objv[3]);
sl@0	3826	while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
sl@0	3827	TraceVarProc, clientData)) != 0) {
sl@0	3828	tvarPtr = (TraceVarInfo *) clientData;
sl@0	3829	if ((tvarPtr->length == length)
sl@0	3830	&& ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags)
sl@0	3831	&& (strncmp(command, tvarPtr->command,
sl@0	3832	(size_t) length) == 0)) {
sl@0	3833	Tcl_UntraceVar2(interp, name, NULL,
sl@0	3834	flags \| TCL_TRACE_UNSETS \| TCL_TRACE_RESULT_OBJECT,
sl@0	3835	TraceVarProc, clientData);
sl@0	3836	break;
sl@0	3837	}
sl@0	3838	}
sl@0	3839	}
sl@0	3840	break;
sl@0	3841	}
sl@0	3842	case TRACE_INFO: {
sl@0	3843	ClientData clientData;
sl@0	3844	Tcl_Obj resultListPtr, eachTraceObjPtr, *elemObjPtr;
sl@0	3845	if (objc != 4) {
sl@0	3846	Tcl_WrongNumArgs(interp, 3, objv, "name");
sl@0	3847	return TCL_ERROR;
sl@0	3848	}
sl@0	3849
sl@0	3850	resultListPtr = Tcl_GetObjResult(interp);
sl@0	3851	clientData = 0;
sl@0	3852	name = Tcl_GetString(objv[3]);
sl@0	3853	while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
sl@0	3854	TraceVarProc, clientData)) != 0) {
sl@0	3855
sl@0	3856	TraceVarInfo tvarPtr = (TraceVarInfo ) clientData;
sl@0	3857
sl@0	3858	/*
sl@0	3859	* Build a list with the ops list as
sl@0	3860	* the first obj element and the tcmdPtr->command string
sl@0	3861	* as the second obj element. Append this list (as an
sl@0	3862	* element) to the end of the result object list.
sl@0	3863	*/
sl@0	3864
sl@0	3865	elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	3866	if (tvarPtr->flags & TCL_TRACE_ARRAY) {
sl@0	3867	Tcl_ListObjAppendElement(NULL, elemObjPtr,
sl@0	3868	Tcl_NewStringObj("array", 5));
sl@0	3869	}
sl@0	3870	if (tvarPtr->flags & TCL_TRACE_READS) {
sl@0	3871	Tcl_ListObjAppendElement(NULL, elemObjPtr,
sl@0	3872	Tcl_NewStringObj("read", 4));
sl@0	3873	}
sl@0	3874	if (tvarPtr->flags & TCL_TRACE_WRITES) {
sl@0	3875	Tcl_ListObjAppendElement(NULL, elemObjPtr,
sl@0	3876	Tcl_NewStringObj("write", 5));
sl@0	3877	}
sl@0	3878	if (tvarPtr->flags & TCL_TRACE_UNSETS) {
sl@0	3879	Tcl_ListObjAppendElement(NULL, elemObjPtr,
sl@0	3880	Tcl_NewStringObj("unset", 5));
sl@0	3881	}
sl@0	3882	eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	3883	Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
sl@0	3884
sl@0	3885	elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
sl@0	3886	Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
sl@0	3887	Tcl_ListObjAppendElement(interp, resultListPtr,
sl@0	3888	eachTraceObjPtr);
sl@0	3889	}
sl@0	3890	Tcl_SetObjResult(interp, resultListPtr);
sl@0	3891	break;
sl@0	3892	}
sl@0	3893	}
sl@0	3894	return TCL_OK;
sl@0	3895	}
sl@0	3896
sl@0	3897
sl@0	3898	/*
sl@0	3899	*----------------------------------------------------------------------
sl@0	3900	*
sl@0	3901	* Tcl_CommandTraceInfo --
sl@0	3902	*
sl@0	3903	* Return the clientData value associated with a trace on a
sl@0	3904	* command. This procedure can also be used to step through
sl@0	3905	* all of the traces on a particular command that have the
sl@0	3906	* same trace procedure.
sl@0	3907	*
sl@0	3908	* Results:
sl@0	3909	* The return value is the clientData value associated with
sl@0	3910	* a trace on the given command. Information will only be
sl@0	3911	* returned for a trace with proc as trace procedure. If
sl@0	3912	* the clientData argument is NULL then the first such trace is
sl@0	3913	* returned; otherwise, the next relevant one after the one
sl@0	3914	* given by clientData will be returned. If the command
sl@0	3915	* doesn't exist then an error message is left in the interpreter
sl@0	3916	* and NULL is returned. Also, if there are no (more) traces for
sl@0	3917	* the given command, NULL is returned.
sl@0	3918	*
sl@0	3919	* Side effects:
sl@0	3920	* None.
sl@0	3921	*
sl@0	3922	*----------------------------------------------------------------------
sl@0	3923	*/
sl@0	3924
sl@0	3925	EXPORT_C ClientData
sl@0	3926	Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData)
sl@0	3927	Tcl_Interp interp; / Interpreter containing command. */
sl@0	3928	CONST char cmdName; / Name of command. */
sl@0	3929	int flags; /* OR-ed combo or TCL_GLOBAL_ONLY,
sl@0	3930	* TCL_NAMESPACE_ONLY (can be 0). */
sl@0	3931	Tcl_CommandTraceProc proc; / Procedure assocated with trace. */
sl@0	3932	ClientData prevClientData; /* If non-NULL, gives last value returned
sl@0	3933	* by this procedure, so this call will
sl@0	3934	* return the next trace after that one.
sl@0	3935	* If NULL, this call will return the
sl@0	3936	* first trace. */
sl@0	3937	{
sl@0	3938	Command *cmdPtr;
sl@0	3939	register CommandTrace *tracePtr;
sl@0	3940
sl@0	3941	cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
sl@0	3942	NULL, TCL_LEAVE_ERR_MSG);
sl@0	3943	if (cmdPtr == NULL) {
sl@0	3944	return NULL;
sl@0	3945	}
sl@0	3946
sl@0	3947	/*
sl@0	3948	* Find the relevant trace, if any, and return its clientData.
sl@0	3949	*/
sl@0	3950
sl@0	3951	tracePtr = cmdPtr->tracePtr;
sl@0	3952	if (prevClientData != NULL) {
sl@0	3953	for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
sl@0	3954	if ((tracePtr->clientData == prevClientData)
sl@0	3955	&& (tracePtr->traceProc == proc)) {
sl@0	3956	tracePtr = tracePtr->nextPtr;
sl@0	3957	break;
sl@0	3958	}
sl@0	3959	}
sl@0	3960	}
sl@0	3961	for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
sl@0	3962	if (tracePtr->traceProc == proc) {
sl@0	3963	return tracePtr->clientData;
sl@0	3964	}
sl@0	3965	}
sl@0	3966	return NULL;
sl@0	3967	}
sl@0	3968
sl@0	3969	/*
sl@0	3970	*----------------------------------------------------------------------
sl@0	3971	*
sl@0	3972	* Tcl_TraceCommand --
sl@0	3973	*
sl@0	3974	* Arrange for rename/deletes to a command to cause a
sl@0	3975	* procedure to be invoked, which can monitor the operations.
sl@0	3976	*
sl@0	3977	* Also optionally arrange for execution of that command
sl@0	3978	* to cause a procedure to be invoked.
sl@0	3979	*
sl@0	3980	* Results:
sl@0	3981	* A standard Tcl return value.
sl@0	3982	*
sl@0	3983	* Side effects:
sl@0	3984	* A trace is set up on the command given by cmdName, such that
sl@0	3985	* future changes to the command will be intermediated by
sl@0	3986	* proc. See the manual entry for complete details on the calling
sl@0	3987	* sequence for proc.
sl@0	3988	*
sl@0	3989	*----------------------------------------------------------------------
sl@0	3990	*/
sl@0	3991
sl@0	3992	EXPORT_C int
sl@0	3993	Tcl_TraceCommand(interp, cmdName, flags, proc, clientData)
sl@0	3994	Tcl_Interp interp; / Interpreter in which command is
sl@0	3995	* to be traced. */
sl@0	3996	CONST char cmdName; / Name of command. */
sl@0	3997	int flags; /* OR-ed collection of bits, including any
sl@0	3998	* of TCL_TRACE_RENAME, TCL_TRACE_DELETE,
sl@0	3999	* and any of the TRACE__EXEC flags /
sl@0	4000	Tcl_CommandTraceProc proc; / Procedure to call when specified ops are
sl@0	4001	* invoked upon varName. */
sl@0	4002	ClientData clientData; /* Arbitrary argument to pass to proc. */
sl@0	4003	{
sl@0	4004	Command *cmdPtr;
sl@0	4005	register CommandTrace *tracePtr;
sl@0	4006
sl@0	4007	cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
sl@0	4008	NULL, TCL_LEAVE_ERR_MSG);
sl@0	4009	if (cmdPtr == NULL) {
sl@0	4010	return TCL_ERROR;
sl@0	4011	}
sl@0	4012
sl@0	4013	/*
sl@0	4014	* Set up trace information.
sl@0	4015	*/
sl@0	4016
sl@0	4017	tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace));
sl@0	4018	tracePtr->traceProc = proc;
sl@0	4019	tracePtr->clientData = clientData;
sl@0	4020	tracePtr->flags = flags & (TCL_TRACE_RENAME \| TCL_TRACE_DELETE
sl@0	4021	\| TCL_TRACE_ANY_EXEC);
sl@0	4022	tracePtr->nextPtr = cmdPtr->tracePtr;
sl@0	4023	tracePtr->refCount = 1;
sl@0	4024	cmdPtr->tracePtr = tracePtr;
sl@0	4025	if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
sl@0	4026	cmdPtr->flags \|= CMD_HAS_EXEC_TRACES;
sl@0	4027	}
sl@0	4028	return TCL_OK;
sl@0	4029	}
sl@0	4030
sl@0	4031	/*
sl@0	4032	*----------------------------------------------------------------------
sl@0	4033	*
sl@0	4034	* Tcl_UntraceCommand --
sl@0	4035	*
sl@0	4036	* Remove a previously-created trace for a command.
sl@0	4037	*
sl@0	4038	* Results:
sl@0	4039	* None.
sl@0	4040	*
sl@0	4041	* Side effects:
sl@0	4042	* If there exists a trace for the command given by cmdName
sl@0	4043	* with the given flags, proc, and clientData, then that trace
sl@0	4044	* is removed.
sl@0	4045	*
sl@0	4046	*----------------------------------------------------------------------
sl@0	4047	*/
sl@0	4048
sl@0	4049	EXPORT_C void
sl@0	4050	Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData)
sl@0	4051	Tcl_Interp interp; / Interpreter containing command. */
sl@0	4052	CONST char cmdName; / Name of command. */
sl@0	4053	int flags; /* OR-ed collection of bits, including any
sl@0	4054	* of TCL_TRACE_RENAME, TCL_TRACE_DELETE,
sl@0	4055	* and any of the TRACE__EXEC flags /
sl@0	4056	Tcl_CommandTraceProc proc; / Procedure assocated with trace. */
sl@0	4057	ClientData clientData; /* Arbitrary argument to pass to proc. */
sl@0	4058	{
sl@0	4059	register CommandTrace *tracePtr;
sl@0	4060	CommandTrace *prevPtr;
sl@0	4061	Command *cmdPtr;
sl@0	4062	Interp iPtr = (Interp ) interp;
sl@0	4063	ActiveCommandTrace *activePtr;
sl@0	4064	int hasExecTraces = 0;
sl@0	4065
sl@0	4066	cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
sl@0	4067	NULL, TCL_LEAVE_ERR_MSG);
sl@0	4068	if (cmdPtr == NULL) {
sl@0	4069	return;
sl@0	4070	}
sl@0	4071
sl@0	4072	flags &= (TCL_TRACE_RENAME \| TCL_TRACE_DELETE \| TCL_TRACE_ANY_EXEC);
sl@0	4073
sl@0	4074	for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ;
sl@0	4075	prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
sl@0	4076	if (tracePtr == NULL) {
sl@0	4077	return;
sl@0	4078	}
sl@0	4079	if ((tracePtr->traceProc == proc)
sl@0	4080	&& ((tracePtr->flags & (TCL_TRACE_RENAME \| TCL_TRACE_DELETE \|
sl@0	4081	TCL_TRACE_ANY_EXEC)) == flags)
sl@0	4082	&& (tracePtr->clientData == clientData)) {
sl@0	4083	if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
sl@0	4084	hasExecTraces = 1;
sl@0	4085	}
sl@0	4086	break;
sl@0	4087	}
sl@0	4088	}
sl@0	4089
sl@0	4090	/*
sl@0	4091	* The code below makes it possible to delete traces while traces
sl@0	4092	* are active: it makes sure that the deleted trace won't be
sl@0	4093	* processed by CallCommandTraces.
sl@0	4094	*/
sl@0	4095
sl@0	4096	for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL;
sl@0	4097	activePtr = activePtr->nextPtr) {
sl@0	4098	if (activePtr->nextTracePtr == tracePtr) {
sl@0	4099	if (activePtr->reverseScan) {
sl@0	4100	activePtr->nextTracePtr = prevPtr;
sl@0	4101	} else {
sl@0	4102	activePtr->nextTracePtr = tracePtr->nextPtr;
sl@0	4103	}
sl@0	4104	}
sl@0	4105	}
sl@0	4106	if (prevPtr == NULL) {
sl@0	4107	cmdPtr->tracePtr = tracePtr->nextPtr;
sl@0	4108	} else {
sl@0	4109	prevPtr->nextPtr = tracePtr->nextPtr;
sl@0	4110	}
sl@0	4111	tracePtr->flags = 0;
sl@0	4112
sl@0	4113	if ((--tracePtr->refCount) <= 0) {
sl@0	4114	ckfree((char*)tracePtr);
sl@0	4115	}
sl@0	4116
sl@0	4117	if (hasExecTraces) {
sl@0	4118	for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ;
sl@0	4119	prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
sl@0	4120	if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
sl@0	4121	return;
sl@0	4122	}
sl@0	4123	}
sl@0	4124	/*
sl@0	4125	* None of the remaining traces on this command are execution
sl@0	4126	* traces. We therefore remove this flag:
sl@0	4127	*/
sl@0	4128	cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;
sl@0	4129	}
sl@0	4130	}
sl@0	4131
sl@0	4132	/*
sl@0	4133	*----------------------------------------------------------------------
sl@0	4134	*
sl@0	4135	* TraceCommandProc --
sl@0	4136	*
sl@0	4137	* This procedure is called to handle command changes that have
sl@0	4138	* been traced using the "trace" command, when using the
sl@0	4139	* 'rename' or 'delete' options.
sl@0	4140	*
sl@0	4141	* Results:
sl@0	4142	* None.
sl@0	4143	*
sl@0	4144	* Side effects:
sl@0	4145	* Depends on the command associated with the trace.
sl@0	4146	*
sl@0	4147	*----------------------------------------------------------------------
sl@0	4148	*/
sl@0	4149
sl@0	4150	/* ARGSUSED */
sl@0	4151	static void
sl@0	4152	TraceCommandProc(clientData, interp, oldName, newName, flags)
sl@0	4153	ClientData clientData; /* Information about the command trace. */
sl@0	4154	Tcl_Interp interp; / Interpreter containing command. */
sl@0	4155	CONST char oldName; / Name of command being changed. */
sl@0	4156	CONST char newName; / New name of command. Empty string
sl@0	4157	* or NULL means command is being deleted
sl@0	4158	* (renamed to ""). */
sl@0	4159	int flags; /* OR-ed bits giving operation and other
sl@0	4160	* information. */
sl@0	4161	{
sl@0	4162	Interp iPtr = (Interp ) interp;
sl@0	4163	int stateCode;
sl@0	4164	Tcl_SavedResult state;
sl@0	4165	TraceCommandInfo tcmdPtr = (TraceCommandInfo ) clientData;
sl@0	4166	int code;
sl@0	4167	Tcl_DString cmd;
sl@0	4168
sl@0	4169	tcmdPtr->refCount++;
sl@0	4170
sl@0	4171	if ((tcmdPtr->flags & flags) && !Tcl_InterpDeleted(interp)) {
sl@0	4172	/*
sl@0	4173	* Generate a command to execute by appending list elements
sl@0	4174	* for the old and new command name and the operation.
sl@0	4175	*/
sl@0	4176
sl@0	4177	Tcl_DStringInit(&cmd);
sl@0	4178	Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length);
sl@0	4179	Tcl_DStringAppendElement(&cmd, oldName);
sl@0	4180	Tcl_DStringAppendElement(&cmd, (newName ? newName : ""));
sl@0	4181	if (flags & TCL_TRACE_RENAME) {
sl@0	4182	Tcl_DStringAppend(&cmd, " rename", 7);
sl@0	4183	} else if (flags & TCL_TRACE_DELETE) {
sl@0	4184	Tcl_DStringAppend(&cmd, " delete", 7);
sl@0	4185	}
sl@0	4186
sl@0	4187	/*
sl@0	4188	* Execute the command. Save the interp's result used for the
sl@0	4189	* command, including the value of iPtr->returnCode which may be
sl@0	4190	* modified when Tcl_Eval is invoked. We discard any object
sl@0	4191	* result the command returns.
sl@0	4192	*
sl@0	4193	* Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to
sl@0	4194	* other areas that this will be destroyed by us, otherwise a
sl@0	4195	* double-free might occur depending on what the eval does.
sl@0	4196	*/
sl@0	4197
sl@0	4198	Tcl_SaveResult(interp, &state);
sl@0	4199	stateCode = iPtr->returnCode;
sl@0	4200	if (flags & TCL_TRACE_DESTROYED) {
sl@0	4201	tcmdPtr->flags \|= TCL_TRACE_DESTROYED;
sl@0	4202	}
sl@0	4203
sl@0	4204	code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
sl@0	4205	Tcl_DStringLength(&cmd), 0);
sl@0	4206	if (code != TCL_OK) {
sl@0	4207	/* We ignore errors in these traced commands */
sl@0	4208	}
sl@0	4209
sl@0	4210	Tcl_RestoreResult(interp, &state);
sl@0	4211	iPtr->returnCode = stateCode;
sl@0	4212
sl@0	4213	Tcl_DStringFree(&cmd);
sl@0	4214	}
sl@0	4215	/*
sl@0	4216	* We delete when the trace was destroyed or if this is a delete trace,
sl@0	4217	* because command deletes are unconditional, so the trace must go away.
sl@0	4218	*/
sl@0	4219	if (flags & (TCL_TRACE_DESTROYED \| TCL_TRACE_DELETE)) {
sl@0	4220	int untraceFlags = tcmdPtr->flags;
sl@0	4221
sl@0	4222	if (tcmdPtr->stepTrace != NULL) {
sl@0	4223	Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
sl@0	4224	tcmdPtr->stepTrace = NULL;
sl@0	4225	if (tcmdPtr->startCmd != NULL) {
sl@0	4226	ckfree((char *)tcmdPtr->startCmd);
sl@0	4227	}
sl@0	4228	}
sl@0	4229	if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
sl@0	4230	/* Postpone deletion, until exec trace returns */
sl@0	4231	tcmdPtr->flags = 0;
sl@0	4232	}
sl@0	4233
sl@0	4234	/*
sl@0	4235	* We need to construct the same flags for Tcl_UntraceCommand
sl@0	4236	* as were passed to Tcl_TraceCommand. Reproduce the processing
sl@0	4237	* of [trace add execution/command]. Be careful to keep this
sl@0	4238	* code in sync with that.
sl@0	4239	*/
sl@0	4240
sl@0	4241	if (untraceFlags & TCL_TRACE_ANY_EXEC) {
sl@0	4242	untraceFlags \|= TCL_TRACE_DELETE;
sl@0	4243	if (untraceFlags & (TCL_TRACE_ENTER_DURING_EXEC
sl@0	4244	\| TCL_TRACE_LEAVE_DURING_EXEC)) {
sl@0	4245	untraceFlags \|= (TCL_TRACE_ENTER_EXEC \| TCL_TRACE_LEAVE_EXEC);
sl@0	4246	}
sl@0	4247	} else if (untraceFlags & TCL_TRACE_RENAME) {
sl@0	4248	untraceFlags \|= TCL_TRACE_DELETE;
sl@0	4249	}
sl@0	4250
sl@0	4251	/*
sl@0	4252	* Remove the trace since TCL_TRACE_DESTROYED tells us to, or the
sl@0	4253	* command we're tracing has just gone away. Then decrement the
sl@0	4254	* clientData refCount that was set up by trace creation.
sl@0	4255	*
sl@0	4256	* Note that we save the (return) state of the interpreter to prevent
sl@0	4257	* bizarre error messages.
sl@0	4258	*/
sl@0	4259
sl@0	4260	Tcl_SaveResult(interp, &state);
sl@0	4261	stateCode = iPtr->returnCode;
sl@0	4262	Tcl_UntraceCommand(interp, oldName, untraceFlags,
sl@0	4263	TraceCommandProc, clientData);
sl@0	4264	Tcl_RestoreResult(interp, &state);
sl@0	4265	iPtr->returnCode = stateCode;
sl@0	4266
sl@0	4267	tcmdPtr->refCount--;
sl@0	4268	}
sl@0	4269	tcmdPtr->refCount--;
sl@0	4270	if (tcmdPtr->refCount < 0) {
sl@0	4271	Tcl_Panic("TraceCommandProc: negative TraceCommandInfo refCount");
sl@0	4272	}
sl@0	4273	if (tcmdPtr->refCount == 0) {
sl@0	4274	ckfree((char*)tcmdPtr);
sl@0	4275	}
sl@0	4276	return;
sl@0	4277	}
sl@0	4278
sl@0	4279	/*
sl@0	4280	*----------------------------------------------------------------------
sl@0	4281	*
sl@0	4282	* TclCheckExecutionTraces --
sl@0	4283	*
sl@0	4284	* Checks on all current command execution traces, and invokes
sl@0	4285	* procedures which have been registered. This procedure can be
sl@0	4286	* used by other code which performs execution to unify the
sl@0	4287	* tracing system, so that execution traces will function for that
sl@0	4288	* other code.
sl@0	4289	*
sl@0	4290	* For instance extensions like [incr Tcl] which use their
sl@0	4291	* own execution technique can make use of Tcl's tracing.
sl@0	4292	*
sl@0	4293	* This procedure is called by 'TclEvalObjvInternal'
sl@0	4294	*
sl@0	4295	* Results:
sl@0	4296	* The return value is a standard Tcl completion code such as
sl@0	4297	* TCL_OK or TCL_ERROR, etc.
sl@0	4298	*
sl@0	4299	* Side effects:
sl@0	4300	* Those side effects made by any trace procedures called.
sl@0	4301	*
sl@0	4302	*----------------------------------------------------------------------
sl@0	4303	*/
sl@0	4304	int
sl@0	4305	TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code,
sl@0	4306	traceFlags, objc, objv)
sl@0	4307	Tcl_Interp interp; / The current interpreter. */
sl@0	4308	CONST char command; / Pointer to beginning of the current
sl@0	4309	* command string. */
sl@0	4310	int numChars; /* The number of characters in 'command'
sl@0	4311	* which are part of the command string. */
sl@0	4312	Command cmdPtr; / Points to command's Command struct. */
sl@0	4313	int code; /* The current result code. */
sl@0	4314	int traceFlags; /* Current tracing situation. */
sl@0	4315	int objc; /* Number of arguments for the command. */
sl@0	4316	Tcl_Obj CONST objv[]; / Pointers to Tcl_Obj of each argument. */
sl@0	4317	{
sl@0	4318	Interp iPtr = (Interp ) interp;
sl@0	4319	CommandTrace tracePtr, lastTracePtr;
sl@0	4320	ActiveCommandTrace active;
sl@0	4321	int curLevel;
sl@0	4322	int traceCode = TCL_OK;
sl@0	4323	TraceCommandInfo* tcmdPtr;
sl@0	4324
sl@0	4325	if (command == NULL \|\| cmdPtr->tracePtr == NULL) {
sl@0	4326	return traceCode;
sl@0	4327	}
sl@0	4328
sl@0	4329	curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level);
sl@0	4330
sl@0	4331	active.nextPtr = iPtr->activeCmdTracePtr;
sl@0	4332	iPtr->activeCmdTracePtr = &active;
sl@0	4333
sl@0	4334	active.cmdPtr = cmdPtr;
sl@0	4335	lastTracePtr = NULL;
sl@0	4336	for (tracePtr = cmdPtr->tracePtr;
sl@0	4337	(traceCode == TCL_OK) && (tracePtr != NULL);
sl@0	4338	tracePtr = active.nextTracePtr) {
sl@0	4339	if (traceFlags & TCL_TRACE_LEAVE_EXEC) {
sl@0	4340	/* execute the trace command in order of creation for "leave" */
sl@0	4341	active.reverseScan = 1;
sl@0	4342	active.nextTracePtr = NULL;
sl@0	4343	tracePtr = cmdPtr->tracePtr;
sl@0	4344	while (tracePtr->nextPtr != lastTracePtr) {
sl@0	4345	active.nextTracePtr = tracePtr;
sl@0	4346	tracePtr = tracePtr->nextPtr;
sl@0	4347	}
sl@0	4348	} else {
sl@0	4349	active.reverseScan = 0;
sl@0	4350	active.nextTracePtr = tracePtr->nextPtr;
sl@0	4351	}
sl@0	4352	if (tracePtr->traceProc == TraceCommandProc) {
sl@0	4353	tcmdPtr = (TraceCommandInfo*)tracePtr->clientData;
sl@0	4354	if (tcmdPtr->flags != 0) {
sl@0	4355	tcmdPtr->curFlags = traceFlags \| TCL_TRACE_EXEC_DIRECT;
sl@0	4356	tcmdPtr->curCode = code;
sl@0	4357	tcmdPtr->refCount++;
sl@0	4358	traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp,
sl@0	4359	curLevel, command, (Tcl_Command)cmdPtr, objc, objv);
sl@0	4360	tcmdPtr->refCount--;
sl@0	4361	if (tcmdPtr->refCount < 0) {
sl@0	4362	Tcl_Panic("TclCheckExecutionTraces: negative TraceCommandInfo refCount");
sl@0	4363	}
sl@0	4364	if (tcmdPtr->refCount == 0) {
sl@0	4365	ckfree((char*)tcmdPtr);
sl@0	4366	}
sl@0	4367	}
sl@0	4368	}
sl@0	4369	if (active.nextTracePtr) {
sl@0	4370	lastTracePtr = active.nextTracePtr->nextPtr;
sl@0	4371	}
sl@0	4372	}
sl@0	4373	iPtr->activeCmdTracePtr = active.nextPtr;
sl@0	4374	return(traceCode);
sl@0	4375	}
sl@0	4376
sl@0	4377	/*
sl@0	4378	*----------------------------------------------------------------------
sl@0	4379	*
sl@0	4380	* TclCheckInterpTraces --
sl@0	4381	*
sl@0	4382	* Checks on all current traces, and invokes procedures which
sl@0	4383	* have been registered. This procedure can be used by other
sl@0	4384	* code which performs execution to unify the tracing system.
sl@0	4385	* For instance extensions like [incr Tcl] which use their
sl@0	4386	* own execution technique can make use of Tcl's tracing.
sl@0	4387	*
sl@0	4388	* This procedure is called by 'TclEvalObjvInternal'
sl@0	4389	*
sl@0	4390	* Results:
sl@0	4391	* The return value is a standard Tcl completion code such as
sl@0	4392	* TCL_OK or TCL_ERROR, etc.
sl@0	4393	*
sl@0	4394	* Side effects:
sl@0	4395	* Those side effects made by any trace procedures called.
sl@0	4396	*
sl@0	4397	*----------------------------------------------------------------------
sl@0	4398	*/
sl@0	4399	int
sl@0	4400	TclCheckInterpTraces(interp, command, numChars, cmdPtr, code,
sl@0	4401	traceFlags, objc, objv)
sl@0	4402	Tcl_Interp interp; / The current interpreter. */
sl@0	4403	CONST char command; / Pointer to beginning of the current
sl@0	4404	* command string. */
sl@0	4405	int numChars; /* The number of characters in 'command'
sl@0	4406	* which are part of the command string. */
sl@0	4407	Command cmdPtr; / Points to command's Command struct. */
sl@0	4408	int code; /* The current result code. */
sl@0	4409	int traceFlags; /* Current tracing situation. */
sl@0	4410	int objc; /* Number of arguments for the command. */
sl@0	4411	Tcl_Obj CONST objv[]; / Pointers to Tcl_Obj of each argument. */
sl@0	4412	{
sl@0	4413	Interp iPtr = (Interp ) interp;
sl@0	4414	Trace tracePtr, lastTracePtr;
sl@0	4415	ActiveInterpTrace active;
sl@0	4416	int curLevel;
sl@0	4417	int traceCode = TCL_OK;
sl@0	4418
sl@0	4419	if (command == NULL \|\| iPtr->tracePtr == NULL \|\|
sl@0	4420	(iPtr->flags & INTERP_TRACE_IN_PROGRESS)) {
sl@0	4421	return(traceCode);
sl@0	4422	}
sl@0	4423
sl@0	4424	curLevel = iPtr->numLevels;
sl@0	4425
sl@0	4426	active.nextPtr = iPtr->activeInterpTracePtr;
sl@0	4427	iPtr->activeInterpTracePtr = &active;
sl@0	4428
sl@0	4429	lastTracePtr = NULL;
sl@0	4430	for ( tracePtr = iPtr->tracePtr;
sl@0	4431	(traceCode == TCL_OK) && (tracePtr != NULL);
sl@0	4432	tracePtr = active.nextTracePtr) {
sl@0	4433	if (traceFlags & TCL_TRACE_ENTER_EXEC) {
sl@0	4434	/*
sl@0	4435	* Execute the trace command in reverse order of creation
sl@0	4436	* for "enterstep" operation. The order is changed for
sl@0	4437	* "enterstep" instead of for "leavestep" as was done in
sl@0	4438	* TclCheckExecutionTraces because for step traces,
sl@0	4439	* Tcl_CreateObjTrace creates one more linked list of traces
sl@0	4440	* which results in one more reversal of trace invocation.
sl@0	4441	*/
sl@0	4442	active.reverseScan = 1;
sl@0	4443	active.nextTracePtr = NULL;
sl@0	4444	tracePtr = iPtr->tracePtr;
sl@0	4445	while (tracePtr->nextPtr != lastTracePtr) {
sl@0	4446	active.nextTracePtr = tracePtr;
sl@0	4447	tracePtr = tracePtr->nextPtr;
sl@0	4448	}
sl@0	4449	} else {
sl@0	4450	active.reverseScan = 0;
sl@0	4451	active.nextTracePtr = tracePtr->nextPtr;
sl@0	4452	}
sl@0	4453	if (tracePtr->level > 0 && curLevel > tracePtr->level) {
sl@0	4454	continue;
sl@0	4455	}
sl@0	4456	if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) {
sl@0	4457	/*
sl@0	4458	* The proc invoked might delete the traced command which
sl@0	4459	* which might try to free tracePtr. We want to use tracePtr
sl@0	4460	* until the end of this if section, so we use
sl@0	4461	* Tcl_Preserve() and Tcl_Release() to be sure it is not
sl@0	4462	* freed while we still need it.
sl@0	4463	*/
sl@0	4464	Tcl_Preserve((ClientData) tracePtr);
sl@0	4465	tracePtr->flags \|= TCL_TRACE_EXEC_IN_PROGRESS;
sl@0	4466
sl@0	4467	if (tracePtr->flags & (TCL_TRACE_ENTER_EXEC \| TCL_TRACE_LEAVE_EXEC)) {
sl@0	4468	/* New style trace */
sl@0	4469	if (tracePtr->flags & traceFlags) {
sl@0	4470	if (tracePtr->proc == TraceExecutionProc) {
sl@0	4471	TraceCommandInfo *tcmdPtr =
sl@0	4472	(TraceCommandInfo *) tracePtr->clientData;
sl@0	4473	tcmdPtr->curFlags = traceFlags;
sl@0	4474	tcmdPtr->curCode = code;
sl@0	4475	}
sl@0	4476	traceCode = (tracePtr->proc)(tracePtr->clientData,
sl@0	4477	interp, curLevel, command, (Tcl_Command)cmdPtr,
sl@0	4478	objc, objv);
sl@0	4479	}
sl@0	4480	} else {
sl@0	4481	/* Old-style trace */
sl@0	4482
sl@0	4483	if (traceFlags & TCL_TRACE_ENTER_EXEC) {
sl@0	4484	/*
sl@0	4485	* Old-style interpreter-wide traces only trigger
sl@0	4486	* before the command is executed.
sl@0	4487	*/
sl@0	4488	traceCode = CallTraceProcedure(interp, tracePtr, cmdPtr,
sl@0	4489	command, numChars, objc, objv);
sl@0	4490	}
sl@0	4491	}
sl@0	4492	tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
sl@0	4493	Tcl_Release((ClientData) tracePtr);
sl@0	4494	}
sl@0	4495	if (active.nextTracePtr) {
sl@0	4496	lastTracePtr = active.nextTracePtr->nextPtr;
sl@0	4497	}
sl@0	4498	}
sl@0	4499	iPtr->activeInterpTracePtr = active.nextPtr;
sl@0	4500	return(traceCode);
sl@0	4501	}
sl@0	4502
sl@0	4503	/*
sl@0	4504	*----------------------------------------------------------------------
sl@0	4505	*
sl@0	4506	* CallTraceProcedure --
sl@0	4507	*
sl@0	4508	* Invokes a trace procedure registered with an interpreter. These
sl@0	4509	* procedures trace command execution. Currently this trace procedure
sl@0	4510	* is called with the address of the string-based Tcl_CmdProc for the
sl@0	4511	* command, not the Tcl_ObjCmdProc.
sl@0	4512	*
sl@0	4513	* Results:
sl@0	4514	* None.
sl@0	4515	*
sl@0	4516	* Side effects:
sl@0	4517	* Those side effects made by the trace procedure.
sl@0	4518	*
sl@0	4519	*----------------------------------------------------------------------
sl@0	4520	*/
sl@0	4521
sl@0	4522	static int
sl@0	4523	CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
sl@0	4524	Tcl_Interp interp; / The current interpreter. */
sl@0	4525	register Trace tracePtr; / Describes the trace procedure to call. */
sl@0	4526	Command cmdPtr; / Points to command's Command struct. */
sl@0	4527	CONST char command; / Points to the first character of the
sl@0	4528	* command's source before substitutions. */
sl@0	4529	int numChars; /* The number of characters in the
sl@0	4530	* command's source. */
sl@0	4531	register int objc; /* Number of arguments for the command. */
sl@0	4532	Tcl_Obj CONST objv[]; / Pointers to Tcl_Obj of each argument. */
sl@0	4533	{
sl@0	4534	Interp iPtr = (Interp ) interp;
sl@0	4535	char *commandCopy;
sl@0	4536	int traceCode;
sl@0	4537
sl@0	4538	/*
sl@0	4539	* Copy the command characters into a new string.
sl@0	4540	*/
sl@0	4541
sl@0	4542	commandCopy = (char *) ckalloc((unsigned) (numChars + 1));
sl@0	4543	memcpy((VOID ) commandCopy, (VOID ) command, (size_t) numChars);
sl@0	4544	commandCopy[numChars] = '\0';
sl@0	4545
sl@0	4546	/*
sl@0	4547	* Call the trace procedure then free allocated storage.
sl@0	4548	*/
sl@0	4549
sl@0	4550	traceCode = (tracePtr->proc)( tracePtr->clientData, (Tcl_Interp*) iPtr,
sl@0	4551	iPtr->numLevels, commandCopy,
sl@0	4552	(Tcl_Command) cmdPtr, objc, objv );
sl@0	4553
sl@0	4554	ckfree((char *) commandCopy);
sl@0	4555	return(traceCode);
sl@0	4556	}
sl@0	4557
sl@0	4558	/*
sl@0	4559	*----------------------------------------------------------------------
sl@0	4560	*
sl@0	4561	* CommandObjTraceDeleted --
sl@0	4562	*
sl@0	4563	* Ensure the trace is correctly deleted by decrementing its
sl@0	4564	* refCount and only deleting if no other references exist.
sl@0	4565	*
sl@0	4566	* Results:
sl@0	4567	* None.
sl@0	4568	*
sl@0	4569	* Side effects:
sl@0	4570	* May release memory.
sl@0	4571	*
sl@0	4572	*----------------------------------------------------------------------
sl@0	4573	*/
sl@0	4574	static void
sl@0	4575	CommandObjTraceDeleted(ClientData clientData) {
sl@0	4576	TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData;
sl@0	4577	tcmdPtr->refCount--;
sl@0	4578	if (tcmdPtr->refCount < 0) {
sl@0	4579	Tcl_Panic("CommandObjTraceDeleted: negative TraceCommandInfo refCount");
sl@0	4580	}
sl@0	4581	if (tcmdPtr->refCount == 0) {
sl@0	4582	ckfree((char*)tcmdPtr);
sl@0	4583	}
sl@0	4584	}
sl@0	4585
sl@0	4586	/*
sl@0	4587	*----------------------------------------------------------------------
sl@0	4588	*
sl@0	4589	* TraceExecutionProc --
sl@0	4590	*
sl@0	4591	* This procedure is invoked whenever code relevant to a
sl@0	4592	* 'trace execution' command is executed. It is called in one
sl@0	4593	* of two ways in Tcl's core:
sl@0	4594	*
sl@0	4595	* (i) by the TclCheckExecutionTraces, when an execution trace
sl@0	4596	* has been triggered.
sl@0	4597	* (ii) by TclCheckInterpTraces, when a prior execution trace has
sl@0	4598	* created a trace of the internals of a procedure, passing in
sl@0	4599	* this procedure as the one to be called.
sl@0	4600	*
sl@0	4601	* Results:
sl@0	4602	* The return value is a standard Tcl completion code such as
sl@0	4603	* TCL_OK or TCL_ERROR, etc.
sl@0	4604	*
sl@0	4605	* Side effects:
sl@0	4606	* May invoke an arbitrary Tcl procedure, and may create or
sl@0	4607	* delete an interpreter-wide trace.
sl@0	4608	*
sl@0	4609	*----------------------------------------------------------------------
sl@0	4610	*/
sl@0	4611	static int
sl@0	4612	TraceExecutionProc(ClientData clientData, Tcl_Interp *interp,
sl@0	4613	int level, CONST char* command, Tcl_Command cmdInfo,
sl@0	4614	int objc, struct Tcl_Obj *CONST objv[]) {
sl@0	4615	int call = 0;
sl@0	4616	Interp iPtr = (Interp ) interp;
sl@0	4617	TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData;
sl@0	4618	int flags = tcmdPtr->curFlags;
sl@0	4619	int code = tcmdPtr->curCode;
sl@0	4620	int traceCode = TCL_OK;
sl@0	4621
sl@0	4622	if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
sl@0	4623	/*
sl@0	4624	* Inside any kind of execution trace callback, we do
sl@0	4625	* not allow any further execution trace callbacks to
sl@0	4626	* be called for the same trace.
sl@0	4627	*/
sl@0	4628	return traceCode;
sl@0	4629	}
sl@0	4630
sl@0	4631	if (!Tcl_InterpDeleted(interp)) {
sl@0	4632	/*
sl@0	4633	* Check whether the current call is going to eval arbitrary
sl@0	4634	* Tcl code with a generated trace, or whether we are only
sl@0	4635	* going to setup interpreter-wide traces to implement the
sl@0	4636	* 'step' traces. This latter situation can happen if
sl@0	4637	* we create a command trace without either before or after
sl@0	4638	* operations, but with either of the step operations.
sl@0	4639	*/
sl@0	4640	if (flags & TCL_TRACE_EXEC_DIRECT) {
sl@0	4641	call = flags & tcmdPtr->flags
sl@0	4642	& (TCL_TRACE_ENTER_EXEC \| TCL_TRACE_LEAVE_EXEC);
sl@0	4643	} else {
sl@0	4644	call = 1;
sl@0	4645	}
sl@0	4646	/*
sl@0	4647	* First, if we have returned back to the level at which we
sl@0	4648	* created an interpreter trace for enterstep and/or leavestep
sl@0	4649	* execution traces, we remove it here.
sl@0	4650	*/
sl@0	4651	if (flags & TCL_TRACE_LEAVE_EXEC) {
sl@0	4652	if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel)
sl@0	4653	&& (strcmp(command, tcmdPtr->startCmd) == 0)) {
sl@0	4654	Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
sl@0	4655	tcmdPtr->stepTrace = NULL;
sl@0	4656	if (tcmdPtr->startCmd != NULL) {
sl@0	4657	ckfree((char *)tcmdPtr->startCmd);
sl@0	4658	}
sl@0	4659	}
sl@0	4660	}
sl@0	4661
sl@0	4662	/*
sl@0	4663	* Second, create the tcl callback, if required.
sl@0	4664	*/
sl@0	4665	if (call) {
sl@0	4666	Tcl_SavedResult state;
sl@0	4667	int stateCode, i, saveInterpFlags;
sl@0	4668	Tcl_DString cmd;
sl@0	4669	Tcl_DString sub;
sl@0	4670
sl@0	4671	Tcl_DStringInit(&cmd);
sl@0	4672	Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length);
sl@0	4673	/* Append command with arguments */
sl@0	4674	Tcl_DStringInit(&sub);
sl@0	4675	for (i = 0; i < objc; i++) {
sl@0	4676	char* str;
sl@0	4677	int len;
sl@0	4678	str = Tcl_GetStringFromObj(objv[i],&len);
sl@0	4679	Tcl_DStringAppendElement(&sub, str);
sl@0	4680	}
sl@0	4681	Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub));
sl@0	4682	Tcl_DStringFree(&sub);
sl@0	4683
sl@0	4684	if (flags & TCL_TRACE_ENTER_EXEC) {
sl@0	4685	/* Append trace operation */
sl@0	4686	if (flags & TCL_TRACE_EXEC_DIRECT) {
sl@0	4687	Tcl_DStringAppendElement(&cmd, "enter");
sl@0	4688	} else {
sl@0	4689	Tcl_DStringAppendElement(&cmd, "enterstep");
sl@0	4690	}
sl@0	4691	} else if (flags & TCL_TRACE_LEAVE_EXEC) {
sl@0	4692	Tcl_Obj* resultCode;
sl@0	4693	char* resultCodeStr;
sl@0	4694
sl@0	4695	/* Append result code */
sl@0	4696	resultCode = Tcl_NewIntObj(code);
sl@0	4697	resultCodeStr = Tcl_GetString(resultCode);
sl@0	4698	Tcl_DStringAppendElement(&cmd, resultCodeStr);
sl@0	4699	Tcl_DecrRefCount(resultCode);
sl@0	4700
sl@0	4701	/* Append result string */
sl@0	4702	Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp));
sl@0	4703	/* Append trace operation */
sl@0	4704	if (flags & TCL_TRACE_EXEC_DIRECT) {
sl@0	4705	Tcl_DStringAppendElement(&cmd, "leave");
sl@0	4706	} else {
sl@0	4707	Tcl_DStringAppendElement(&cmd, "leavestep");
sl@0	4708	}
sl@0	4709	} else {
sl@0	4710	panic("TraceExecutionProc: bad flag combination");
sl@0	4711	}
sl@0	4712
sl@0	4713	/*
sl@0	4714	* Execute the command. Save the interp's result used for
sl@0	4715	* the command, including the value of iPtr->returnCode which
sl@0	4716	* may be modified when Tcl_Eval is invoked. We discard any
sl@0	4717	* object result the command returns.
sl@0	4718	*/
sl@0	4719
sl@0	4720	Tcl_SaveResult(interp, &state);
sl@0	4721	stateCode = iPtr->returnCode;
sl@0	4722
sl@0	4723	saveInterpFlags = iPtr->flags;
sl@0	4724	iPtr->flags \|= INTERP_TRACE_IN_PROGRESS;
sl@0	4725	tcmdPtr->flags \|= TCL_TRACE_EXEC_IN_PROGRESS;
sl@0	4726	tcmdPtr->refCount++;
sl@0	4727	/*
sl@0	4728	* This line can have quite arbitrary side-effects,
sl@0	4729	* including deleting the trace, the command being
sl@0	4730	* traced, or even the interpreter.
sl@0	4731	*/
sl@0	4732	traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
sl@0	4733	tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
sl@0	4734
sl@0	4735	/*
sl@0	4736	* Restore the interp tracing flag to prevent cmd traces
sl@0	4737	* from affecting interp traces
sl@0	4738	*/
sl@0	4739	iPtr->flags = saveInterpFlags;;
sl@0	4740	if (tcmdPtr->flags == 0) {
sl@0	4741	flags \|= TCL_TRACE_DESTROYED;
sl@0	4742	}
sl@0	4743
sl@0	4744	if (traceCode == TCL_OK) {
sl@0	4745	/* Restore result if trace execution was successful */
sl@0	4746	Tcl_RestoreResult(interp, &state);
sl@0	4747	iPtr->returnCode = stateCode;
sl@0	4748	} else {
sl@0	4749	Tcl_DiscardResult(&state);
sl@0	4750	}
sl@0	4751
sl@0	4752	Tcl_DStringFree(&cmd);
sl@0	4753	}
sl@0	4754
sl@0	4755	/*
sl@0	4756	* Third, if there are any step execution traces for this proc,
sl@0	4757	* we register an interpreter trace to invoke enterstep and/or
sl@0	4758	* leavestep traces.
sl@0	4759	* We also need to save the current stack level and the proc
sl@0	4760	* string in startLevel and startCmd so that we can delete this
sl@0	4761	* interpreter trace when it reaches the end of this proc.
sl@0	4762	*/
sl@0	4763	if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL)
sl@0	4764	&& (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC \|
sl@0	4765	TCL_TRACE_LEAVE_DURING_EXEC))) {
sl@0	4766	tcmdPtr->startLevel = level;
sl@0	4767	tcmdPtr->startCmd =
sl@0	4768	(char *) ckalloc((unsigned) (strlen(command) + 1));
sl@0	4769	strcpy(tcmdPtr->startCmd, command);
sl@0	4770	tcmdPtr->refCount++;
sl@0	4771	tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0,
sl@0	4772	(tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2,
sl@0	4773	TraceExecutionProc, (ClientData)tcmdPtr,
sl@0	4774	CommandObjTraceDeleted);
sl@0	4775	}
sl@0	4776	}
sl@0	4777	if (flags & TCL_TRACE_DESTROYED) {
sl@0	4778	if (tcmdPtr->stepTrace != NULL) {
sl@0	4779	Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
sl@0	4780	tcmdPtr->stepTrace = NULL;
sl@0	4781	if (tcmdPtr->startCmd != NULL) {
sl@0	4782	ckfree((char *)tcmdPtr->startCmd);
sl@0	4783	}
sl@0	4784	}
sl@0	4785	}
sl@0	4786	if (call) {
sl@0	4787	tcmdPtr->refCount--;
sl@0	4788	if (tcmdPtr->refCount < 0) {
sl@0	4789	Tcl_Panic("TraceExecutionProc: negative TraceCommandInfo refCount");
sl@0	4790	}
sl@0	4791	if (tcmdPtr->refCount == 0) {
sl@0	4792	ckfree((char*)tcmdPtr);
sl@0	4793	}
sl@0	4794	}
sl@0	4795	return traceCode;
sl@0	4796	}
sl@0	4797
sl@0	4798	/*
sl@0	4799	*----------------------------------------------------------------------
sl@0	4800	*
sl@0	4801	* TraceVarProc --
sl@0	4802	*
sl@0	4803	* This procedure is called to handle variable accesses that have
sl@0	4804	* been traced using the "trace" command.
sl@0	4805	*
sl@0	4806	* Results:
sl@0	4807	* Normally returns NULL. If the trace command returns an error,
sl@0	4808	* then this procedure returns an error string.
sl@0	4809	*
sl@0	4810	* Side effects:
sl@0	4811	* Depends on the command associated with the trace.
sl@0	4812	*
sl@0	4813	*----------------------------------------------------------------------
sl@0	4814	*/
sl@0	4815
sl@0	4816	/* ARGSUSED */
sl@0	4817	static char *
sl@0	4818	TraceVarProc(clientData, interp, name1, name2, flags)
sl@0	4819	ClientData clientData; /* Information about the variable trace. */
sl@0	4820	Tcl_Interp interp; / Interpreter containing variable. */
sl@0	4821	CONST char name1; / Name of variable or array. */
sl@0	4822	CONST char name2; / Name of element within array; NULL means
sl@0	4823	* scalar variable is being referenced. */
sl@0	4824	int flags; /* OR-ed bits giving operation and other
sl@0	4825	* information. */
sl@0	4826	{
sl@0	4827	Tcl_SavedResult state;
sl@0	4828	TraceVarInfo tvarPtr = (TraceVarInfo ) clientData;
sl@0	4829	char *result;
sl@0	4830	int code, destroy = 0;
sl@0	4831	Tcl_DString cmd;
sl@0	4832
sl@0	4833	/*
sl@0	4834	* We might call Tcl_Eval() below, and that might evaluate [trace
sl@0	4835	* vdelete] which might try to free tvarPtr. However we do not
sl@0	4836	* need to protect anything here; it's done by our caller because
sl@0	4837	* the TraceVarInfo is really part of a CompoundVarTrace. [Bug 1348775]
sl@0	4838	*/
sl@0	4839
sl@0	4840	result = NULL;
sl@0	4841	if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp)) {
sl@0	4842	if (tvarPtr->length != (size_t) 0) {
sl@0	4843	/*
sl@0	4844	* Generate a command to execute by appending list elements
sl@0	4845	* for the two variable names and the operation.
sl@0	4846	*/
sl@0	4847
sl@0	4848	Tcl_DStringInit(&cmd);
sl@0	4849	Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);
sl@0	4850	Tcl_DStringAppendElement(&cmd, name1);
sl@0	4851	Tcl_DStringAppendElement(&cmd, (name2 ? name2 : ""));
sl@0	4852	#ifndef TCL_REMOVE_OBSOLETE_TRACES
sl@0	4853	if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) {
sl@0	4854	if (flags & TCL_TRACE_ARRAY) {
sl@0	4855	Tcl_DStringAppend(&cmd, " a", 2);
sl@0	4856	} else if (flags & TCL_TRACE_READS) {
sl@0	4857	Tcl_DStringAppend(&cmd, " r", 2);
sl@0	4858	} else if (flags & TCL_TRACE_WRITES) {
sl@0	4859	Tcl_DStringAppend(&cmd, " w", 2);
sl@0	4860	} else if (flags & TCL_TRACE_UNSETS) {
sl@0	4861	Tcl_DStringAppend(&cmd, " u", 2);
sl@0	4862	}
sl@0	4863	} else {
sl@0	4864	#endif
sl@0	4865	if (flags & TCL_TRACE_ARRAY) {
sl@0	4866	Tcl_DStringAppend(&cmd, " array", 6);
sl@0	4867	} else if (flags & TCL_TRACE_READS) {
sl@0	4868	Tcl_DStringAppend(&cmd, " read", 5);
sl@0	4869	} else if (flags & TCL_TRACE_WRITES) {
sl@0	4870	Tcl_DStringAppend(&cmd, " write", 6);
sl@0	4871	} else if (flags & TCL_TRACE_UNSETS) {
sl@0	4872	Tcl_DStringAppend(&cmd, " unset", 6);
sl@0	4873	}
sl@0	4874	#ifndef TCL_REMOVE_OBSOLETE_TRACES
sl@0	4875	}
sl@0	4876	#endif
sl@0	4877
sl@0	4878	/*
sl@0	4879	* Execute the command. Save the interp's result used for
sl@0	4880	* the command. We discard any object result the command returns.
sl@0	4881	*
sl@0	4882	* Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to
sl@0	4883	* other areas that this will be destroyed by us, otherwise a
sl@0	4884	* double-free might occur depending on what the eval does.
sl@0	4885	*/
sl@0	4886
sl@0	4887	Tcl_SaveResult(interp, &state);
sl@0	4888	if ((flags & TCL_TRACE_DESTROYED)
sl@0	4889	&& !(tvarPtr->flags & TCL_TRACE_DESTROYED)) {
sl@0	4890	destroy = 1;
sl@0	4891	tvarPtr->flags \|= TCL_TRACE_DESTROYED;
sl@0	4892	}
sl@0	4893
sl@0	4894	code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
sl@0	4895	Tcl_DStringLength(&cmd), 0);
sl@0	4896	if (code != TCL_OK) { /* copy error msg to result */
sl@0	4897	register Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp);
sl@0	4898	Tcl_IncrRefCount(errMsgObj);
sl@0	4899	result = (char *) errMsgObj;
sl@0	4900	}
sl@0	4901
sl@0	4902	Tcl_RestoreResult(interp, &state);
sl@0	4903
sl@0	4904	Tcl_DStringFree(&cmd);
sl@0	4905	}
sl@0	4906	}
sl@0	4907	if (destroy) {
sl@0	4908	if (result != NULL) {
sl@0	4909	register Tcl_Obj errMsgObj = (Tcl_Obj ) result;
sl@0	4910
sl@0	4911	Tcl_DecrRefCount(errMsgObj);
sl@0	4912	result = NULL;
sl@0	4913	}
sl@0	4914	}
sl@0	4915	return result;
sl@0	4916	}
sl@0	4917
sl@0	4918	/*
sl@0	4919	*----------------------------------------------------------------------
sl@0	4920	*
sl@0	4921	* Tcl_WhileObjCmd --
sl@0	4922	*
sl@0	4923	* This procedure is invoked to process the "while" Tcl command.
sl@0	4924	* See the user documentation for details on what it does.
sl@0	4925	*
sl@0	4926	* With the bytecode compiler, this procedure is only called when
sl@0	4927	* a command name is computed at runtime, and is "while" or the name
sl@0	4928	* to which "while" was renamed: e.g., "set z while; $z {$i<100} {}"
sl@0	4929	*
sl@0	4930	* Results:
sl@0	4931	* A standard Tcl result.
sl@0	4932	*
sl@0	4933	* Side effects:
sl@0	4934	* See the user documentation.
sl@0	4935	*
sl@0	4936	*----------------------------------------------------------------------
sl@0	4937	*/
sl@0	4938
sl@0	4939	/* ARGSUSED */
sl@0	4940	int
sl@0	4941	Tcl_WhileObjCmd(dummy, interp, objc, objv)
sl@0	4942	ClientData dummy; /* Not used. */
sl@0	4943	Tcl_Interp interp; / Current interpreter. */
sl@0	4944	int objc; /* Number of arguments. */
sl@0	4945	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	4946	{
sl@0	4947	int result, value;
sl@0	4948	#ifdef TCL_TIP280
sl@0	4949	Interp* iPtr = (Interp*) interp;
sl@0	4950	#endif
sl@0	4951
sl@0	4952	if (objc != 3) {
sl@0	4953	Tcl_WrongNumArgs(interp, 1, objv, "test command");
sl@0	4954	return TCL_ERROR;
sl@0	4955	}
sl@0	4956
sl@0	4957	while (1) {
sl@0	4958	result = Tcl_ExprBooleanObj(interp, objv[1], &value);
sl@0	4959	if (result != TCL_OK) {
sl@0	4960	return result;
sl@0	4961	}
sl@0	4962	if (!value) {
sl@0	4963	break;
sl@0	4964	}
sl@0	4965	#ifndef TCL_TIP280
sl@0	4966	result = Tcl_EvalObjEx(interp, objv[2], 0);
sl@0	4967	#else
sl@0	4968	/* TIP #280. */
sl@0	4969	result = TclEvalObjEx(interp, objv[2], 0, iPtr->cmdFramePtr,2);
sl@0	4970	#endif
sl@0	4971	if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
sl@0	4972	if (result == TCL_ERROR) {
sl@0	4973	char msg[32 + TCL_INTEGER_SPACE];
sl@0	4974
sl@0	4975	sprintf(msg, "\n (\"while\" body line %d)",
sl@0	4976	interp->errorLine);
sl@0	4977	Tcl_AddErrorInfo(interp, msg);
sl@0	4978	}
sl@0	4979	break;
sl@0	4980	}
sl@0	4981	}
sl@0	4982	if (result == TCL_BREAK) {
sl@0	4983	result = TCL_OK;
sl@0	4984	}
sl@0	4985	if (result == TCL_OK) {
sl@0	4986	Tcl_ResetResult(interp);
sl@0	4987	}
sl@0	4988	return result;
sl@0	4989	}
sl@0	4990
sl@0	4991	#ifdef TCL_TIP280
sl@0	4992	static void
sl@0	4993	ListLines(listStr, line, n, lines)
sl@0	4994	CONST char* listStr; /* Pointer to string with list structure.
sl@0	4995	* Assumed to be valid. Assumed to contain
sl@0	4996	* n elements.
sl@0	4997	*/
sl@0	4998	int line; /* line the list as a whole starts on */
sl@0	4999	int n; /* #elements in lines */
sl@0	5000	int* lines; /* Array of line numbers, to fill */
sl@0	5001	{
sl@0	5002	int i;
sl@0	5003	int length = strlen( listStr);
sl@0	5004	CONST char *element = NULL;
sl@0	5005	CONST char* next = NULL;
sl@0	5006
sl@0	5007	for (i = 0; i < n; i++) {
sl@0	5008	TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL);
sl@0	5009
sl@0	5010	TclAdvanceLines (&line, listStr, element); /* Leading whitespace */
sl@0	5011	lines [i] = line;
sl@0	5012	length -= (next - listStr);
sl@0	5013	TclAdvanceLines (&line, element, next); /* Element */
sl@0	5014	listStr = next;
sl@0	5015
sl@0	5016	if (*element == 0) {
sl@0	5017	/* ASSERT i == n */
sl@0	5018	break;
sl@0	5019	}
sl@0	5020	}
sl@0	5021	}
sl@0	5022	#endif
sl@0	5023
sl@0	5024	/*
sl@0	5025	* Local Variables:
sl@0	5026	* mode: c
sl@0	5027	* c-basic-offset: 4
sl@0	5028	* fill-column: 78
sl@0	5029	* End:
sl@0	5030	*/
sl@0	5031

author	sl@SLION-WIN7.fritz.box
	Fri, 15 Jun 2012 03:10:57 +0200
changeset 0	bde4ae8d615e
permissions	-rw-r--r--