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

sl@0	1	/*
sl@0	2	* tclCmdIL.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	* I through L. It contains only commands in the generic core
sl@0	7	* (i.e. 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) 1993-1997 Lucent Technologies.
sl@0	11	* Copyright (c) 1994-1997 Sun Microsystems, Inc.
sl@0	12	* Copyright (c) 1998-1999 by Scriptics Corporation.
sl@0	13	* Copyright (c) 2001 by Kevin B. Kenny. 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: tclCmdIL.c,v 1.47.2.11 2007/03/10 14:57:38 dkf 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
sl@0	25	/*
sl@0	26	* During execution of the "lsort" command, structures of the following
sl@0	27	* type are used to arrange the objects being sorted into a collection
sl@0	28	* of linked lists.
sl@0	29	*/
sl@0	30
sl@0	31	typedef struct SortElement {
sl@0	32	Tcl_Obj objPtr; / Object being sorted. */
sl@0	33	int count; /* number of same elements in list */
sl@0	34	struct SortElement nextPtr; / Next element in the list, or
sl@0	35	* NULL for end of list. */
sl@0	36	} SortElement;
sl@0	37
sl@0	38	/*
sl@0	39	* The "lsort" command needs to pass certain information down to the
sl@0	40	* function that compares two list elements, and the comparison function
sl@0	41	* needs to pass success or failure information back up to the top-level
sl@0	42	* "lsort" command. The following structure is used to pass this
sl@0	43	* information.
sl@0	44	*/
sl@0	45
sl@0	46	typedef struct SortInfo {
sl@0	47	int isIncreasing; /* Nonzero means sort in increasing order. */
sl@0	48	int sortMode; /* The sort mode. One of SORTMODE_*
sl@0	49	* values defined below */
sl@0	50	Tcl_Obj compareCmdPtr; / The Tcl comparison command when sortMode
sl@0	51	* is SORTMODE_COMMAND. Pre-initialized to
sl@0	52	* hold base of command.*/
sl@0	53	int index; /* If the -index option was specified, this
sl@0	54	* holds the index of the list element
sl@0	55	* to extract for comparison. If -index
sl@0	56	* wasn't specified, this is -1. */
sl@0	57	Tcl_Interp interp; / The interpreter in which the sortis
sl@0	58	* being done. */
sl@0	59	int resultCode; /* Completion code for the lsort command.
sl@0	60	* If an error occurs during the sort this
sl@0	61	* is changed from TCL_OK to TCL_ERROR. */
sl@0	62	} SortInfo;
sl@0	63
sl@0	64	/*
sl@0	65	* The "sortMode" field of the SortInfo structure can take on any of the
sl@0	66	* following values.
sl@0	67	*/
sl@0	68
sl@0	69	#define SORTMODE_ASCII 0
sl@0	70	#define SORTMODE_INTEGER 1
sl@0	71	#define SORTMODE_REAL 2
sl@0	72	#define SORTMODE_COMMAND 3
sl@0	73	#define SORTMODE_DICTIONARY 4
sl@0	74
sl@0	75	/*
sl@0	76	* Magic values for the index field of the SortInfo structure.
sl@0	77	* Note that the index "end-1" will be translated to SORTIDX_END-1, etc.
sl@0	78	*/
sl@0	79	#define SORTIDX_NONE -1 /* Not indexed; use whole value. */
sl@0	80	#define SORTIDX_END -2 /* Indexed from end. */
sl@0	81
sl@0	82	/*
sl@0	83	* Forward declarations for procedures defined in this file:
sl@0	84	*/
sl@0	85
sl@0	86	static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	87	Tcl_Obj listPtr, CONST char pattern,
sl@0	88	int includeLinks));
sl@0	89	static int DictionaryCompare _ANSI_ARGS_((char *left,
sl@0	90	char *right));
sl@0	91	static int InfoArgsCmd _ANSI_ARGS_((ClientData dummy,
sl@0	92	Tcl_Interp *interp, int objc,
sl@0	93	Tcl_Obj *CONST objv[]));
sl@0	94	static int InfoBodyCmd _ANSI_ARGS_((ClientData dummy,
sl@0	95	Tcl_Interp *interp, int objc,
sl@0	96	Tcl_Obj *CONST objv[]));
sl@0	97	static int InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy,
sl@0	98	Tcl_Interp *interp, int objc,
sl@0	99	Tcl_Obj *CONST objv[]));
sl@0	100	static int InfoCommandsCmd _ANSI_ARGS_((ClientData dummy,
sl@0	101	Tcl_Interp *interp, int objc,
sl@0	102	Tcl_Obj *CONST objv[]));
sl@0	103	static int InfoCompleteCmd _ANSI_ARGS_((ClientData dummy,
sl@0	104	Tcl_Interp *interp, int objc,
sl@0	105	Tcl_Obj *CONST objv[]));
sl@0	106	static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy,
sl@0	107	Tcl_Interp *interp, int objc,
sl@0	108	Tcl_Obj *CONST objv[]));
sl@0	109	static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy,
sl@0	110	Tcl_Interp *interp, int objc,
sl@0	111	Tcl_Obj *CONST objv[]));
sl@0	112	#ifdef TCL_TIP280
sl@0	113	/* TIP #280 - New 'info' subcommand 'frame' */
sl@0	114	static int InfoFrameCmd _ANSI_ARGS_((ClientData dummy,
sl@0	115	Tcl_Interp *interp, int objc,
sl@0	116	Tcl_Obj *CONST objv[]));
sl@0	117	#endif
sl@0	118	static int InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy,
sl@0	119	Tcl_Interp *interp, int objc,
sl@0	120	Tcl_Obj *CONST objv[]));
sl@0	121	static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy,
sl@0	122	Tcl_Interp *interp, int objc,
sl@0	123	Tcl_Obj *CONST objv[]));
sl@0	124	static int InfoHostnameCmd _ANSI_ARGS_((ClientData dummy,
sl@0	125	Tcl_Interp *interp, int objc,
sl@0	126	Tcl_Obj *CONST objv[]));
sl@0	127	static int InfoLevelCmd _ANSI_ARGS_((ClientData dummy,
sl@0	128	Tcl_Interp *interp, int objc,
sl@0	129	Tcl_Obj *CONST objv[]));
sl@0	130	static int InfoLibraryCmd _ANSI_ARGS_((ClientData dummy,
sl@0	131	Tcl_Interp *interp, int objc,
sl@0	132	Tcl_Obj *CONST objv[]));
sl@0	133	static int InfoLoadedCmd _ANSI_ARGS_((ClientData dummy,
sl@0	134	Tcl_Interp *interp, int objc,
sl@0	135	Tcl_Obj *CONST objv[]));
sl@0	136	static int InfoLocalsCmd _ANSI_ARGS_((ClientData dummy,
sl@0	137	Tcl_Interp *interp, int objc,
sl@0	138	Tcl_Obj *CONST objv[]));
sl@0	139	static int InfoNameOfExecutableCmd _ANSI_ARGS_((
sl@0	140	ClientData dummy, Tcl_Interp *interp, int objc,
sl@0	141	Tcl_Obj *CONST objv[]));
sl@0	142	static int InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy,
sl@0	143	Tcl_Interp *interp, int objc,
sl@0	144	Tcl_Obj *CONST objv[]));
sl@0	145	static int InfoProcsCmd _ANSI_ARGS_((ClientData dummy,
sl@0	146	Tcl_Interp *interp, int objc,
sl@0	147	Tcl_Obj *CONST objv[]));
sl@0	148	static int InfoScriptCmd _ANSI_ARGS_((ClientData dummy,
sl@0	149	Tcl_Interp *interp, int objc,
sl@0	150	Tcl_Obj *CONST objv[]));
sl@0	151	static int InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy,
sl@0	152	Tcl_Interp *interp, int objc,
sl@0	153	Tcl_Obj *CONST objv[]));
sl@0	154	static int InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy,
sl@0	155	Tcl_Interp *interp, int objc,
sl@0	156	Tcl_Obj *CONST objv[]));
sl@0	157	static int InfoVarsCmd _ANSI_ARGS_((ClientData dummy,
sl@0	158	Tcl_Interp *interp, int objc,
sl@0	159	Tcl_Obj *CONST objv[]));
sl@0	160	static SortElement * MergeSort _ANSI_ARGS_((SortElement *headPt,
sl@0	161	SortInfo *infoPtr));
sl@0	162	static SortElement * MergeLists _ANSI_ARGS_((SortElement *leftPtr,
sl@0	163	SortElement rightPtr, SortInfo infoPtr));
sl@0	164	static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
sl@0	165	Tcl_Obj second, SortInfo infoPtr));
sl@0	166
sl@0	167	/*
sl@0	168	*----------------------------------------------------------------------
sl@0	169	*
sl@0	170	* Tcl_IfObjCmd --
sl@0	171	*
sl@0	172	* This procedure is invoked to process the "if" Tcl command.
sl@0	173	* See the user documentation for details on what it does.
sl@0	174	*
sl@0	175	* With the bytecode compiler, this procedure is only called when
sl@0	176	* a command name is computed at runtime, and is "if" or the name
sl@0	177	* to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}"
sl@0	178	*
sl@0	179	* Results:
sl@0	180	* A standard Tcl result.
sl@0	181	*
sl@0	182	* Side effects:
sl@0	183	* See the user documentation.
sl@0	184	*
sl@0	185	*----------------------------------------------------------------------
sl@0	186	*/
sl@0	187
sl@0	188	/* ARGSUSED */
sl@0	189	int
sl@0	190	Tcl_IfObjCmd(dummy, interp, objc, objv)
sl@0	191	ClientData dummy; /* Not used. */
sl@0	192	Tcl_Interp interp; / Current interpreter. */
sl@0	193	int objc; /* Number of arguments. */
sl@0	194	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	195	{
sl@0	196	int thenScriptIndex = 0; /* then script to be evaled after syntax check */
sl@0	197	#ifdef TCL_TIP280
sl@0	198	Interp* iPtr = (Interp*) interp;
sl@0	199	#endif
sl@0	200	int i, result, value;
sl@0	201	char *clause;
sl@0	202	i = 1;
sl@0	203	while (1) {
sl@0	204	/*
sl@0	205	* At this point in the loop, objv and objc refer to an expression
sl@0	206	* to test, either for the main expression or an expression
sl@0	207	* following an "elseif". The arguments after the expression must
sl@0	208	* be "then" (optional) and a script to execute if the expression is
sl@0	209	* true.
sl@0	210	*/
sl@0	211
sl@0	212	if (i >= objc) {
sl@0	213	clause = Tcl_GetString(objv[i-1]);
sl@0	214	Tcl_AppendResult(interp, "wrong # args: no expression after \"",
sl@0	215	clause, "\" argument", (char *) NULL);
sl@0	216	return TCL_ERROR;
sl@0	217	}
sl@0	218	if (!thenScriptIndex) {
sl@0	219	result = Tcl_ExprBooleanObj(interp, objv[i], &value);
sl@0	220	if (result != TCL_OK) {
sl@0	221	return result;
sl@0	222	}
sl@0	223	}
sl@0	224	i++;
sl@0	225	if (i >= objc) {
sl@0	226	missingScript:
sl@0	227	clause = Tcl_GetString(objv[i-1]);
sl@0	228	Tcl_AppendResult(interp, "wrong # args: no script following \"",
sl@0	229	clause, "\" argument", (char *) NULL);
sl@0	230	return TCL_ERROR;
sl@0	231	}
sl@0	232	clause = Tcl_GetString(objv[i]);
sl@0	233	if ((i < objc) && (strcmp(clause, "then") == 0)) {
sl@0	234	i++;
sl@0	235	}
sl@0	236	if (i >= objc) {
sl@0	237	goto missingScript;
sl@0	238	}
sl@0	239	if (value) {
sl@0	240	thenScriptIndex = i;
sl@0	241	value = 0;
sl@0	242	}
sl@0	243
sl@0	244	/*
sl@0	245	* The expression evaluated to false. Skip the command, then
sl@0	246	* see if there is an "else" or "elseif" clause.
sl@0	247	*/
sl@0	248
sl@0	249	i++;
sl@0	250	if (i >= objc) {
sl@0	251	if (thenScriptIndex) {
sl@0	252	#ifndef TCL_TIP280
sl@0	253	return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
sl@0	254	#else
sl@0	255	/* TIP #280. Make invoking context available to branch */
sl@0	256	return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
sl@0	257	iPtr->cmdFramePtr,thenScriptIndex);
sl@0	258	#endif
sl@0	259	}
sl@0	260	return TCL_OK;
sl@0	261	}
sl@0	262	clause = Tcl_GetString(objv[i]);
sl@0	263	if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) {
sl@0	264	i++;
sl@0	265	continue;
sl@0	266	}
sl@0	267	break;
sl@0	268	}
sl@0	269
sl@0	270	/*
sl@0	271	* Couldn't find a "then" or "elseif" clause to execute. Check now
sl@0	272	* for an "else" clause. We know that there's at least one more
sl@0	273	* argument when we get here.
sl@0	274	*/
sl@0	275
sl@0	276	if (strcmp(clause, "else") == 0) {
sl@0	277	i++;
sl@0	278	if (i >= objc) {
sl@0	279	Tcl_AppendResult(interp,
sl@0	280	"wrong # args: no script following \"else\" argument",
sl@0	281	(char *) NULL);
sl@0	282	return TCL_ERROR;
sl@0	283	}
sl@0	284	}
sl@0	285	if (i < objc - 1) {
sl@0	286	Tcl_AppendResult(interp,
sl@0	287	"wrong # args: extra words after \"else\" clause in \"if\" command",
sl@0	288	(char *) NULL);
sl@0	289	return TCL_ERROR;
sl@0	290	}
sl@0	291	if (thenScriptIndex) {
sl@0	292	#ifndef TCL_TIP280
sl@0	293	return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
sl@0	294	#else
sl@0	295	/* TIP #280. Make invoking context available to branch/else */
sl@0	296	return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
sl@0	297	iPtr->cmdFramePtr,thenScriptIndex);
sl@0	298	#endif
sl@0	299	}
sl@0	300	#ifndef TCL_TIP280
sl@0	301	return Tcl_EvalObjEx(interp, objv[i], 0);
sl@0	302	#else
sl@0	303	return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr,i);
sl@0	304	#endif
sl@0	305	}
sl@0	306
sl@0	307	/*
sl@0	308	*----------------------------------------------------------------------
sl@0	309	*
sl@0	310	* Tcl_IncrObjCmd --
sl@0	311	*
sl@0	312	* This procedure is invoked to process the "incr" Tcl command.
sl@0	313	* See the user documentation for details on what it does.
sl@0	314	*
sl@0	315	* With the bytecode compiler, this procedure is only called when
sl@0	316	* a command name is computed at runtime, and is "incr" or the name
sl@0	317	* to which "incr" was renamed: e.g., "set z incr; $z i -1"
sl@0	318	*
sl@0	319	* Results:
sl@0	320	* A standard Tcl result.
sl@0	321	*
sl@0	322	* Side effects:
sl@0	323	* See the user documentation.
sl@0	324	*
sl@0	325	*----------------------------------------------------------------------
sl@0	326	*/
sl@0	327
sl@0	328	/* ARGSUSED */
sl@0	329	int
sl@0	330	Tcl_IncrObjCmd(dummy, interp, objc, objv)
sl@0	331	ClientData dummy; /* Not used. */
sl@0	332	Tcl_Interp interp; / Current interpreter. */
sl@0	333	int objc; /* Number of arguments. */
sl@0	334	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	335	{
sl@0	336	long incrAmount;
sl@0	337	Tcl_Obj *newValuePtr;
sl@0	338
sl@0	339	if ((objc != 2) && (objc != 3)) {
sl@0	340	Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?");
sl@0	341	return TCL_ERROR;
sl@0	342	}
sl@0	343
sl@0	344	/*
sl@0	345	* Calculate the amount to increment by.
sl@0	346	*/
sl@0	347
sl@0	348	if (objc == 2) {
sl@0	349	incrAmount = 1;
sl@0	350	} else {
sl@0	351	if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) {
sl@0	352	Tcl_AddErrorInfo(interp, "\n (reading increment)");
sl@0	353	return TCL_ERROR;
sl@0	354	}
sl@0	355	/*
sl@0	356	* Need to be a bit cautious to ensure that [expr]-like rules
sl@0	357	* are enforced for interpretation of wide integers, despite
sl@0	358	* the fact that the underlying API itself is a 'long' only one.
sl@0	359	*/
sl@0	360	if (objv[2]->typePtr == &tclIntType) {
sl@0	361	incrAmount = objv[2]->internalRep.longValue;
sl@0	362	} else if (objv[2]->typePtr == &tclWideIntType) {
sl@0	363	TclGetLongFromWide(incrAmount,objv[2]);
sl@0	364	} else {
sl@0	365	Tcl_WideInt wide;
sl@0	366
sl@0	367	if (Tcl_GetWideIntFromObj(interp, objv[2], &wide) != TCL_OK) {
sl@0	368	Tcl_AddErrorInfo(interp, "\n (reading increment)");
sl@0	369	return TCL_ERROR;
sl@0	370	}
sl@0	371	incrAmount = Tcl_WideAsLong(wide);
sl@0	372	if ((wide <= Tcl_LongAsWide(LONG_MAX))
sl@0	373	&& (wide >= Tcl_LongAsWide(LONG_MIN))) {
sl@0	374	objv[2]->typePtr = &tclIntType;
sl@0	375	objv[2]->internalRep.longValue = incrAmount;
sl@0	376	}
sl@0	377	}
sl@0	378	}
sl@0	379
sl@0	380	/*
sl@0	381	* Increment the variable's value.
sl@0	382	*/
sl@0	383
sl@0	384	newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount,
sl@0	385	TCL_LEAVE_ERR_MSG);
sl@0	386	if (newValuePtr == NULL) {
sl@0	387	return TCL_ERROR;
sl@0	388	}
sl@0	389
sl@0	390	/*
sl@0	391	* Set the interpreter's object result to refer to the variable's new
sl@0	392	* value object.
sl@0	393	*/
sl@0	394
sl@0	395	Tcl_SetObjResult(interp, newValuePtr);
sl@0	396	return TCL_OK;
sl@0	397	}
sl@0	398
sl@0	399	/*
sl@0	400	*----------------------------------------------------------------------
sl@0	401	*
sl@0	402	* Tcl_InfoObjCmd --
sl@0	403	*
sl@0	404	* This procedure is invoked to process the "info" Tcl command.
sl@0	405	* See the user documentation for details on what it does.
sl@0	406	*
sl@0	407	* Results:
sl@0	408	* A standard Tcl result.
sl@0	409	*
sl@0	410	* Side effects:
sl@0	411	* See the user documentation.
sl@0	412	*
sl@0	413	*----------------------------------------------------------------------
sl@0	414	*/
sl@0	415
sl@0	416	/* ARGSUSED */
sl@0	417	int
sl@0	418	Tcl_InfoObjCmd(clientData, interp, objc, objv)
sl@0	419	ClientData clientData; /* Arbitrary value passed to the command. */
sl@0	420	Tcl_Interp interp; / Current interpreter. */
sl@0	421	int objc; /* Number of arguments. */
sl@0	422	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	423	{
sl@0	424	static CONST char *subCmds[] = {
sl@0	425	"args", "body", "cmdcount", "commands",
sl@0	426	"complete", "default", "exists",
sl@0	427	#ifdef TCL_TIP280
sl@0	428	"frame",
sl@0	429	#endif
sl@0	430	"functions",
sl@0	431	"globals", "hostname", "level", "library", "loaded",
sl@0	432	"locals", "nameofexecutable", "patchlevel", "procs",
sl@0	433	"script", "sharedlibextension", "tclversion", "vars",
sl@0	434	(char *) NULL};
sl@0	435	enum ISubCmdIdx {
sl@0	436	IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
sl@0	437	ICompleteIdx, IDefaultIdx, IExistsIdx,
sl@0	438	#ifdef TCL_TIP280
sl@0	439	IFrameIdx,
sl@0	440	#endif
sl@0	441	IFunctionsIdx,
sl@0	442	IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
sl@0	443	ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
sl@0	444	IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
sl@0	445	};
sl@0	446	int index, result;
sl@0	447
sl@0	448	if (objc < 2) {
sl@0	449	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
sl@0	450	return TCL_ERROR;
sl@0	451	}
sl@0	452
sl@0	453	result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
sl@0	454	(int *) &index);
sl@0	455	if (result != TCL_OK) {
sl@0	456	return result;
sl@0	457	}
sl@0	458
sl@0	459	switch (index) {
sl@0	460	case IArgsIdx:
sl@0	461	result = InfoArgsCmd(clientData, interp, objc, objv);
sl@0	462	break;
sl@0	463	case IBodyIdx:
sl@0	464	result = InfoBodyCmd(clientData, interp, objc, objv);
sl@0	465	break;
sl@0	466	case ICmdCountIdx:
sl@0	467	result = InfoCmdCountCmd(clientData, interp, objc, objv);
sl@0	468	break;
sl@0	469	case ICommandsIdx:
sl@0	470	result = InfoCommandsCmd(clientData, interp, objc, objv);
sl@0	471	break;
sl@0	472	case ICompleteIdx:
sl@0	473	result = InfoCompleteCmd(clientData, interp, objc, objv);
sl@0	474	break;
sl@0	475	case IDefaultIdx:
sl@0	476	result = InfoDefaultCmd(clientData, interp, objc, objv);
sl@0	477	break;
sl@0	478	case IExistsIdx:
sl@0	479	result = InfoExistsCmd(clientData, interp, objc, objv);
sl@0	480	break;
sl@0	481	#ifdef TCL_TIP280
sl@0	482	case IFrameIdx:
sl@0	483	/* TIP #280 - New method 'frame' */
sl@0	484	result = InfoFrameCmd(clientData, interp, objc, objv);
sl@0	485	break;
sl@0	486	#endif
sl@0	487	case IFunctionsIdx:
sl@0	488	result = InfoFunctionsCmd(clientData, interp, objc, objv);
sl@0	489	break;
sl@0	490	case IGlobalsIdx:
sl@0	491	result = InfoGlobalsCmd(clientData, interp, objc, objv);
sl@0	492	break;
sl@0	493	case IHostnameIdx:
sl@0	494	result = InfoHostnameCmd(clientData, interp, objc, objv);
sl@0	495	break;
sl@0	496	case ILevelIdx:
sl@0	497	result = InfoLevelCmd(clientData, interp, objc, objv);
sl@0	498	break;
sl@0	499	case ILibraryIdx:
sl@0	500	result = InfoLibraryCmd(clientData, interp, objc, objv);
sl@0	501	break;
sl@0	502	case ILoadedIdx:
sl@0	503	result = InfoLoadedCmd(clientData, interp, objc, objv);
sl@0	504	break;
sl@0	505	case ILocalsIdx:
sl@0	506	result = InfoLocalsCmd(clientData, interp, objc, objv);
sl@0	507	break;
sl@0	508	case INameOfExecutableIdx:
sl@0	509	result = InfoNameOfExecutableCmd(clientData, interp, objc, objv);
sl@0	510	break;
sl@0	511	case IPatchLevelIdx:
sl@0	512	result = InfoPatchLevelCmd(clientData, interp, objc, objv);
sl@0	513	break;
sl@0	514	case IProcsIdx:
sl@0	515	result = InfoProcsCmd(clientData, interp, objc, objv);
sl@0	516	break;
sl@0	517	case IScriptIdx:
sl@0	518	result = InfoScriptCmd(clientData, interp, objc, objv);
sl@0	519	break;
sl@0	520	case ISharedLibExtensionIdx:
sl@0	521	result = InfoSharedlibCmd(clientData, interp, objc, objv);
sl@0	522	break;
sl@0	523	case ITclVersionIdx:
sl@0	524	result = InfoTclVersionCmd(clientData, interp, objc, objv);
sl@0	525	break;
sl@0	526	case IVarsIdx:
sl@0	527	result = InfoVarsCmd(clientData, interp, objc, objv);
sl@0	528	break;
sl@0	529	}
sl@0	530	return result;
sl@0	531	}
sl@0	532
sl@0	533	/*
sl@0	534	*----------------------------------------------------------------------
sl@0	535	*
sl@0	536	* InfoArgsCmd --
sl@0	537	*
sl@0	538	* Called to implement the "info args" command that returns the
sl@0	539	* argument list for a procedure. Handles the following syntax:
sl@0	540	*
sl@0	541	* info args procName
sl@0	542	*
sl@0	543	* Results:
sl@0	544	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	545	*
sl@0	546	* Side effects:
sl@0	547	* Returns a result in the interpreter's result object. If there is
sl@0	548	* an error, the result is an error message.
sl@0	549	*
sl@0	550	*----------------------------------------------------------------------
sl@0	551	*/
sl@0	552
sl@0	553	static int
sl@0	554	InfoArgsCmd(dummy, interp, objc, objv)
sl@0	555	ClientData dummy; /* Not used. */
sl@0	556	Tcl_Interp interp; / Current interpreter. */
sl@0	557	int objc; /* Number of arguments. */
sl@0	558	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	559	{
sl@0	560	register Interp iPtr = (Interp ) interp;
sl@0	561	char *name;
sl@0	562	Proc *procPtr;
sl@0	563	CompiledLocal *localPtr;
sl@0	564	Tcl_Obj *listObjPtr;
sl@0	565
sl@0	566	if (objc != 3) {
sl@0	567	Tcl_WrongNumArgs(interp, 2, objv, "procname");
sl@0	568	return TCL_ERROR;
sl@0	569	}
sl@0	570
sl@0	571	name = Tcl_GetString(objv[2]);
sl@0	572	procPtr = TclFindProc(iPtr, name);
sl@0	573	if (procPtr == NULL) {
sl@0	574	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	575	"\"", name, "\" isn't a procedure", (char *) NULL);
sl@0	576	return TCL_ERROR;
sl@0	577	}
sl@0	578
sl@0	579	/*
sl@0	580	* Build a return list containing the arguments.
sl@0	581	*/
sl@0	582
sl@0	583	listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	584	for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
sl@0	585	localPtr = localPtr->nextPtr) {
sl@0	586	if (TclIsVarArgument(localPtr)) {
sl@0	587	Tcl_ListObjAppendElement(interp, listObjPtr,
sl@0	588	Tcl_NewStringObj(localPtr->name, -1));
sl@0	589	}
sl@0	590	}
sl@0	591	Tcl_SetObjResult(interp, listObjPtr);
sl@0	592	return TCL_OK;
sl@0	593	}
sl@0	594
sl@0	595	/*
sl@0	596	*----------------------------------------------------------------------
sl@0	597	*
sl@0	598	* InfoBodyCmd --
sl@0	599	*
sl@0	600	* Called to implement the "info body" command that returns the body
sl@0	601	* for a procedure. Handles the following syntax:
sl@0	602	*
sl@0	603	* info body procName
sl@0	604	*
sl@0	605	* Results:
sl@0	606	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	607	*
sl@0	608	* Side effects:
sl@0	609	* Returns a result in the interpreter's result object. If there is
sl@0	610	* an error, the result is an error message.
sl@0	611	*
sl@0	612	*----------------------------------------------------------------------
sl@0	613	*/
sl@0	614
sl@0	615	static int
sl@0	616	InfoBodyCmd(dummy, interp, objc, objv)
sl@0	617	ClientData dummy; /* Not used. */
sl@0	618	Tcl_Interp interp; / Current interpreter. */
sl@0	619	int objc; /* Number of arguments. */
sl@0	620	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	621	{
sl@0	622	register Interp iPtr = (Interp ) interp;
sl@0	623	char *name;
sl@0	624	Proc *procPtr;
sl@0	625	Tcl_Obj bodyPtr, resultPtr;
sl@0	626
sl@0	627	if (objc != 3) {
sl@0	628	Tcl_WrongNumArgs(interp, 2, objv, "procname");
sl@0	629	return TCL_ERROR;
sl@0	630	}
sl@0	631
sl@0	632	name = Tcl_GetString(objv[2]);
sl@0	633	procPtr = TclFindProc(iPtr, name);
sl@0	634	if (procPtr == NULL) {
sl@0	635	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	636	"\"", name, "\" isn't a procedure", (char *) NULL);
sl@0	637	return TCL_ERROR;
sl@0	638	}
sl@0	639
sl@0	640	/*
sl@0	641	* Here we used to return procPtr->bodyPtr, except when the body was
sl@0	642	* bytecompiled - in that case, the return was a copy of the body's
sl@0	643	* string rep. In order to better isolate the implementation details
sl@0	644	* of the compiler/engine subsystem, we now always return a copy of
sl@0	645	* the string rep. It is important to return a copy so that later
sl@0	646	* manipulations of the object do not invalidate the internal rep.
sl@0	647	*/
sl@0	648
sl@0	649	bodyPtr = procPtr->bodyPtr;
sl@0	650	if (bodyPtr->bytes == NULL) {
sl@0	651	/*
sl@0	652	* The string rep might not be valid if the procedure has
sl@0	653	* never been run before. [Bug #545644]
sl@0	654	*/
sl@0	655	(void) Tcl_GetString(bodyPtr);
sl@0	656	}
sl@0	657	resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
sl@0	658
sl@0	659	Tcl_SetObjResult(interp, resultPtr);
sl@0	660	return TCL_OK;
sl@0	661	}
sl@0	662
sl@0	663	/*
sl@0	664	*----------------------------------------------------------------------
sl@0	665	*
sl@0	666	* InfoCmdCountCmd --
sl@0	667	*
sl@0	668	* Called to implement the "info cmdcount" command that returns the
sl@0	669	* number of commands that have been executed. Handles the following
sl@0	670	* syntax:
sl@0	671	*
sl@0	672	* info cmdcount
sl@0	673	*
sl@0	674	* Results:
sl@0	675	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	676	*
sl@0	677	* Side effects:
sl@0	678	* Returns a result in the interpreter's result object. If there is
sl@0	679	* an error, the result is an error message.
sl@0	680	*
sl@0	681	*----------------------------------------------------------------------
sl@0	682	*/
sl@0	683
sl@0	684	static int
sl@0	685	InfoCmdCountCmd(dummy, interp, objc, objv)
sl@0	686	ClientData dummy; /* Not used. */
sl@0	687	Tcl_Interp interp; / Current interpreter. */
sl@0	688	int objc; /* Number of arguments. */
sl@0	689	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	690	{
sl@0	691	Interp iPtr = (Interp ) interp;
sl@0	692
sl@0	693	if (objc != 2) {
sl@0	694	Tcl_WrongNumArgs(interp, 2, objv, NULL);
sl@0	695	return TCL_ERROR;
sl@0	696	}
sl@0	697
sl@0	698	Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount);
sl@0	699	return TCL_OK;
sl@0	700	}
sl@0	701
sl@0	702	/*
sl@0	703	*----------------------------------------------------------------------
sl@0	704	*
sl@0	705	* InfoCommandsCmd --
sl@0	706	*
sl@0	707	* Called to implement the "info commands" command that returns the
sl@0	708	* list of commands in the interpreter that match an optional pattern.
sl@0	709	* The pattern, if any, consists of an optional sequence of namespace
sl@0	710	* names separated by "::" qualifiers, which is followed by a
sl@0	711	* glob-style pattern that restricts which commands are returned.
sl@0	712	* Handles the following syntax:
sl@0	713	*
sl@0	714	* info commands ?pattern?
sl@0	715	*
sl@0	716	* Results:
sl@0	717	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	718	*
sl@0	719	* Side effects:
sl@0	720	* Returns a result in the interpreter's result object. If there is
sl@0	721	* an error, the result is an error message.
sl@0	722	*
sl@0	723	*----------------------------------------------------------------------
sl@0	724	*/
sl@0	725
sl@0	726	static int
sl@0	727	InfoCommandsCmd(dummy, interp, objc, objv)
sl@0	728	ClientData dummy; /* Not used. */
sl@0	729	Tcl_Interp interp; / Current interpreter. */
sl@0	730	int objc; /* Number of arguments. */
sl@0	731	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	732	{
sl@0	733	char cmdName, pattern;
sl@0	734	CONST char *simplePattern;
sl@0	735	register Tcl_HashEntry *entryPtr;
sl@0	736	Tcl_HashSearch search;
sl@0	737	Namespace *nsPtr;
sl@0	738	Namespace globalNsPtr = (Namespace ) Tcl_GetGlobalNamespace(interp);
sl@0	739	Namespace currNsPtr = (Namespace ) Tcl_GetCurrentNamespace(interp);
sl@0	740	Tcl_Obj listPtr, elemObjPtr;
sl@0	741	int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
sl@0	742	Tcl_Command cmd;
sl@0	743
sl@0	744	/*
sl@0	745	* Get the pattern and find the "effective namespace" in which to
sl@0	746	* list commands.
sl@0	747	*/
sl@0	748
sl@0	749	if (objc == 2) {
sl@0	750	simplePattern = NULL;
sl@0	751	nsPtr = currNsPtr;
sl@0	752	specificNsInPattern = 0;
sl@0	753	} else if (objc == 3) {
sl@0	754	/*
sl@0	755	* From the pattern, get the effective namespace and the simple
sl@0	756	* pattern (no namespace qualifiers or ::'s) at the end. If an
sl@0	757	* error was found while parsing the pattern, return it. Otherwise,
sl@0	758	* if the namespace wasn't found, just leave nsPtr NULL: we will
sl@0	759	* return an empty list since no commands there can be found.
sl@0	760	*/
sl@0	761
sl@0	762	Namespace dummy1NsPtr, dummy2NsPtr;
sl@0	763
sl@0	764
sl@0	765	pattern = Tcl_GetString(objv[2]);
sl@0	766	TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
sl@0	767	/flags/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
sl@0	768
sl@0	769	if (nsPtr != NULL) { /* we successfully found the pattern's ns */
sl@0	770	specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
sl@0	771	}
sl@0	772	} else {
sl@0	773	Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
sl@0	774	return TCL_ERROR;
sl@0	775	}
sl@0	776
sl@0	777	/*
sl@0	778	* Exit as quickly as possible if we couldn't find the namespace.
sl@0	779	*/
sl@0	780
sl@0	781	if (nsPtr == NULL) {
sl@0	782	return TCL_OK;
sl@0	783	}
sl@0	784
sl@0	785	/*
sl@0	786	* Scan through the effective namespace's command table and create a
sl@0	787	* list with all commands that match the pattern. If a specific
sl@0	788	* namespace was requested in the pattern, qualify the command names
sl@0	789	* with the namespace name.
sl@0	790	*/
sl@0	791
sl@0	792	listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	793
sl@0	794	if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
sl@0	795	/*
sl@0	796	* Special case for when the pattern doesn't include any of
sl@0	797	* glob's special characters. This lets us avoid scans of any
sl@0	798	* hash tables.
sl@0	799	*/
sl@0	800	entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
sl@0	801	if (entryPtr != NULL) {
sl@0	802	if (specificNsInPattern) {
sl@0	803	cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
sl@0	804	elemObjPtr = Tcl_NewObj();
sl@0	805	Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
sl@0	806	} else {
sl@0	807	cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
sl@0	808	elemObjPtr = Tcl_NewStringObj(cmdName, -1);
sl@0	809	}
sl@0	810	Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
sl@0	811	} else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
sl@0	812	entryPtr = Tcl_FindHashEntry(&globalNsPtr->cmdTable,
sl@0	813	simplePattern);
sl@0	814	if (entryPtr != NULL) {
sl@0	815	cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
sl@0	816	Tcl_ListObjAppendElement(interp, listPtr,
sl@0	817	Tcl_NewStringObj(cmdName, -1));
sl@0	818	}
sl@0	819	}
sl@0	820	} else {
sl@0	821	entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
sl@0	822	while (entryPtr != NULL) {
sl@0	823	cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
sl@0	824	if ((simplePattern == NULL)
sl@0	825	\|\| Tcl_StringMatch(cmdName, simplePattern)) {
sl@0	826	if (specificNsInPattern) {
sl@0	827	cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
sl@0	828	elemObjPtr = Tcl_NewObj();
sl@0	829	Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
sl@0	830	} else {
sl@0	831	elemObjPtr = Tcl_NewStringObj(cmdName, -1);
sl@0	832	}
sl@0	833	Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
sl@0	834	}
sl@0	835	entryPtr = Tcl_NextHashEntry(&search);
sl@0	836	}
sl@0	837
sl@0	838	/*
sl@0	839	* If the effective namespace isn't the global :: namespace, and a
sl@0	840	* specific namespace wasn't requested in the pattern, then add in
sl@0	841	* all global :: commands that match the simple pattern. Of course,
sl@0	842	* we add in only those commands that aren't hidden by a command in
sl@0	843	* the effective namespace.
sl@0	844	*/
sl@0	845
sl@0	846	if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
sl@0	847	entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
sl@0	848	while (entryPtr != NULL) {
sl@0	849	cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
sl@0	850	if ((simplePattern == NULL)
sl@0	851	\|\| Tcl_StringMatch(cmdName, simplePattern)) {
sl@0	852	if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
sl@0	853	Tcl_ListObjAppendElement(interp, listPtr,
sl@0	854	Tcl_NewStringObj(cmdName, -1));
sl@0	855	}
sl@0	856	}
sl@0	857	entryPtr = Tcl_NextHashEntry(&search);
sl@0	858	}
sl@0	859	}
sl@0	860	}
sl@0	861
sl@0	862	Tcl_SetObjResult(interp, listPtr);
sl@0	863	return TCL_OK;
sl@0	864	}
sl@0	865
sl@0	866	/*
sl@0	867	*----------------------------------------------------------------------
sl@0	868	*
sl@0	869	* InfoCompleteCmd --
sl@0	870	*
sl@0	871	* Called to implement the "info complete" command that determines
sl@0	872	* whether a string is a complete Tcl command. Handles the following
sl@0	873	* syntax:
sl@0	874	*
sl@0	875	* info complete command
sl@0	876	*
sl@0	877	* Results:
sl@0	878	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	879	*
sl@0	880	* Side effects:
sl@0	881	* Returns a result in the interpreter's result object. If there is
sl@0	882	* an error, the result is an error message.
sl@0	883	*
sl@0	884	*----------------------------------------------------------------------
sl@0	885	*/
sl@0	886
sl@0	887	static int
sl@0	888	InfoCompleteCmd(dummy, interp, objc, objv)
sl@0	889	ClientData dummy; /* Not used. */
sl@0	890	Tcl_Interp interp; / Current interpreter. */
sl@0	891	int objc; /* Number of arguments. */
sl@0	892	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	893	{
sl@0	894	if (objc != 3) {
sl@0	895	Tcl_WrongNumArgs(interp, 2, objv, "command");
sl@0	896	return TCL_ERROR;
sl@0	897	}
sl@0	898
sl@0	899	if (TclObjCommandComplete(objv[2])) {
sl@0	900	Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
sl@0	901	} else {
sl@0	902	Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
sl@0	903	}
sl@0	904
sl@0	905	return TCL_OK;
sl@0	906	}
sl@0	907
sl@0	908	/*
sl@0	909	*----------------------------------------------------------------------
sl@0	910	*
sl@0	911	* InfoDefaultCmd --
sl@0	912	*
sl@0	913	* Called to implement the "info default" command that returns the
sl@0	914	* default value for a procedure argument. Handles the following
sl@0	915	* syntax:
sl@0	916	*
sl@0	917	* info default procName arg varName
sl@0	918	*
sl@0	919	* Results:
sl@0	920	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	921	*
sl@0	922	* Side effects:
sl@0	923	* Returns a result in the interpreter's result object. If there is
sl@0	924	* an error, the result is an error message.
sl@0	925	*
sl@0	926	*----------------------------------------------------------------------
sl@0	927	*/
sl@0	928
sl@0	929	static int
sl@0	930	InfoDefaultCmd(dummy, interp, objc, objv)
sl@0	931	ClientData dummy; /* Not used. */
sl@0	932	Tcl_Interp interp; / Current interpreter. */
sl@0	933	int objc; /* Number of arguments. */
sl@0	934	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	935	{
sl@0	936	Interp iPtr = (Interp ) interp;
sl@0	937	char procName, argName, *varName;
sl@0	938	Proc *procPtr;
sl@0	939	CompiledLocal *localPtr;
sl@0	940	Tcl_Obj *valueObjPtr;
sl@0	941
sl@0	942	if (objc != 5) {
sl@0	943	Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname");
sl@0	944	return TCL_ERROR;
sl@0	945	}
sl@0	946
sl@0	947	procName = Tcl_GetString(objv[2]);
sl@0	948	argName = Tcl_GetString(objv[3]);
sl@0	949
sl@0	950	procPtr = TclFindProc(iPtr, procName);
sl@0	951	if (procPtr == NULL) {
sl@0	952	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	953	"\"", procName, "\" isn't a procedure", (char *) NULL);
sl@0	954	return TCL_ERROR;
sl@0	955	}
sl@0	956
sl@0	957	for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
sl@0	958	localPtr = localPtr->nextPtr) {
sl@0	959	if (TclIsVarArgument(localPtr)
sl@0	960	&& (strcmp(argName, localPtr->name) == 0)) {
sl@0	961	if (localPtr->defValuePtr != NULL) {
sl@0	962	valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
sl@0	963	localPtr->defValuePtr, 0);
sl@0	964	if (valueObjPtr == NULL) {
sl@0	965	defStoreError:
sl@0	966	varName = Tcl_GetString(objv[4]);
sl@0	967	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	968	"couldn't store default value in variable \"",
sl@0	969	varName, "\"", (char *) NULL);
sl@0	970	return TCL_ERROR;
sl@0	971	}
sl@0	972	Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
sl@0	973	} else {
sl@0	974	Tcl_Obj *nullObjPtr = Tcl_NewObj();
sl@0	975	Tcl_IncrRefCount(nullObjPtr);
sl@0	976	valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
sl@0	977	nullObjPtr, 0);
sl@0	978	Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */
sl@0	979	if (valueObjPtr == NULL) {
sl@0	980	goto defStoreError;
sl@0	981	}
sl@0	982	Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
sl@0	983	}
sl@0	984	return TCL_OK;
sl@0	985	}
sl@0	986	}
sl@0	987
sl@0	988	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	989	"procedure \"", procName, "\" doesn't have an argument \"",
sl@0	990	argName, "\"", (char *) NULL);
sl@0	991	return TCL_ERROR;
sl@0	992	}
sl@0	993
sl@0	994	/*
sl@0	995	*----------------------------------------------------------------------
sl@0	996	*
sl@0	997	* InfoExistsCmd --
sl@0	998	*
sl@0	999	* Called to implement the "info exists" command that determines
sl@0	1000	* whether a variable exists. Handles the following syntax:
sl@0	1001	*
sl@0	1002	* info exists varName
sl@0	1003	*
sl@0	1004	* Results:
sl@0	1005	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	1006	*
sl@0	1007	* Side effects:
sl@0	1008	* Returns a result in the interpreter's result object. If there is
sl@0	1009	* an error, the result is an error message.
sl@0	1010	*
sl@0	1011	*----------------------------------------------------------------------
sl@0	1012	*/
sl@0	1013
sl@0	1014	static int
sl@0	1015	InfoExistsCmd(dummy, interp, objc, objv)
sl@0	1016	ClientData dummy; /* Not used. */
sl@0	1017	Tcl_Interp interp; / Current interpreter. */
sl@0	1018	int objc; /* Number of arguments. */
sl@0	1019	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1020	{
sl@0	1021	char *varName;
sl@0	1022	Var *varPtr;
sl@0	1023
sl@0	1024	if (objc != 3) {
sl@0	1025	Tcl_WrongNumArgs(interp, 2, objv, "varName");
sl@0	1026	return TCL_ERROR;
sl@0	1027	}
sl@0	1028
sl@0	1029	varName = Tcl_GetString(objv[2]);
sl@0	1030	varPtr = TclVarTraceExists(interp, varName);
sl@0	1031	if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
sl@0	1032	Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
sl@0	1033	} else {
sl@0	1034	Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
sl@0	1035	}
sl@0	1036	return TCL_OK;
sl@0	1037	}
sl@0	1038
sl@0	1039	#ifdef TCL_TIP280
sl@0	1040	/*
sl@0	1041	*----------------------------------------------------------------------
sl@0	1042	*
sl@0	1043	* InfoFrameCmd --
sl@0	1044	* TIP #280
sl@0	1045	*
sl@0	1046	* Called to implement the "info frame" command that returns the
sl@0	1047	* location of either the currently executing command, or its caller.
sl@0	1048	* Handles the following syntax:
sl@0	1049	*
sl@0	1050	* info frame ?number?
sl@0	1051	*
sl@0	1052	* Results:
sl@0	1053	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	1054	*
sl@0	1055	* Side effects:
sl@0	1056	* Returns a result in the interpreter's result object. If there is
sl@0	1057	* an error, the result is an error message.
sl@0	1058	*
sl@0	1059	*----------------------------------------------------------------------
sl@0	1060	*/
sl@0	1061
sl@0	1062	static int
sl@0	1063	InfoFrameCmd(dummy, interp, objc, objv)
sl@0	1064	ClientData dummy; /* Not used. */
sl@0	1065	Tcl_Interp interp; / Current interpreter. */
sl@0	1066	int objc; /* Number of arguments. */
sl@0	1067	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1068	{
sl@0	1069	Interp iPtr = (Interp ) interp;
sl@0	1070
sl@0	1071	if (objc == 2) {
sl@0	1072	/* just "info frame" */
sl@0	1073	int levels = (iPtr->cmdFramePtr == NULL
sl@0	1074	? 0
sl@0	1075	: iPtr->cmdFramePtr->level);
sl@0	1076
sl@0	1077	Tcl_SetIntObj(Tcl_GetObjResult(interp), levels);
sl@0	1078	return TCL_OK;
sl@0	1079
sl@0	1080	} else if (objc == 3) {
sl@0	1081	/* "info frame level" */
sl@0	1082	int level;
sl@0	1083	CmdFrame *framePtr;
sl@0	1084
sl@0	1085	if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
sl@0	1086	return TCL_ERROR;
sl@0	1087	}
sl@0	1088	if (level <= 0) {
sl@0	1089	/* Relative adressing */
sl@0	1090
sl@0	1091	if (iPtr->cmdFramePtr == NULL) {
sl@0	1092	levelError:
sl@0	1093	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1094	"bad level \"",
sl@0	1095	Tcl_GetString(objv[2]),
sl@0	1096	"\"", (char *) NULL);
sl@0	1097	return TCL_ERROR;
sl@0	1098	}
sl@0	1099	/* Convert to absolute. */
sl@0	1100
sl@0	1101	level += iPtr->cmdFramePtr->level;
sl@0	1102	}
sl@0	1103	for (framePtr = iPtr->cmdFramePtr;
sl@0	1104	framePtr != NULL;
sl@0	1105	framePtr = framePtr->nextPtr) {
sl@0	1106
sl@0	1107	if (framePtr->level == level) {
sl@0	1108	break;
sl@0	1109	}
sl@0	1110	}
sl@0	1111	if (framePtr == NULL) {
sl@0	1112	goto levelError;
sl@0	1113	}
sl@0	1114
sl@0	1115	/*
sl@0	1116	* Pull the information and construct the dictionary to return, as
sl@0	1117	* list. Regarding use of the CmdFrame fields see tclInt.h, and its
sl@0	1118	* definition.
sl@0	1119	*/
sl@0	1120
sl@0	1121	{
sl@0	1122	Tcl_Obj* lv [20]; /* Keep uptodate when more keys are added to the dict */
sl@0	1123	int lc = 0;
sl@0	1124
sl@0	1125	/* This array is indexed by the TCL_LOCATION_... values, except
sl@0	1126	* for _LAST.
sl@0	1127	*/
sl@0	1128
sl@0	1129	static CONST char* typeString [TCL_LOCATION_LAST] = {
sl@0	1130	"eval", "eval", "eval", "precompiled", "source", "proc"
sl@0	1131	};
sl@0	1132
sl@0	1133	switch (framePtr->type) {
sl@0	1134	case TCL_LOCATION_EVAL:
sl@0	1135	/* Evaluation, dynamic script. Type, line, cmd, the latter
sl@0	1136	* through str. */
sl@0	1137
sl@0	1138	lv [lc ++] = Tcl_NewStringObj ("type",-1);
sl@0	1139	lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
sl@0	1140	lv [lc ++] = Tcl_NewStringObj ("line",-1);
sl@0	1141	lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]);
sl@0	1142	lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
sl@0	1143	lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd,
sl@0	1144	framePtr->cmd.str.len);
sl@0	1145	break;
sl@0	1146
sl@0	1147	case TCL_LOCATION_EVAL_LIST:
sl@0	1148	/* List optimized evaluation. Type, line, cmd, the latter
sl@0	1149	* through listPtr, possibly a frame. */
sl@0	1150
sl@0	1151	lv [lc ++] = Tcl_NewStringObj ("type",-1);
sl@0	1152	lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
sl@0	1153	lv [lc ++] = Tcl_NewStringObj ("line",-1);
sl@0	1154	lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]);
sl@0	1155
sl@0	1156	/* We put a duplicate of the command list obj into the result
sl@0	1157	* to ensure that the 'pure List'-property of the command
sl@0	1158	* itself is not destroyed. Otherwise the query here would
sl@0	1159	* disable the list optimization path in Tcl_EvalObjEx.
sl@0	1160	*/
sl@0	1161
sl@0	1162	lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
sl@0	1163	lv [lc ++] = Tcl_DuplicateObj (framePtr->cmd.listPtr);
sl@0	1164	break;
sl@0	1165
sl@0	1166	case TCL_LOCATION_PREBC:
sl@0	1167	/* Precompiled. Result contains the type as signal, nothing
sl@0	1168	* else */
sl@0	1169
sl@0	1170	lv [lc ++] = Tcl_NewStringObj ("type",-1);
sl@0	1171	lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
sl@0	1172	break;
sl@0	1173
sl@0	1174	case TCL_LOCATION_BC: {
sl@0	1175	/* Execution of bytecode. Talk to the BC engine to fill out
sl@0	1176	* the frame. */
sl@0	1177
sl@0	1178	CmdFrame f = *framePtr;
sl@0	1179	Proc* procPtr = f.framePtr ? f.framePtr->procPtr : NULL;
sl@0	1180
sl@0	1181	/* Note: Type BC => f.data.eval.path is not used.
sl@0	1182	* f.data.tebc.codePtr is used instead.
sl@0	1183	*/
sl@0	1184
sl@0	1185	TclGetSrcInfoForPc (&f);
sl@0	1186	/* Now filled: cmd.str.(cmd,len), line */
sl@0	1187	/* Possibly modified: type, path! */
sl@0	1188
sl@0	1189	lv [lc ++] = Tcl_NewStringObj ("type",-1);
sl@0	1190	lv [lc ++] = Tcl_NewStringObj (typeString [f.type],-1);
sl@0	1191	lv [lc ++] = Tcl_NewStringObj ("line",-1);
sl@0	1192	lv [lc ++] = Tcl_NewIntObj (f.line[0]);
sl@0	1193
sl@0	1194	if (f.type == TCL_LOCATION_SOURCE) {
sl@0	1195	lv [lc ++] = Tcl_NewStringObj ("file",-1);
sl@0	1196	lv [lc ++] = f.data.eval.path;
sl@0	1197	/* Death of reference by TclGetSrcInfoForPc */
sl@0	1198	Tcl_DecrRefCount (f.data.eval.path);
sl@0	1199	}
sl@0	1200
sl@0	1201	lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
sl@0	1202	lv [lc ++] = Tcl_NewStringObj (f.cmd.str.cmd, f.cmd.str.len);
sl@0	1203
sl@0	1204	if (procPtr != NULL) {
sl@0	1205	Tcl_HashEntry* namePtr = procPtr->cmdPtr->hPtr;
sl@0	1206	char* procName = Tcl_GetHashKey (namePtr->tablePtr, namePtr);
sl@0	1207	char* nsName = procPtr->cmdPtr->nsPtr->fullName;
sl@0	1208
sl@0	1209	lv [lc ++] = Tcl_NewStringObj ("proc",-1);
sl@0	1210	lv [lc ++] = Tcl_NewStringObj (nsName,-1);
sl@0	1211
sl@0	1212	if (strcmp (nsName, "::") != 0) {
sl@0	1213	Tcl_AppendToObj (lv [lc-1], "::", -1);
sl@0	1214	}
sl@0	1215	Tcl_AppendToObj (lv [lc-1], procName, -1);
sl@0	1216	}
sl@0	1217	break;
sl@0	1218	}
sl@0	1219
sl@0	1220	case TCL_LOCATION_SOURCE:
sl@0	1221	/* Evaluation of a script file */
sl@0	1222
sl@0	1223	lv [lc ++] = Tcl_NewStringObj ("type",-1);
sl@0	1224	lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
sl@0	1225	lv [lc ++] = Tcl_NewStringObj ("line",-1);
sl@0	1226	lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]);
sl@0	1227	lv [lc ++] = Tcl_NewStringObj ("file",-1);
sl@0	1228	lv [lc ++] = framePtr->data.eval.path;
sl@0	1229	/* Refcount framePtr->data.eval.path goes up when lv
sl@0	1230	* is converted into the result list object.
sl@0	1231	*/
sl@0	1232	lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
sl@0	1233	lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd,
sl@0	1234	framePtr->cmd.str.len);
sl@0	1235	break;
sl@0	1236
sl@0	1237	case TCL_LOCATION_PROC:
sl@0	1238	Tcl_Panic ("TCL_LOCATION_PROC found in standard frame");
sl@0	1239	break;
sl@0	1240	}
sl@0	1241
sl@0	1242
sl@0	1243	/* 'level'. Common to all frame types. Conditional on having an
sl@0	1244	* associated _visible_ CallFrame */
sl@0	1245
sl@0	1246	if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) {
sl@0	1247	CallFrame* current = framePtr->framePtr;
sl@0	1248	CallFrame* top = iPtr->varFramePtr;
sl@0	1249	CallFrame* idx;
sl@0	1250
sl@0	1251	for (idx = top;
sl@0	1252	idx != NULL;
sl@0	1253	idx = idx->callerVarPtr) {
sl@0	1254	if (idx == current) {
sl@0	1255	int c = framePtr->framePtr->level;
sl@0	1256	int t = iPtr->varFramePtr->level;
sl@0	1257
sl@0	1258	lv [lc ++] = Tcl_NewStringObj ("level",-1);
sl@0	1259	lv [lc ++] = Tcl_NewIntObj (t - c);
sl@0	1260	break;
sl@0	1261	}
sl@0	1262	}
sl@0	1263	}
sl@0	1264
sl@0	1265	Tcl_SetObjResult(interp, Tcl_NewListObj (lc, lv));
sl@0	1266	return TCL_OK;
sl@0	1267	}
sl@0	1268	}
sl@0	1269
sl@0	1270	Tcl_WrongNumArgs(interp, 2, objv, "?number?");
sl@0	1271
sl@0	1272	return TCL_ERROR;
sl@0	1273	}
sl@0	1274	#endif
sl@0	1275
sl@0	1276	/*
sl@0	1277	*----------------------------------------------------------------------
sl@0	1278	*
sl@0	1279	* InfoFunctionsCmd --
sl@0	1280	*
sl@0	1281	* Called to implement the "info functions" command that returns the
sl@0	1282	* list of math functions matching an optional pattern. Handles the
sl@0	1283	* following syntax:
sl@0	1284	*
sl@0	1285	* info functions ?pattern?
sl@0	1286	*
sl@0	1287	* Results:
sl@0	1288	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	1289	*
sl@0	1290	* Side effects:
sl@0	1291	* Returns a result in the interpreter's result object. If there is
sl@0	1292	* an error, the result is an error message.
sl@0	1293	*
sl@0	1294	*----------------------------------------------------------------------
sl@0	1295	*/
sl@0	1296
sl@0	1297	static int
sl@0	1298	InfoFunctionsCmd(dummy, interp, objc, objv)
sl@0	1299	ClientData dummy; /* Not used. */
sl@0	1300	Tcl_Interp interp; / Current interpreter. */
sl@0	1301	int objc; /* Number of arguments. */
sl@0	1302	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1303	{
sl@0	1304	char *pattern;
sl@0	1305	Tcl_Obj *listPtr;
sl@0	1306
sl@0	1307	if (objc == 2) {
sl@0	1308	pattern = NULL;
sl@0	1309	} else if (objc == 3) {
sl@0	1310	pattern = Tcl_GetString(objv[2]);
sl@0	1311	} else {
sl@0	1312	Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
sl@0	1313	return TCL_ERROR;
sl@0	1314	}
sl@0	1315
sl@0	1316	listPtr = Tcl_ListMathFuncs(interp, pattern);
sl@0	1317	if (listPtr == NULL) {
sl@0	1318	return TCL_ERROR;
sl@0	1319	}
sl@0	1320	Tcl_SetObjResult(interp, listPtr);
sl@0	1321	return TCL_OK;
sl@0	1322	}
sl@0	1323
sl@0	1324	/*
sl@0	1325	*----------------------------------------------------------------------
sl@0	1326	*
sl@0	1327	* InfoGlobalsCmd --
sl@0	1328	*
sl@0	1329	* Called to implement the "info globals" command that returns the list
sl@0	1330	* of global variables matching an optional pattern. Handles the
sl@0	1331	* following syntax:
sl@0	1332	*
sl@0	1333	* info globals ?pattern?
sl@0	1334	*
sl@0	1335	* Results:
sl@0	1336	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	1337	*
sl@0	1338	* Side effects:
sl@0	1339	* Returns a result in the interpreter's result object. If there is
sl@0	1340	* an error, the result is an error message.
sl@0	1341	*
sl@0	1342	*----------------------------------------------------------------------
sl@0	1343	*/
sl@0	1344
sl@0	1345	static int
sl@0	1346	InfoGlobalsCmd(dummy, interp, objc, objv)
sl@0	1347	ClientData dummy; /* Not used. */
sl@0	1348	Tcl_Interp interp; / Current interpreter. */
sl@0	1349	int objc; /* Number of arguments. */
sl@0	1350	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1351	{
sl@0	1352	char varName, pattern;
sl@0	1353	Namespace globalNsPtr = (Namespace ) Tcl_GetGlobalNamespace(interp);
sl@0	1354	register Tcl_HashEntry *entryPtr;
sl@0	1355	Tcl_HashSearch search;
sl@0	1356	Var *varPtr;
sl@0	1357	Tcl_Obj *listPtr;
sl@0	1358
sl@0	1359	if (objc == 2) {
sl@0	1360	pattern = NULL;
sl@0	1361	} else if (objc == 3) {
sl@0	1362	pattern = Tcl_GetString(objv[2]);
sl@0	1363	/*
sl@0	1364	* Strip leading global-namespace qualifiers. [Bug 1057461]
sl@0	1365	*/
sl@0	1366	if (pattern[0] == ':' && pattern[1] == ':') {
sl@0	1367	while (*pattern == ':') {
sl@0	1368	pattern++;
sl@0	1369	}
sl@0	1370	}
sl@0	1371	} else {
sl@0	1372	Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
sl@0	1373	return TCL_ERROR;
sl@0	1374	}
sl@0	1375
sl@0	1376	/*
sl@0	1377	* Scan through the global :: namespace's variable table and create a
sl@0	1378	* list of all global variables that match the pattern.
sl@0	1379	*/
sl@0	1380
sl@0	1381	listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	1382	if (pattern != NULL && TclMatchIsTrivial(pattern)) {
sl@0	1383	entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern);
sl@0	1384	if (entryPtr != NULL) {
sl@0	1385	varPtr = (Var *) Tcl_GetHashValue(entryPtr);
sl@0	1386	if (!TclIsVarUndefined(varPtr)) {
sl@0	1387	Tcl_ListObjAppendElement(interp, listPtr,
sl@0	1388	Tcl_NewStringObj(pattern, -1));
sl@0	1389	}
sl@0	1390	}
sl@0	1391	} else {
sl@0	1392	for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
sl@0	1393	entryPtr != NULL;
sl@0	1394	entryPtr = Tcl_NextHashEntry(&search)) {
sl@0	1395	varPtr = (Var *) Tcl_GetHashValue(entryPtr);
sl@0	1396	if (TclIsVarUndefined(varPtr)) {
sl@0	1397	continue;
sl@0	1398	}
sl@0	1399	varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
sl@0	1400	if ((pattern == NULL) \|\| Tcl_StringMatch(varName, pattern)) {
sl@0	1401	Tcl_ListObjAppendElement(interp, listPtr,
sl@0	1402	Tcl_NewStringObj(varName, -1));
sl@0	1403	}
sl@0	1404	}
sl@0	1405	}
sl@0	1406	Tcl_SetObjResult(interp, listPtr);
sl@0	1407	return TCL_OK;
sl@0	1408	}
sl@0	1409
sl@0	1410	/*
sl@0	1411	*----------------------------------------------------------------------
sl@0	1412	*
sl@0	1413	* InfoHostnameCmd --
sl@0	1414	*
sl@0	1415	* Called to implement the "info hostname" command that returns the
sl@0	1416	* host name. Handles the following syntax:
sl@0	1417	*
sl@0	1418	* info hostname
sl@0	1419	*
sl@0	1420	* Results:
sl@0	1421	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	1422	*
sl@0	1423	* Side effects:
sl@0	1424	* Returns a result in the interpreter's result object. If there is
sl@0	1425	* an error, the result is an error message.
sl@0	1426	*
sl@0	1427	*----------------------------------------------------------------------
sl@0	1428	*/
sl@0	1429
sl@0	1430	static int
sl@0	1431	InfoHostnameCmd(dummy, interp, objc, objv)
sl@0	1432	ClientData dummy; /* Not used. */
sl@0	1433	Tcl_Interp interp; / Current interpreter. */
sl@0	1434	int objc; /* Number of arguments. */
sl@0	1435	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1436	{
sl@0	1437	CONST char *name;
sl@0	1438	if (objc != 2) {
sl@0	1439	Tcl_WrongNumArgs(interp, 2, objv, NULL);
sl@0	1440	return TCL_ERROR;
sl@0	1441	}
sl@0	1442
sl@0	1443	name = Tcl_GetHostName();
sl@0	1444	if (name) {
sl@0	1445	Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1);
sl@0	1446	return TCL_OK;
sl@0	1447	} else {
sl@0	1448	Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0	1449	"unable to determine name of host", -1);
sl@0	1450	return TCL_ERROR;
sl@0	1451	}
sl@0	1452	}
sl@0	1453
sl@0	1454	/*
sl@0	1455	*----------------------------------------------------------------------
sl@0	1456	*
sl@0	1457	* InfoLevelCmd --
sl@0	1458	*
sl@0	1459	* Called to implement the "info level" command that returns
sl@0	1460	* information about the call stack. Handles the following syntax:
sl@0	1461	*
sl@0	1462	* info level ?number?
sl@0	1463	*
sl@0	1464	* Results:
sl@0	1465	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	1466	*
sl@0	1467	* Side effects:
sl@0	1468	* Returns a result in the interpreter's result object. If there is
sl@0	1469	* an error, the result is an error message.
sl@0	1470	*
sl@0	1471	*----------------------------------------------------------------------
sl@0	1472	*/
sl@0	1473
sl@0	1474	static int
sl@0	1475	InfoLevelCmd(dummy, interp, objc, objv)
sl@0	1476	ClientData dummy; /* Not used. */
sl@0	1477	Tcl_Interp interp; / Current interpreter. */
sl@0	1478	int objc; /* Number of arguments. */
sl@0	1479	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1480	{
sl@0	1481	Interp iPtr = (Interp ) interp;
sl@0	1482	int level;
sl@0	1483	CallFrame *framePtr;
sl@0	1484	Tcl_Obj *listPtr;
sl@0	1485
sl@0	1486	if (objc == 2) { /* just "info level" */
sl@0	1487	if (iPtr->varFramePtr == NULL) {
sl@0	1488	Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
sl@0	1489	} else {
sl@0	1490	Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level);
sl@0	1491	}
sl@0	1492	return TCL_OK;
sl@0	1493	} else if (objc == 3) {
sl@0	1494	if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
sl@0	1495	return TCL_ERROR;
sl@0	1496	}
sl@0	1497	if (level <= 0) {
sl@0	1498	if (iPtr->varFramePtr == NULL) {
sl@0	1499	levelError:
sl@0	1500	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1501	"bad level \"",
sl@0	1502	Tcl_GetString(objv[2]),
sl@0	1503	"\"", (char *) NULL);
sl@0	1504	return TCL_ERROR;
sl@0	1505	}
sl@0	1506	level += iPtr->varFramePtr->level;
sl@0	1507	}
sl@0	1508	for (framePtr = iPtr->varFramePtr; framePtr != NULL;
sl@0	1509	framePtr = framePtr->callerVarPtr) {
sl@0	1510	if (framePtr->level == level) {
sl@0	1511	break;
sl@0	1512	}
sl@0	1513	}
sl@0	1514	if (framePtr == NULL) {
sl@0	1515	goto levelError;
sl@0	1516	}
sl@0	1517
sl@0	1518	listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
sl@0	1519	Tcl_SetObjResult(interp, listPtr);
sl@0	1520	return TCL_OK;
sl@0	1521	}
sl@0	1522
sl@0	1523	Tcl_WrongNumArgs(interp, 2, objv, "?number?");
sl@0	1524	return TCL_ERROR;
sl@0	1525	}
sl@0	1526
sl@0	1527	/*
sl@0	1528	*----------------------------------------------------------------------
sl@0	1529	*
sl@0	1530	* InfoLibraryCmd --
sl@0	1531	*
sl@0	1532	* Called to implement the "info library" command that returns the
sl@0	1533	* library directory for the Tcl installation. Handles the following
sl@0	1534	* syntax:
sl@0	1535	*
sl@0	1536	* info library
sl@0	1537	*
sl@0	1538	* Results:
sl@0	1539	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	1540	*
sl@0	1541	* Side effects:
sl@0	1542	* Returns a result in the interpreter's result object. If there is
sl@0	1543	* an error, the result is an error message.
sl@0	1544	*
sl@0	1545	*----------------------------------------------------------------------
sl@0	1546	*/
sl@0	1547
sl@0	1548	static int
sl@0	1549	InfoLibraryCmd(dummy, interp, objc, objv)
sl@0	1550	ClientData dummy; /* Not used. */
sl@0	1551	Tcl_Interp interp; / Current interpreter. */
sl@0	1552	int objc; /* Number of arguments. */
sl@0	1553	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1554	{
sl@0	1555	CONST char *libDirName;
sl@0	1556
sl@0	1557	if (objc != 2) {
sl@0	1558	Tcl_WrongNumArgs(interp, 2, objv, NULL);
sl@0	1559	return TCL_ERROR;
sl@0	1560	}
sl@0	1561
sl@0	1562	libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
sl@0	1563	if (libDirName != NULL) {
sl@0	1564	Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1);
sl@0	1565	return TCL_OK;
sl@0	1566	}
sl@0	1567	Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0	1568	"no library has been specified for Tcl", -1);
sl@0	1569	return TCL_ERROR;
sl@0	1570	}
sl@0	1571
sl@0	1572	/*
sl@0	1573	*----------------------------------------------------------------------
sl@0	1574	*
sl@0	1575	* InfoLoadedCmd --
sl@0	1576	*
sl@0	1577	* Called to implement the "info loaded" command that returns the
sl@0	1578	* packages that have been loaded into an interpreter. Handles the
sl@0	1579	* following syntax:
sl@0	1580	*
sl@0	1581	* info loaded ?interp?
sl@0	1582	*
sl@0	1583	* Results:
sl@0	1584	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	1585	*
sl@0	1586	* Side effects:
sl@0	1587	* Returns a result in the interpreter's result object. If there is
sl@0	1588	* an error, the result is an error message.
sl@0	1589	*
sl@0	1590	*----------------------------------------------------------------------
sl@0	1591	*/
sl@0	1592
sl@0	1593	static int
sl@0	1594	InfoLoadedCmd(dummy, interp, objc, objv)
sl@0	1595	ClientData dummy; /* Not used. */
sl@0	1596	Tcl_Interp interp; / Current interpreter. */
sl@0	1597	int objc; /* Number of arguments. */
sl@0	1598	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1599	{
sl@0	1600	char *interpName;
sl@0	1601	int result;
sl@0	1602
sl@0	1603	if ((objc != 2) && (objc != 3)) {
sl@0	1604	Tcl_WrongNumArgs(interp, 2, objv, "?interp?");
sl@0	1605	return TCL_ERROR;
sl@0	1606	}
sl@0	1607
sl@0	1608	if (objc == 2) { /* get loaded pkgs in all interpreters */
sl@0	1609	interpName = NULL;
sl@0	1610	} else { /* get pkgs just in specified interp */
sl@0	1611	interpName = Tcl_GetString(objv[2]);
sl@0	1612	}
sl@0	1613	result = TclGetLoadedPackages(interp, interpName);
sl@0	1614	return result;
sl@0	1615	}
sl@0	1616
sl@0	1617	/*
sl@0	1618	*----------------------------------------------------------------------
sl@0	1619	*
sl@0	1620	* InfoLocalsCmd --
sl@0	1621	*
sl@0	1622	* Called to implement the "info locals" command to return a list of
sl@0	1623	* local variables that match an optional pattern. Handles the
sl@0	1624	* following syntax:
sl@0	1625	*
sl@0	1626	* info locals ?pattern?
sl@0	1627	*
sl@0	1628	* Results:
sl@0	1629	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	1630	*
sl@0	1631	* Side effects:
sl@0	1632	* Returns a result in the interpreter's result object. If there is
sl@0	1633	* an error, the result is an error message.
sl@0	1634	*
sl@0	1635	*----------------------------------------------------------------------
sl@0	1636	*/
sl@0	1637
sl@0	1638	static int
sl@0	1639	InfoLocalsCmd(dummy, interp, objc, objv)
sl@0	1640	ClientData dummy; /* Not used. */
sl@0	1641	Tcl_Interp interp; / Current interpreter. */
sl@0	1642	int objc; /* Number of arguments. */
sl@0	1643	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1644	{
sl@0	1645	Interp iPtr = (Interp ) interp;
sl@0	1646	char *pattern;
sl@0	1647	Tcl_Obj *listPtr;
sl@0	1648
sl@0	1649	if (objc == 2) {
sl@0	1650	pattern = NULL;
sl@0	1651	} else if (objc == 3) {
sl@0	1652	pattern = Tcl_GetString(objv[2]);
sl@0	1653	} else {
sl@0	1654	Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
sl@0	1655	return TCL_ERROR;
sl@0	1656	}
sl@0	1657
sl@0	1658	if (iPtr->varFramePtr == NULL \|\| !iPtr->varFramePtr->isProcCallFrame) {
sl@0	1659	return TCL_OK;
sl@0	1660	}
sl@0	1661
sl@0	1662	/*
sl@0	1663	* Return a list containing names of first the compiled locals (i.e. the
sl@0	1664	* ones stored in the call frame), then the variables in the local hash
sl@0	1665	* table (if one exists).
sl@0	1666	*/
sl@0	1667
sl@0	1668	listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	1669	AppendLocals(interp, listPtr, pattern, 0);
sl@0	1670	Tcl_SetObjResult(interp, listPtr);
sl@0	1671	return TCL_OK;
sl@0	1672	}
sl@0	1673
sl@0	1674	/*
sl@0	1675	*----------------------------------------------------------------------
sl@0	1676	*
sl@0	1677	* AppendLocals --
sl@0	1678	*
sl@0	1679	* Append the local variables for the current frame to the
sl@0	1680	* specified list object.
sl@0	1681	*
sl@0	1682	* Results:
sl@0	1683	* None.
sl@0	1684	*
sl@0	1685	* Side effects:
sl@0	1686	* None.
sl@0	1687	*
sl@0	1688	*----------------------------------------------------------------------
sl@0	1689	*/
sl@0	1690
sl@0	1691	static void
sl@0	1692	AppendLocals(interp, listPtr, pattern, includeLinks)
sl@0	1693	Tcl_Interp interp; / Current interpreter. */
sl@0	1694	Tcl_Obj listPtr; / List object to append names to. */
sl@0	1695	CONST char pattern; / Pattern to match against. */
sl@0	1696	int includeLinks; /* 1 if upvars should be included, else 0. */
sl@0	1697	{
sl@0	1698	Interp iPtr = (Interp ) interp;
sl@0	1699	CompiledLocal *localPtr;
sl@0	1700	Var *varPtr;
sl@0	1701	int i, localVarCt;
sl@0	1702	char *varName;
sl@0	1703	Tcl_HashTable *localVarTablePtr;
sl@0	1704	register Tcl_HashEntry *entryPtr;
sl@0	1705	Tcl_HashSearch search;
sl@0	1706
sl@0	1707	localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr;
sl@0	1708	localVarCt = iPtr->varFramePtr->numCompiledLocals;
sl@0	1709	varPtr = iPtr->varFramePtr->compiledLocals;
sl@0	1710	localVarTablePtr = iPtr->varFramePtr->varTablePtr;
sl@0	1711
sl@0	1712	for (i = 0; i < localVarCt; i++) {
sl@0	1713	/*
sl@0	1714	* Skip nameless (temporary) variables and undefined variables
sl@0	1715	*/
sl@0	1716
sl@0	1717	if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)
sl@0	1718	&& (includeLinks \|\| !TclIsVarLink(varPtr))) {
sl@0	1719	varName = varPtr->name;
sl@0	1720	if ((pattern == NULL) \|\| Tcl_StringMatch(varName, pattern)) {
sl@0	1721	Tcl_ListObjAppendElement(interp, listPtr,
sl@0	1722	Tcl_NewStringObj(varName, -1));
sl@0	1723	}
sl@0	1724	}
sl@0	1725	varPtr++;
sl@0	1726	localPtr = localPtr->nextPtr;
sl@0	1727	}
sl@0	1728
sl@0	1729	if (localVarTablePtr != NULL) {
sl@0	1730	for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);
sl@0	1731	entryPtr != NULL;
sl@0	1732	entryPtr = Tcl_NextHashEntry(&search)) {
sl@0	1733	varPtr = (Var *) Tcl_GetHashValue(entryPtr);
sl@0	1734	if (!TclIsVarUndefined(varPtr)
sl@0	1735	&& (includeLinks \|\| !TclIsVarLink(varPtr))) {
sl@0	1736	varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);
sl@0	1737	if ((pattern == NULL)
sl@0	1738	\|\| Tcl_StringMatch(varName, pattern)) {
sl@0	1739	Tcl_ListObjAppendElement(interp, listPtr,
sl@0	1740	Tcl_NewStringObj(varName, -1));
sl@0	1741	}
sl@0	1742	}
sl@0	1743	}
sl@0	1744	}
sl@0	1745	}
sl@0	1746
sl@0	1747	/*
sl@0	1748	*----------------------------------------------------------------------
sl@0	1749	*
sl@0	1750	* InfoNameOfExecutableCmd --
sl@0	1751	*
sl@0	1752	* Called to implement the "info nameofexecutable" command that returns
sl@0	1753	* the name of the binary file running this application. Handles the
sl@0	1754	* following syntax:
sl@0	1755	*
sl@0	1756	* info nameofexecutable
sl@0	1757	*
sl@0	1758	* Results:
sl@0	1759	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	1760	*
sl@0	1761	* Side effects:
sl@0	1762	* Returns a result in the interpreter's result object. If there is
sl@0	1763	* an error, the result is an error message.
sl@0	1764	*
sl@0	1765	*----------------------------------------------------------------------
sl@0	1766	*/
sl@0	1767
sl@0	1768	static int
sl@0	1769	InfoNameOfExecutableCmd(dummy, interp, objc, objv)
sl@0	1770	ClientData dummy; /* Not used. */
sl@0	1771	Tcl_Interp interp; / Current interpreter. */
sl@0	1772	int objc; /* Number of arguments. */
sl@0	1773	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1774	{
sl@0	1775	CONST char *nameOfExecutable;
sl@0	1776
sl@0	1777	if (objc != 2) {
sl@0	1778	Tcl_WrongNumArgs(interp, 2, objv, NULL);
sl@0	1779	return TCL_ERROR;
sl@0	1780	}
sl@0	1781
sl@0	1782	nameOfExecutable = Tcl_GetNameOfExecutable();
sl@0	1783
sl@0	1784	if (nameOfExecutable != NULL) {
sl@0	1785	Tcl_SetStringObj(Tcl_GetObjResult(interp), nameOfExecutable, -1);
sl@0	1786	}
sl@0	1787	return TCL_OK;
sl@0	1788	}
sl@0	1789
sl@0	1790	/*
sl@0	1791	*----------------------------------------------------------------------
sl@0	1792	*
sl@0	1793	* InfoPatchLevelCmd --
sl@0	1794	*
sl@0	1795	* Called to implement the "info patchlevel" command that returns the
sl@0	1796	* default value for an argument to a procedure. Handles the following
sl@0	1797	* syntax:
sl@0	1798	*
sl@0	1799	* info patchlevel
sl@0	1800	*
sl@0	1801	* Results:
sl@0	1802	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	1803	*
sl@0	1804	* Side effects:
sl@0	1805	* Returns a result in the interpreter's result object. If there is
sl@0	1806	* an error, the result is an error message.
sl@0	1807	*
sl@0	1808	*----------------------------------------------------------------------
sl@0	1809	*/
sl@0	1810
sl@0	1811	static int
sl@0	1812	InfoPatchLevelCmd(dummy, interp, objc, objv)
sl@0	1813	ClientData dummy; /* Not used. */
sl@0	1814	Tcl_Interp interp; / Current interpreter. */
sl@0	1815	int objc; /* Number of arguments. */
sl@0	1816	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1817	{
sl@0	1818	CONST char *patchlevel;
sl@0	1819
sl@0	1820	if (objc != 2) {
sl@0	1821	Tcl_WrongNumArgs(interp, 2, objv, NULL);
sl@0	1822	return TCL_ERROR;
sl@0	1823	}
sl@0	1824
sl@0	1825	patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
sl@0	1826	(TCL_GLOBAL_ONLY \| TCL_LEAVE_ERR_MSG));
sl@0	1827	if (patchlevel != NULL) {
sl@0	1828	Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1);
sl@0	1829	return TCL_OK;
sl@0	1830	}
sl@0	1831	return TCL_ERROR;
sl@0	1832	}
sl@0	1833
sl@0	1834	/*
sl@0	1835	*----------------------------------------------------------------------
sl@0	1836	*
sl@0	1837	* InfoProcsCmd --
sl@0	1838	*
sl@0	1839	* Called to implement the "info procs" command that returns the
sl@0	1840	* list of procedures in the interpreter that match an optional pattern.
sl@0	1841	* The pattern, if any, consists of an optional sequence of namespace
sl@0	1842	* names separated by "::" qualifiers, which is followed by a
sl@0	1843	* glob-style pattern that restricts which commands are returned.
sl@0	1844	* Handles the following syntax:
sl@0	1845	*
sl@0	1846	* info procs ?pattern?
sl@0	1847	*
sl@0	1848	* Results:
sl@0	1849	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	1850	*
sl@0	1851	* Side effects:
sl@0	1852	* Returns a result in the interpreter's result object. If there is
sl@0	1853	* an error, the result is an error message.
sl@0	1854	*
sl@0	1855	*----------------------------------------------------------------------
sl@0	1856	*/
sl@0	1857
sl@0	1858	static int
sl@0	1859	InfoProcsCmd(dummy, interp, objc, objv)
sl@0	1860	ClientData dummy; /* Not used. */
sl@0	1861	Tcl_Interp interp; / Current interpreter. */
sl@0	1862	int objc; /* Number of arguments. */
sl@0	1863	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1864	{
sl@0	1865	char cmdName, pattern;
sl@0	1866	CONST char *simplePattern;
sl@0	1867	Namespace *nsPtr;
sl@0	1868	#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
sl@0	1869	Namespace globalNsPtr = (Namespace ) Tcl_GetGlobalNamespace(interp);
sl@0	1870	#endif
sl@0	1871	Namespace currNsPtr = (Namespace ) Tcl_GetCurrentNamespace(interp);
sl@0	1872	Tcl_Obj listPtr, elemObjPtr;
sl@0	1873	int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
sl@0	1874	register Tcl_HashEntry *entryPtr;
sl@0	1875	Tcl_HashSearch search;
sl@0	1876	Command cmdPtr, realCmdPtr;
sl@0	1877
sl@0	1878	/*
sl@0	1879	* Get the pattern and find the "effective namespace" in which to
sl@0	1880	* list procs.
sl@0	1881	*/
sl@0	1882
sl@0	1883	if (objc == 2) {
sl@0	1884	simplePattern = NULL;
sl@0	1885	nsPtr = currNsPtr;
sl@0	1886	specificNsInPattern = 0;
sl@0	1887	} else if (objc == 3) {
sl@0	1888	/*
sl@0	1889	* From the pattern, get the effective namespace and the simple
sl@0	1890	* pattern (no namespace qualifiers or ::'s) at the end. If an
sl@0	1891	* error was found while parsing the pattern, return it. Otherwise,
sl@0	1892	* if the namespace wasn't found, just leave nsPtr NULL: we will
sl@0	1893	* return an empty list since no commands there can be found.
sl@0	1894	*/
sl@0	1895
sl@0	1896	Namespace dummy1NsPtr, dummy2NsPtr;
sl@0	1897
sl@0	1898	pattern = Tcl_GetString(objv[2]);
sl@0	1899	TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
sl@0	1900	/flags/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
sl@0	1901	&simplePattern);
sl@0	1902
sl@0	1903	if (nsPtr != NULL) { /* we successfully found the pattern's ns */
sl@0	1904	specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
sl@0	1905	}
sl@0	1906	} else {
sl@0	1907	Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
sl@0	1908	return TCL_ERROR;
sl@0	1909	}
sl@0	1910
sl@0	1911	if (nsPtr == NULL) {
sl@0	1912	return TCL_OK;
sl@0	1913	}
sl@0	1914
sl@0	1915	/*
sl@0	1916	* Scan through the effective namespace's command table and create a
sl@0	1917	* list with all procs that match the pattern. If a specific
sl@0	1918	* namespace was requested in the pattern, qualify the command names
sl@0	1919	* with the namespace name.
sl@0	1920	*/
sl@0	1921
sl@0	1922	listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	1923	#ifndef INFO_PROCS_SEARCH_GLOBAL_NS
sl@0	1924	if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
sl@0	1925	entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
sl@0	1926	if (entryPtr != NULL) {
sl@0	1927	cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
sl@0	1928
sl@0	1929	if (!TclIsProc(cmdPtr)) {
sl@0	1930	realCmdPtr = (Command *)
sl@0	1931	TclGetOriginalCommand((Tcl_Command) cmdPtr);
sl@0	1932	if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
sl@0	1933	goto simpleProcOK;
sl@0	1934	}
sl@0	1935	} else {
sl@0	1936	simpleProcOK:
sl@0	1937	if (specificNsInPattern) {
sl@0	1938	elemObjPtr = Tcl_NewObj();
sl@0	1939	Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
sl@0	1940	elemObjPtr);
sl@0	1941	} else {
sl@0	1942	elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
sl@0	1943	}
sl@0	1944	Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
sl@0	1945	}
sl@0	1946	}
sl@0	1947	} else
sl@0	1948	#endif /* !INFO_PROCS_SEARCH_GLOBAL_NS */
sl@0	1949	{
sl@0	1950	entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
sl@0	1951	while (entryPtr != NULL) {
sl@0	1952	cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
sl@0	1953	if ((simplePattern == NULL)
sl@0	1954	\|\| Tcl_StringMatch(cmdName, simplePattern)) {
sl@0	1955	cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
sl@0	1956
sl@0	1957	if (!TclIsProc(cmdPtr)) {
sl@0	1958	realCmdPtr = (Command *)
sl@0	1959	TclGetOriginalCommand((Tcl_Command) cmdPtr);
sl@0	1960	if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
sl@0	1961	goto procOK;
sl@0	1962	}
sl@0	1963	} else {
sl@0	1964	procOK:
sl@0	1965	if (specificNsInPattern) {
sl@0	1966	elemObjPtr = Tcl_NewObj();
sl@0	1967	Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
sl@0	1968	elemObjPtr);
sl@0	1969	} else {
sl@0	1970	elemObjPtr = Tcl_NewStringObj(cmdName, -1);
sl@0	1971	}
sl@0	1972	Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
sl@0	1973	}
sl@0	1974	}
sl@0	1975	entryPtr = Tcl_NextHashEntry(&search);
sl@0	1976	}
sl@0	1977
sl@0	1978	/*
sl@0	1979	* If the effective namespace isn't the global :: namespace, and a
sl@0	1980	* specific namespace wasn't requested in the pattern, then add in
sl@0	1981	* all global :: procs that match the simple pattern. Of course,
sl@0	1982	* we add in only those procs that aren't hidden by a proc in
sl@0	1983	* the effective namespace.
sl@0	1984	*/
sl@0	1985
sl@0	1986	#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
sl@0	1987	/*
sl@0	1988	* If "info procs" worked like "info commands", returning the
sl@0	1989	* commands also seen in the global namespace, then you would
sl@0	1990	* include this code. As this could break backwards compatibilty
sl@0	1991	* with 8.0-8.2, we decided not to "fix" it in 8.3, leaving the
sl@0	1992	* behavior slightly different.
sl@0	1993	*/
sl@0	1994	if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
sl@0	1995	entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
sl@0	1996	while (entryPtr != NULL) {
sl@0	1997	cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
sl@0	1998	if ((simplePattern == NULL)
sl@0	1999	\|\| Tcl_StringMatch(cmdName, simplePattern)) {
sl@0	2000	if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
sl@0	2001	cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
sl@0	2002	realCmdPtr = (Command *) TclGetOriginalCommand(
sl@0	2003	(Tcl_Command) cmdPtr);
sl@0	2004
sl@0	2005	if (TclIsProc(cmdPtr) \|\| ((realCmdPtr != NULL)
sl@0	2006	&& TclIsProc(realCmdPtr))) {
sl@0	2007	Tcl_ListObjAppendElement(interp, listPtr,
sl@0	2008	Tcl_NewStringObj(cmdName, -1));
sl@0	2009	}
sl@0	2010	}
sl@0	2011	}
sl@0	2012	entryPtr = Tcl_NextHashEntry(&search);
sl@0	2013	}
sl@0	2014	}
sl@0	2015	#endif
sl@0	2016	}
sl@0	2017
sl@0	2018	Tcl_SetObjResult(interp, listPtr);
sl@0	2019	return TCL_OK;
sl@0	2020	}
sl@0	2021
sl@0	2022	/*
sl@0	2023	*----------------------------------------------------------------------
sl@0	2024	*
sl@0	2025	* InfoScriptCmd --
sl@0	2026	*
sl@0	2027	* Called to implement the "info script" command that returns the
sl@0	2028	* script file that is currently being evaluated. Handles the
sl@0	2029	* following syntax:
sl@0	2030	*
sl@0	2031	* info script ?newName?
sl@0	2032	*
sl@0	2033	* If newName is specified, it will set that as the internal name.
sl@0	2034	*
sl@0	2035	* Results:
sl@0	2036	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	2037	*
sl@0	2038	* Side effects:
sl@0	2039	* Returns a result in the interpreter's result object. If there is
sl@0	2040	* an error, the result is an error message. It may change the
sl@0	2041	* internal script filename.
sl@0	2042	*
sl@0	2043	*----------------------------------------------------------------------
sl@0	2044	*/
sl@0	2045
sl@0	2046	static int
sl@0	2047	InfoScriptCmd(dummy, interp, objc, objv)
sl@0	2048	ClientData dummy; /* Not used. */
sl@0	2049	Tcl_Interp interp; / Current interpreter. */
sl@0	2050	int objc; /* Number of arguments. */
sl@0	2051	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2052	{
sl@0	2053	Interp iPtr = (Interp ) interp;
sl@0	2054	if ((objc != 2) && (objc != 3)) {
sl@0	2055	Tcl_WrongNumArgs(interp, 2, objv, "?filename?");
sl@0	2056	return TCL_ERROR;
sl@0	2057	}
sl@0	2058
sl@0	2059	if (objc == 3) {
sl@0	2060	if (iPtr->scriptFile != NULL) {
sl@0	2061	Tcl_DecrRefCount(iPtr->scriptFile);
sl@0	2062	}
sl@0	2063	iPtr->scriptFile = objv[2];
sl@0	2064	Tcl_IncrRefCount(iPtr->scriptFile);
sl@0	2065	}
sl@0	2066	if (iPtr->scriptFile != NULL) {
sl@0	2067	Tcl_SetObjResult(interp, iPtr->scriptFile);
sl@0	2068	}
sl@0	2069	return TCL_OK;
sl@0	2070	}
sl@0	2071
sl@0	2072	/*
sl@0	2073	*----------------------------------------------------------------------
sl@0	2074	*
sl@0	2075	* InfoSharedlibCmd --
sl@0	2076	*
sl@0	2077	* Called to implement the "info sharedlibextension" command that
sl@0	2078	* returns the file extension used for shared libraries. Handles the
sl@0	2079	* following syntax:
sl@0	2080	*
sl@0	2081	* info sharedlibextension
sl@0	2082	*
sl@0	2083	* Results:
sl@0	2084	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	2085	*
sl@0	2086	* Side effects:
sl@0	2087	* Returns a result in the interpreter's result object. If there is
sl@0	2088	* an error, the result is an error message.
sl@0	2089	*
sl@0	2090	*----------------------------------------------------------------------
sl@0	2091	*/
sl@0	2092
sl@0	2093	static int
sl@0	2094	InfoSharedlibCmd(dummy, interp, objc, objv)
sl@0	2095	ClientData dummy; /* Not used. */
sl@0	2096	Tcl_Interp interp; / Current interpreter. */
sl@0	2097	int objc; /* Number of arguments. */
sl@0	2098	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2099	{
sl@0	2100	if (objc != 2) {
sl@0	2101	Tcl_WrongNumArgs(interp, 2, objv, NULL);
sl@0	2102	return TCL_ERROR;
sl@0	2103	}
sl@0	2104
sl@0	2105	#ifdef TCL_SHLIB_EXT
sl@0	2106	Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1);
sl@0	2107	#endif
sl@0	2108	return TCL_OK;
sl@0	2109	}
sl@0	2110
sl@0	2111	/*
sl@0	2112	*----------------------------------------------------------------------
sl@0	2113	*
sl@0	2114	* InfoTclVersionCmd --
sl@0	2115	*
sl@0	2116	* Called to implement the "info tclversion" command that returns the
sl@0	2117	* version number for this Tcl library. Handles the following syntax:
sl@0	2118	*
sl@0	2119	* info tclversion
sl@0	2120	*
sl@0	2121	* Results:
sl@0	2122	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	2123	*
sl@0	2124	* Side effects:
sl@0	2125	* Returns a result in the interpreter's result object. If there is
sl@0	2126	* an error, the result is an error message.
sl@0	2127	*
sl@0	2128	*----------------------------------------------------------------------
sl@0	2129	*/
sl@0	2130
sl@0	2131	static int
sl@0	2132	InfoTclVersionCmd(dummy, interp, objc, objv)
sl@0	2133	ClientData dummy; /* Not used. */
sl@0	2134	Tcl_Interp interp; / Current interpreter. */
sl@0	2135	int objc; /* Number of arguments. */
sl@0	2136	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2137	{
sl@0	2138	CONST char *version;
sl@0	2139
sl@0	2140	if (objc != 2) {
sl@0	2141	Tcl_WrongNumArgs(interp, 2, objv, NULL);
sl@0	2142	return TCL_ERROR;
sl@0	2143	}
sl@0	2144
sl@0	2145	version = Tcl_GetVar(interp, "tcl_version",
sl@0	2146	(TCL_GLOBAL_ONLY \| TCL_LEAVE_ERR_MSG));
sl@0	2147	if (version != NULL) {
sl@0	2148	Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1);
sl@0	2149	return TCL_OK;
sl@0	2150	}
sl@0	2151	return TCL_ERROR;
sl@0	2152	}
sl@0	2153
sl@0	2154	/*
sl@0	2155	*----------------------------------------------------------------------
sl@0	2156	*
sl@0	2157	* InfoVarsCmd --
sl@0	2158	*
sl@0	2159	* Called to implement the "info vars" command that returns the
sl@0	2160	* list of variables in the interpreter that match an optional pattern.
sl@0	2161	* The pattern, if any, consists of an optional sequence of namespace
sl@0	2162	* names separated by "::" qualifiers, which is followed by a
sl@0	2163	* glob-style pattern that restricts which variables are returned.
sl@0	2164	* Handles the following syntax:
sl@0	2165	*
sl@0	2166	* info vars ?pattern?
sl@0	2167	*
sl@0	2168	* Results:
sl@0	2169	* Returns TCL_OK if successful and TCL_ERROR if there is an error.
sl@0	2170	*
sl@0	2171	* Side effects:
sl@0	2172	* Returns a result in the interpreter's result object. If there is
sl@0	2173	* an error, the result is an error message.
sl@0	2174	*
sl@0	2175	*----------------------------------------------------------------------
sl@0	2176	*/
sl@0	2177
sl@0	2178	static int
sl@0	2179	InfoVarsCmd(dummy, interp, objc, objv)
sl@0	2180	ClientData dummy; /* Not used. */
sl@0	2181	Tcl_Interp interp; / Current interpreter. */
sl@0	2182	int objc; /* Number of arguments. */
sl@0	2183	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2184	{
sl@0	2185	Interp iPtr = (Interp ) interp;
sl@0	2186	char varName, pattern;
sl@0	2187	CONST char *simplePattern;
sl@0	2188	register Tcl_HashEntry *entryPtr;
sl@0	2189	Tcl_HashSearch search;
sl@0	2190	Var *varPtr;
sl@0	2191	Namespace *nsPtr;
sl@0	2192	Namespace globalNsPtr = (Namespace ) Tcl_GetGlobalNamespace(interp);
sl@0	2193	Namespace currNsPtr = (Namespace ) Tcl_GetCurrentNamespace(interp);
sl@0	2194	Tcl_Obj listPtr, elemObjPtr;
sl@0	2195	int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
sl@0	2196
sl@0	2197	/*
sl@0	2198	* Get the pattern and find the "effective namespace" in which to
sl@0	2199	* list variables. We only use this effective namespace if there's
sl@0	2200	* no active Tcl procedure frame.
sl@0	2201	*/
sl@0	2202
sl@0	2203	if (objc == 2) {
sl@0	2204	simplePattern = NULL;
sl@0	2205	nsPtr = currNsPtr;
sl@0	2206	specificNsInPattern = 0;
sl@0	2207	} else if (objc == 3) {
sl@0	2208	/*
sl@0	2209	* From the pattern, get the effective namespace and the simple
sl@0	2210	* pattern (no namespace qualifiers or ::'s) at the end. If an
sl@0	2211	* error was found while parsing the pattern, return it. Otherwise,
sl@0	2212	* if the namespace wasn't found, just leave nsPtr NULL: we will
sl@0	2213	* return an empty list since no variables there can be found.
sl@0	2214	*/
sl@0	2215
sl@0	2216	Namespace dummy1NsPtr, dummy2NsPtr;
sl@0	2217
sl@0	2218	pattern = Tcl_GetString(objv[2]);
sl@0	2219	TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
sl@0	2220	/flags/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
sl@0	2221	&simplePattern);
sl@0	2222
sl@0	2223	if (nsPtr != NULL) { /* we successfully found the pattern's ns */
sl@0	2224	specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
sl@0	2225	}
sl@0	2226	} else {
sl@0	2227	Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
sl@0	2228	return TCL_ERROR;
sl@0	2229	}
sl@0	2230
sl@0	2231	/*
sl@0	2232	* If the namespace specified in the pattern wasn't found, just return.
sl@0	2233	*/
sl@0	2234
sl@0	2235	if (nsPtr == NULL) {
sl@0	2236	return TCL_OK;
sl@0	2237	}
sl@0	2238
sl@0	2239	listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	2240
sl@0	2241	if ((iPtr->varFramePtr == NULL)
sl@0	2242	\|\| !iPtr->varFramePtr->isProcCallFrame
sl@0	2243	\|\| specificNsInPattern) {
sl@0	2244	/*
sl@0	2245	* There is no frame pointer, the frame pointer was pushed only
sl@0	2246	* to activate a namespace, or we are in a procedure call frame
sl@0	2247	* but a specific namespace was specified. Create a list containing
sl@0	2248	* only the variables in the effective namespace's variable table.
sl@0	2249	*/
sl@0	2250
sl@0	2251	if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
sl@0	2252	/*
sl@0	2253	* If we can just do hash lookups, that simplifies things
sl@0	2254	* a lot.
sl@0	2255	*/
sl@0	2256
sl@0	2257	entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern);
sl@0	2258	if (entryPtr != NULL) {
sl@0	2259	varPtr = (Var *) Tcl_GetHashValue(entryPtr);
sl@0	2260	if (!TclIsVarUndefined(varPtr)
sl@0	2261	\|\| (varPtr->flags & VAR_NAMESPACE_VAR)) {
sl@0	2262	if (specificNsInPattern) {
sl@0	2263	elemObjPtr = Tcl_NewObj();
sl@0	2264	Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
sl@0	2265	elemObjPtr);
sl@0	2266	} else {
sl@0	2267	elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
sl@0	2268	}
sl@0	2269	Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
sl@0	2270	}
sl@0	2271	} else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
sl@0	2272	entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable,
sl@0	2273	simplePattern);
sl@0	2274	if (entryPtr != NULL) {
sl@0	2275	varPtr = (Var *) Tcl_GetHashValue(entryPtr);
sl@0	2276	if (!TclIsVarUndefined(varPtr)
sl@0	2277	\|\| (varPtr->flags & VAR_NAMESPACE_VAR)) {
sl@0	2278	Tcl_ListObjAppendElement(interp, listPtr,
sl@0	2279	Tcl_NewStringObj(simplePattern, -1));
sl@0	2280	}
sl@0	2281	}
sl@0	2282	}
sl@0	2283	} else {
sl@0	2284	/*
sl@0	2285	* Have to scan the tables of variables.
sl@0	2286	*/
sl@0	2287
sl@0	2288	entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
sl@0	2289	while (entryPtr != NULL) {
sl@0	2290	varPtr = (Var *) Tcl_GetHashValue(entryPtr);
sl@0	2291	if (!TclIsVarUndefined(varPtr)
sl@0	2292	\|\| (varPtr->flags & VAR_NAMESPACE_VAR)) {
sl@0	2293	varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
sl@0	2294	if ((simplePattern == NULL)
sl@0	2295	\|\| Tcl_StringMatch(varName, simplePattern)) {
sl@0	2296	if (specificNsInPattern) {
sl@0	2297	elemObjPtr = Tcl_NewObj();
sl@0	2298	Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
sl@0	2299	elemObjPtr);
sl@0	2300	} else {
sl@0	2301	elemObjPtr = Tcl_NewStringObj(varName, -1);
sl@0	2302	}
sl@0	2303	Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
sl@0	2304	}
sl@0	2305	}
sl@0	2306	entryPtr = Tcl_NextHashEntry(&search);
sl@0	2307	}
sl@0	2308
sl@0	2309	/*
sl@0	2310	* If the effective namespace isn't the global ::
sl@0	2311	* namespace, and a specific namespace wasn't requested in
sl@0	2312	* the pattern (i.e., the pattern only specifies variable
sl@0	2313	* names), then add in all global :: variables that match
sl@0	2314	* the simple pattern. Of course, add in only those
sl@0	2315	* variables that aren't hidden by a variable in the
sl@0	2316	* effective namespace.
sl@0	2317	*/
sl@0	2318
sl@0	2319	if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
sl@0	2320	entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
sl@0	2321	while (entryPtr != NULL) {
sl@0	2322	varPtr = (Var *) Tcl_GetHashValue(entryPtr);
sl@0	2323	if (!TclIsVarUndefined(varPtr)
sl@0	2324	\|\| (varPtr->flags & VAR_NAMESPACE_VAR)) {
sl@0	2325	varName = Tcl_GetHashKey(&globalNsPtr->varTable,
sl@0	2326	entryPtr);
sl@0	2327	if ((simplePattern == NULL)
sl@0	2328	\|\| Tcl_StringMatch(varName, simplePattern)) {
sl@0	2329	if (Tcl_FindHashEntry(&nsPtr->varTable,
sl@0	2330	varName) == NULL) {
sl@0	2331	Tcl_ListObjAppendElement(interp, listPtr,
sl@0	2332	Tcl_NewStringObj(varName, -1));
sl@0	2333	}
sl@0	2334	}
sl@0	2335	}
sl@0	2336	entryPtr = Tcl_NextHashEntry(&search);
sl@0	2337	}
sl@0	2338	}
sl@0	2339	}
sl@0	2340	} else if (((Interp *)interp)->varFramePtr->procPtr != NULL) {
sl@0	2341	AppendLocals(interp, listPtr, simplePattern, 1);
sl@0	2342	}
sl@0	2343
sl@0	2344	Tcl_SetObjResult(interp, listPtr);
sl@0	2345	return TCL_OK;
sl@0	2346	}
sl@0	2347
sl@0	2348	/*
sl@0	2349	*----------------------------------------------------------------------
sl@0	2350	*
sl@0	2351	* Tcl_JoinObjCmd --
sl@0	2352	*
sl@0	2353	* This procedure is invoked to process the "join" Tcl command.
sl@0	2354	* See the user documentation for details on what it does.
sl@0	2355	*
sl@0	2356	* Results:
sl@0	2357	* A standard Tcl object result.
sl@0	2358	*
sl@0	2359	* Side effects:
sl@0	2360	* See the user documentation.
sl@0	2361	*
sl@0	2362	*----------------------------------------------------------------------
sl@0	2363	*/
sl@0	2364
sl@0	2365	/* ARGSUSED */
sl@0	2366	int
sl@0	2367	Tcl_JoinObjCmd(dummy, interp, objc, objv)
sl@0	2368	ClientData dummy; /* Not used. */
sl@0	2369	Tcl_Interp interp; / Current interpreter. */
sl@0	2370	int objc; /* Number of arguments. */
sl@0	2371	Tcl_Obj CONST objv[]; / The argument objects. */
sl@0	2372	{
sl@0	2373	char joinString, bytes;
sl@0	2374	int joinLength, listLen, length, i, result;
sl@0	2375	Tcl_Obj **elemPtrs;
sl@0	2376	Tcl_Obj *resObjPtr;
sl@0	2377
sl@0	2378	if (objc == 2) {
sl@0	2379	joinString = " ";
sl@0	2380	joinLength = 1;
sl@0	2381	} else if (objc == 3) {
sl@0	2382	joinString = Tcl_GetStringFromObj(objv[2], &joinLength);
sl@0	2383	} else {
sl@0	2384	Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
sl@0	2385	return TCL_ERROR;
sl@0	2386	}
sl@0	2387
sl@0	2388	/*
sl@0	2389	* Make sure the list argument is a list object and get its length and
sl@0	2390	* a pointer to its array of element pointers.
sl@0	2391	*/
sl@0	2392
sl@0	2393	result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
sl@0	2394	if (result != TCL_OK) {
sl@0	2395	return result;
sl@0	2396	}
sl@0	2397
sl@0	2398	/*
sl@0	2399	* Now concatenate strings to form the "joined" result. We append
sl@0	2400	* directly into the interpreter's result object.
sl@0	2401	*/
sl@0	2402
sl@0	2403	resObjPtr = Tcl_GetObjResult(interp);
sl@0	2404
sl@0	2405	for (i = 0; i < listLen; i++) {
sl@0	2406	bytes = Tcl_GetStringFromObj(elemPtrs[i], &length);
sl@0	2407	if (i > 0) {
sl@0	2408	Tcl_AppendToObj(resObjPtr, joinString, joinLength);
sl@0	2409	}
sl@0	2410	Tcl_AppendToObj(resObjPtr, bytes, length);
sl@0	2411	}
sl@0	2412	return TCL_OK;
sl@0	2413	}
sl@0	2414
sl@0	2415	/*
sl@0	2416	*----------------------------------------------------------------------
sl@0	2417	*
sl@0	2418	* Tcl_LindexObjCmd --
sl@0	2419	*
sl@0	2420	* This object-based procedure is invoked to process the "lindex" Tcl
sl@0	2421	* command. See the user documentation for details on what it does.
sl@0	2422	*
sl@0	2423	* Results:
sl@0	2424	* A standard Tcl object result.
sl@0	2425	*
sl@0	2426	* Side effects:
sl@0	2427	* See the user documentation.
sl@0	2428	*
sl@0	2429	*----------------------------------------------------------------------
sl@0	2430	*/
sl@0	2431
sl@0	2432	/* ARGSUSED */
sl@0	2433	int
sl@0	2434	Tcl_LindexObjCmd(dummy, interp, objc, objv)
sl@0	2435	ClientData dummy; /* Not used. */
sl@0	2436	Tcl_Interp interp; / Current interpreter. */
sl@0	2437	int objc; /* Number of arguments. */
sl@0	2438	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2439	{
sl@0	2440
sl@0	2441	Tcl_Obj elemPtr; / Pointer to the element being extracted */
sl@0	2442
sl@0	2443	if (objc < 2) {
sl@0	2444	Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?");
sl@0	2445	return TCL_ERROR;
sl@0	2446	}
sl@0	2447
sl@0	2448	/*
sl@0	2449	* If objc == 3, then objv[ 2 ] may be either a single index or
sl@0	2450	* a list of indices: go to TclLindexList to determine which.
sl@0	2451	* If objc >= 4, or objc == 2, then objv[ 2 .. objc-2 ] are all
sl@0	2452	* single indices and processed as such in TclLindexFlat.
sl@0	2453	*/
sl@0	2454
sl@0	2455	if ( objc == 3 ) {
sl@0	2456
sl@0	2457	elemPtr = TclLindexList( interp, objv[ 1 ], objv[ 2 ] );
sl@0	2458
sl@0	2459	} else {
sl@0	2460
sl@0	2461	elemPtr = TclLindexFlat( interp, objv[ 1 ], objc-2, objv+2 );
sl@0	2462
sl@0	2463	}
sl@0	2464
sl@0	2465	/*
sl@0	2466	* Set the interpreter's object result to the last element extracted
sl@0	2467	*/
sl@0	2468
sl@0	2469	if ( elemPtr == NULL ) {
sl@0	2470	return TCL_ERROR;
sl@0	2471	} else {
sl@0	2472	Tcl_SetObjResult(interp, elemPtr);
sl@0	2473	Tcl_DecrRefCount( elemPtr );
sl@0	2474	return TCL_OK;
sl@0	2475	}
sl@0	2476	}
sl@0	2477
sl@0	2478	/*
sl@0	2479	*----------------------------------------------------------------------
sl@0	2480	*
sl@0	2481	* TclLindexList --
sl@0	2482	*
sl@0	2483	* This procedure handles the 'lindex' command when objc==3.
sl@0	2484	*
sl@0	2485	* Results:
sl@0	2486	* Returns a pointer to the object extracted, or NULL if an
sl@0	2487	* error occurred.
sl@0	2488	*
sl@0	2489	* Side effects:
sl@0	2490	* None.
sl@0	2491	*
sl@0	2492	* If objv[1] can be parsed as a list, TclLindexList handles extraction
sl@0	2493	* of the desired element locally. Otherwise, it invokes
sl@0	2494	* TclLindexFlat to treat objv[1] as a scalar.
sl@0	2495	*
sl@0	2496	* The reference count of the returned object includes one reference
sl@0	2497	* corresponding to the pointer returned. Thus, the calling code will
sl@0	2498	* usually do something like:
sl@0	2499	* Tcl_SetObjResult( interp, result );
sl@0	2500	* Tcl_DecrRefCount( result );
sl@0	2501	*
sl@0	2502	*----------------------------------------------------------------------
sl@0	2503	*/
sl@0	2504
sl@0	2505	Tcl_Obj *
sl@0	2506	TclLindexList( interp, listPtr, argPtr )
sl@0	2507	Tcl_Interp* interp; /* Tcl interpreter */
sl@0	2508	Tcl_Obj* listPtr; /* List being unpacked */
sl@0	2509	Tcl_Obj* argPtr; /* Index or index list */
sl@0	2510	{
sl@0	2511
sl@0	2512	Tcl_Obj *elemPtrs; / Elements of the list being manipulated. */
sl@0	2513	int listLen; /* Length of the list being manipulated. */
sl@0	2514	int index; /* Index into the list */
sl@0	2515	int result; /* Result returned from a Tcl library call */
sl@0	2516	int i; /* Current index number */
sl@0	2517	Tcl_Obj** indices; /* Array of list indices */
sl@0	2518	int indexCount; /* Size of the array of list indices */
sl@0	2519	Tcl_Obj* oldListPtr; /* Temp location to preserve the list
sl@0	2520	* pointer when replacing it with a sublist */
sl@0	2521
sl@0	2522	/*
sl@0	2523	* Determine whether argPtr designates a list or a single index.
sl@0	2524	* We have to be careful about the order of the checks to avoid
sl@0	2525	* repeated shimmering; see TIP#22 and TIP#33 for the details.
sl@0	2526	*/
sl@0	2527
sl@0	2528	if ( argPtr->typePtr != &tclListType
sl@0	2529	&& TclGetIntForIndex( NULL , argPtr, 0, &index ) == TCL_OK ) {
sl@0	2530
sl@0	2531	/*
sl@0	2532	* argPtr designates a single index.
sl@0	2533	*/
sl@0	2534
sl@0	2535	return TclLindexFlat( interp, listPtr, 1, &argPtr );
sl@0	2536
sl@0	2537	} else if ( Tcl_ListObjGetElements( NULL, argPtr, &indexCount, &indices )
sl@0	2538	!= TCL_OK ) {
sl@0	2539
sl@0	2540	/*
sl@0	2541	* argPtr designates something that is neither an index nor a
sl@0	2542	* well-formed list. Report the error via TclLindexFlat.
sl@0	2543	*/
sl@0	2544
sl@0	2545	return TclLindexFlat( interp, listPtr, 1, &argPtr );
sl@0	2546	}
sl@0	2547
sl@0	2548	/*
sl@0	2549	* Record the reference to the list that we are maintaining in
sl@0	2550	* the activation record.
sl@0	2551	*/
sl@0	2552
sl@0	2553	Tcl_IncrRefCount( listPtr );
sl@0	2554
sl@0	2555	/*
sl@0	2556	* argPtr designates a list, and the 'else if' above has parsed it
sl@0	2557	* into indexCount and indices.
sl@0	2558	*/
sl@0	2559
sl@0	2560	for ( i = 0; i < indexCount; ++i ) {
sl@0	2561
sl@0	2562	/*
sl@0	2563	* Convert the current listPtr to a list if necessary.
sl@0	2564	*/
sl@0	2565
sl@0	2566	result = Tcl_ListObjGetElements( interp, listPtr,
sl@0	2567	&listLen, &elemPtrs);
sl@0	2568	if (result != TCL_OK) {
sl@0	2569	Tcl_DecrRefCount( listPtr );
sl@0	2570	return NULL;
sl@0	2571	}
sl@0	2572
sl@0	2573	/*
sl@0	2574	* Get the index from indices[ i ]
sl@0	2575	*/
sl@0	2576
sl@0	2577	result = TclGetIntForIndex( interp, indices[ i ],
sl@0	2578	/endValue/ (listLen - 1),
sl@0	2579	&index );
sl@0	2580	if ( result != TCL_OK ) {
sl@0	2581	/*
sl@0	2582	* Index could not be parsed
sl@0	2583	*/
sl@0	2584
sl@0	2585	Tcl_DecrRefCount( listPtr );
sl@0	2586	return NULL;
sl@0	2587
sl@0	2588	} else if ( index < 0
sl@0	2589	\|\| index >= listLen ) {
sl@0	2590	/*
sl@0	2591	* Index is out of range
sl@0	2592	*/
sl@0	2593	Tcl_DecrRefCount( listPtr );
sl@0	2594	listPtr = Tcl_NewObj();
sl@0	2595	Tcl_IncrRefCount( listPtr );
sl@0	2596	return listPtr;
sl@0	2597	}
sl@0	2598
sl@0	2599	/*
sl@0	2600	* Make sure listPtr still refers to a list object.
sl@0	2601	* If it shared a Tcl_Obj structure with the arguments, then
sl@0	2602	* it might have just been converted to something else.
sl@0	2603	*/
sl@0	2604
sl@0	2605	if (listPtr->typePtr != &tclListType) {
sl@0	2606	result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
sl@0	2607	&elemPtrs);
sl@0	2608	if (result != TCL_OK) {
sl@0	2609	Tcl_DecrRefCount( listPtr );
sl@0	2610	return NULL;
sl@0	2611	}
sl@0	2612	}
sl@0	2613
sl@0	2614	/*
sl@0	2615	* Extract the pointer to the appropriate element
sl@0	2616	*/
sl@0	2617
sl@0	2618	oldListPtr = listPtr;
sl@0	2619	listPtr = elemPtrs[ index ];
sl@0	2620	Tcl_IncrRefCount( listPtr );
sl@0	2621	Tcl_DecrRefCount( oldListPtr );
sl@0	2622
sl@0	2623	/*
sl@0	2624	* The work we did above may have caused the internal rep
sl@0	2625	* of *argPtr to change to something else. Get it back.
sl@0	2626	*/
sl@0	2627
sl@0	2628	result = Tcl_ListObjGetElements( interp, argPtr,
sl@0	2629	&indexCount, &indices );
sl@0	2630	if ( result != TCL_OK ) {
sl@0	2631	/*
sl@0	2632	* This can't happen unless some extension corrupted a Tcl_Obj.
sl@0	2633	*/
sl@0	2634	Tcl_DecrRefCount( listPtr );
sl@0	2635	return NULL;
sl@0	2636	}
sl@0	2637
sl@0	2638	} /* end for */
sl@0	2639
sl@0	2640	/*
sl@0	2641	* Return the last object extracted. Its reference count will include
sl@0	2642	* the reference being returned.
sl@0	2643	*/
sl@0	2644
sl@0	2645	return listPtr;
sl@0	2646	}
sl@0	2647
sl@0	2648	/*
sl@0	2649	*----------------------------------------------------------------------
sl@0	2650	*
sl@0	2651	* TclLindexFlat --
sl@0	2652	*
sl@0	2653	* This procedure handles the 'lindex' command, given that the
sl@0	2654	* arguments to the command are known to be a flat list.
sl@0	2655	*
sl@0	2656	* Results:
sl@0	2657	* Returns a standard Tcl result.
sl@0	2658	*
sl@0	2659	* Side effects:
sl@0	2660	* None.
sl@0	2661	*
sl@0	2662	* This procedure is called from either tclExecute.c or
sl@0	2663	* Tcl_LindexObjCmd whenever either is presented with
sl@0	2664	* objc == 2 or objc >= 4. It is also called from TclLindexList
sl@0	2665	* for the objc==3 case once it is determined that objv[2] cannot
sl@0	2666	* be parsed as a list.
sl@0	2667	*
sl@0	2668	*----------------------------------------------------------------------
sl@0	2669	*/
sl@0	2670
sl@0	2671	Tcl_Obj *
sl@0	2672	TclLindexFlat( interp, listPtr, indexCount, indexArray )
sl@0	2673	Tcl_Interp* interp; /* Tcl interpreter */
sl@0	2674	Tcl_Obj* listPtr; /* Tcl object representing the list */
sl@0	2675	int indexCount; /* Count of indices */
sl@0	2676	Tcl_Obj* CONST indexArray[];
sl@0	2677	/* Array of pointers to Tcl objects
sl@0	2678	* representing the indices in the
sl@0	2679	* list */
sl@0	2680	{
sl@0	2681
sl@0	2682	int i; /* Current list index */
sl@0	2683	int result; /* Result of Tcl library calls */
sl@0	2684	int listLen; /* Length of the current list being
sl@0	2685	* processed */
sl@0	2686	Tcl_Obj** elemPtrs; /* Array of pointers to the elements
sl@0	2687	* of the current list */
sl@0	2688	int index; /* Parsed version of the current element
sl@0	2689	* of indexArray */
sl@0	2690	Tcl_Obj* oldListPtr; /* Temporary to hold listPtr so that
sl@0	2691	* its ref count can be decremented. */
sl@0	2692
sl@0	2693	/*
sl@0	2694	* Record the reference to the 'listPtr' object that we are
sl@0	2695	* maintaining in the C activation record.
sl@0	2696	*/
sl@0	2697
sl@0	2698	Tcl_IncrRefCount( listPtr );
sl@0	2699
sl@0	2700	for ( i = 0; i < indexCount; ++i ) {
sl@0	2701
sl@0	2702	/*
sl@0	2703	* Convert the current listPtr to a list if necessary.
sl@0	2704	*/
sl@0	2705
sl@0	2706	result = Tcl_ListObjGetElements(interp, listPtr,
sl@0	2707	&listLen, &elemPtrs);
sl@0	2708	if (result != TCL_OK) {
sl@0	2709	Tcl_DecrRefCount( listPtr );
sl@0	2710	return NULL;
sl@0	2711	}
sl@0	2712
sl@0	2713	/*
sl@0	2714	* Get the index from objv[i]
sl@0	2715	*/
sl@0	2716
sl@0	2717	result = TclGetIntForIndex( interp, indexArray[ i ],
sl@0	2718	/endValue/ (listLen - 1),
sl@0	2719	&index );
sl@0	2720	if ( result != TCL_OK ) {
sl@0	2721
sl@0	2722	/* Index could not be parsed */
sl@0	2723
sl@0	2724	Tcl_DecrRefCount( listPtr );
sl@0	2725	return NULL;
sl@0	2726
sl@0	2727	} else if ( index < 0
sl@0	2728	\|\| index >= listLen ) {
sl@0	2729
sl@0	2730	/*
sl@0	2731	* Index is out of range
sl@0	2732	*/
sl@0	2733
sl@0	2734	Tcl_DecrRefCount( listPtr );
sl@0	2735	listPtr = Tcl_NewObj();
sl@0	2736	Tcl_IncrRefCount( listPtr );
sl@0	2737	return listPtr;
sl@0	2738	}
sl@0	2739
sl@0	2740	/*
sl@0	2741	* Make sure listPtr still refers to a list object.
sl@0	2742	* It might have been converted to something else above
sl@0	2743	* if objv[1] overlaps with one of the other parameters.
sl@0	2744	*/
sl@0	2745
sl@0	2746	if (listPtr->typePtr != &tclListType) {
sl@0	2747	result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
sl@0	2748	&elemPtrs);
sl@0	2749	if (result != TCL_OK) {
sl@0	2750	Tcl_DecrRefCount( listPtr );
sl@0	2751	return NULL;
sl@0	2752	}
sl@0	2753	}
sl@0	2754
sl@0	2755	/*
sl@0	2756	* Extract the pointer to the appropriate element
sl@0	2757	*/
sl@0	2758
sl@0	2759	oldListPtr = listPtr;
sl@0	2760	listPtr = elemPtrs[ index ];
sl@0	2761	Tcl_IncrRefCount( listPtr );
sl@0	2762	Tcl_DecrRefCount( oldListPtr );
sl@0	2763
sl@0	2764	}
sl@0	2765
sl@0	2766	return listPtr;
sl@0	2767
sl@0	2768	}
sl@0	2769
sl@0	2770	/*
sl@0	2771	*----------------------------------------------------------------------
sl@0	2772	*
sl@0	2773	* Tcl_LinsertObjCmd --
sl@0	2774	*
sl@0	2775	* This object-based procedure is invoked to process the "linsert" Tcl
sl@0	2776	* command. See the user documentation for details on what it does.
sl@0	2777	*
sl@0	2778	* Results:
sl@0	2779	* A new Tcl list object formed by inserting zero or more elements
sl@0	2780	* into a list.
sl@0	2781	*
sl@0	2782	* Side effects:
sl@0	2783	* See the user documentation.
sl@0	2784	*
sl@0	2785	*----------------------------------------------------------------------
sl@0	2786	*/
sl@0	2787
sl@0	2788	/* ARGSUSED */
sl@0	2789	int
sl@0	2790	Tcl_LinsertObjCmd(dummy, interp, objc, objv)
sl@0	2791	ClientData dummy; /* Not used. */
sl@0	2792	Tcl_Interp interp; / Current interpreter. */
sl@0	2793	register int objc; /* Number of arguments. */
sl@0	2794	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2795	{
sl@0	2796	Tcl_Obj *listPtr;
sl@0	2797	int index, isDuplicate, len, result;
sl@0	2798
sl@0	2799	if (objc < 4) {
sl@0	2800	Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
sl@0	2801	return TCL_ERROR;
sl@0	2802	}
sl@0	2803
sl@0	2804	result = Tcl_ListObjLength(interp, objv[1], &len);
sl@0	2805	if (result != TCL_OK) {
sl@0	2806	return result;
sl@0	2807	}
sl@0	2808
sl@0	2809	/*
sl@0	2810	* Get the index. "end" is interpreted to be the index after the last
sl@0	2811	* element, such that using it will cause any inserted elements to be
sl@0	2812	* appended to the list.
sl@0	2813	*/
sl@0	2814
sl@0	2815	result = TclGetIntForIndex(interp, objv[2], /end/ len, &index);
sl@0	2816	if (result != TCL_OK) {
sl@0	2817	return result;
sl@0	2818	}
sl@0	2819	if (index > len) {
sl@0	2820	index = len;
sl@0	2821	}
sl@0	2822
sl@0	2823	/*
sl@0	2824	* If the list object is unshared we can modify it directly. Otherwise
sl@0	2825	* we create a copy to modify: this is "copy on write".
sl@0	2826	*/
sl@0	2827
sl@0	2828	listPtr = objv[1];
sl@0	2829	isDuplicate = 0;
sl@0	2830	if (Tcl_IsShared(listPtr)) {
sl@0	2831	listPtr = Tcl_DuplicateObj(listPtr);
sl@0	2832	isDuplicate = 1;
sl@0	2833	}
sl@0	2834
sl@0	2835	if ((objc == 4) && (index == len)) {
sl@0	2836	/*
sl@0	2837	* Special case: insert one element at the end of the list.
sl@0	2838	*/
sl@0	2839	result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]);
sl@0	2840	} else if (objc > 3) {
sl@0	2841	result = Tcl_ListObjReplace(interp, listPtr, index, 0,
sl@0	2842	(objc-3), &(objv[3]));
sl@0	2843	}
sl@0	2844	if (result != TCL_OK) {
sl@0	2845	if (isDuplicate) {
sl@0	2846	Tcl_DecrRefCount(listPtr); /* free unneeded obj */
sl@0	2847	}
sl@0	2848	return result;
sl@0	2849	}
sl@0	2850
sl@0	2851	/*
sl@0	2852	* Set the interpreter's object result.
sl@0	2853	*/
sl@0	2854
sl@0	2855	Tcl_SetObjResult(interp, listPtr);
sl@0	2856	return TCL_OK;
sl@0	2857	}
sl@0	2858
sl@0	2859	/*
sl@0	2860	*----------------------------------------------------------------------
sl@0	2861	*
sl@0	2862	* Tcl_ListObjCmd --
sl@0	2863	*
sl@0	2864	* This procedure is invoked to process the "list" Tcl command.
sl@0	2865	* See the user documentation for details on what it does.
sl@0	2866	*
sl@0	2867	* Results:
sl@0	2868	* A standard Tcl object result.
sl@0	2869	*
sl@0	2870	* Side effects:
sl@0	2871	* See the user documentation.
sl@0	2872	*
sl@0	2873	*----------------------------------------------------------------------
sl@0	2874	*/
sl@0	2875
sl@0	2876	/* ARGSUSED */
sl@0	2877	int
sl@0	2878	Tcl_ListObjCmd(dummy, interp, objc, objv)
sl@0	2879	ClientData dummy; /* Not used. */
sl@0	2880	Tcl_Interp interp; / Current interpreter. */
sl@0	2881	register int objc; /* Number of arguments. */
sl@0	2882	register Tcl_Obj CONST objv[]; / The argument objects. */
sl@0	2883	{
sl@0	2884	/*
sl@0	2885	* If there are no list elements, the result is an empty object.
sl@0	2886	* Otherwise modify the interpreter's result object to be a list object.
sl@0	2887	*/
sl@0	2888
sl@0	2889	if (objc > 1) {
sl@0	2890	Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1]));
sl@0	2891	}
sl@0	2892	return TCL_OK;
sl@0	2893	}
sl@0	2894
sl@0	2895	/*
sl@0	2896	*----------------------------------------------------------------------
sl@0	2897	*
sl@0	2898	* Tcl_LlengthObjCmd --
sl@0	2899	*
sl@0	2900	* This object-based procedure is invoked to process the "llength" Tcl
sl@0	2901	* command. See the user documentation for details on what it does.
sl@0	2902	*
sl@0	2903	* Results:
sl@0	2904	* A standard Tcl object result.
sl@0	2905	*
sl@0	2906	* Side effects:
sl@0	2907	* See the user documentation.
sl@0	2908	*
sl@0	2909	*----------------------------------------------------------------------
sl@0	2910	*/
sl@0	2911
sl@0	2912	/* ARGSUSED */
sl@0	2913	int
sl@0	2914	Tcl_LlengthObjCmd(dummy, interp, objc, objv)
sl@0	2915	ClientData dummy; /* Not used. */
sl@0	2916	Tcl_Interp interp; / Current interpreter. */
sl@0	2917	int objc; /* Number of arguments. */
sl@0	2918	register Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2919	{
sl@0	2920	int listLen, result;
sl@0	2921
sl@0	2922	if (objc != 2) {
sl@0	2923	Tcl_WrongNumArgs(interp, 1, objv, "list");
sl@0	2924	return TCL_ERROR;
sl@0	2925	}
sl@0	2926
sl@0	2927	result = Tcl_ListObjLength(interp, objv[1], &listLen);
sl@0	2928	if (result != TCL_OK) {
sl@0	2929	return result;
sl@0	2930	}
sl@0	2931
sl@0	2932	/*
sl@0	2933	* Set the interpreter's object result to an integer object holding the
sl@0	2934	* length.
sl@0	2935	*/
sl@0	2936
sl@0	2937	Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen);
sl@0	2938	return TCL_OK;
sl@0	2939	}
sl@0	2940
sl@0	2941	/*
sl@0	2942	*----------------------------------------------------------------------
sl@0	2943	*
sl@0	2944	* Tcl_LrangeObjCmd --
sl@0	2945	*
sl@0	2946	* This procedure is invoked to process the "lrange" Tcl command.
sl@0	2947	* See the user documentation for details on what it does.
sl@0	2948	*
sl@0	2949	* Results:
sl@0	2950	* A standard Tcl object result.
sl@0	2951	*
sl@0	2952	* Side effects:
sl@0	2953	* See the user documentation.
sl@0	2954	*
sl@0	2955	*----------------------------------------------------------------------
sl@0	2956	*/
sl@0	2957
sl@0	2958	/* ARGSUSED */
sl@0	2959	int
sl@0	2960	Tcl_LrangeObjCmd(notUsed, interp, objc, objv)
sl@0	2961	ClientData notUsed; /* Not used. */
sl@0	2962	Tcl_Interp interp; / Current interpreter. */
sl@0	2963	int objc; /* Number of arguments. */
sl@0	2964	register Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	2965	{
sl@0	2966	Tcl_Obj *listPtr;
sl@0	2967	Tcl_Obj **elemPtrs;
sl@0	2968	int listLen, first, last, numElems, result;
sl@0	2969
sl@0	2970	if (objc != 4) {
sl@0	2971	Tcl_WrongNumArgs(interp, 1, objv, "list first last");
sl@0	2972	return TCL_ERROR;
sl@0	2973	}
sl@0	2974
sl@0	2975	/*
sl@0	2976	* Make sure the list argument is a list object and get its length and
sl@0	2977	* a pointer to its array of element pointers.
sl@0	2978	*/
sl@0	2979
sl@0	2980	listPtr = objv[1];
sl@0	2981	result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
sl@0	2982	if (result != TCL_OK) {
sl@0	2983	return result;
sl@0	2984	}
sl@0	2985
sl@0	2986	/*
sl@0	2987	* Get the first and last indexes.
sl@0	2988	*/
sl@0	2989
sl@0	2990	result = TclGetIntForIndex(interp, objv[2], /endValue/ (listLen - 1),
sl@0	2991	&first);
sl@0	2992	if (result != TCL_OK) {
sl@0	2993	return result;
sl@0	2994	}
sl@0	2995	if (first < 0) {
sl@0	2996	first = 0;
sl@0	2997	}
sl@0	2998
sl@0	2999	result = TclGetIntForIndex(interp, objv[3], /endValue/ (listLen - 1),
sl@0	3000	&last);
sl@0	3001	if (result != TCL_OK) {
sl@0	3002	return result;
sl@0	3003	}
sl@0	3004	if (last >= listLen) {
sl@0	3005	last = (listLen - 1);
sl@0	3006	}
sl@0	3007
sl@0	3008	if (first > last) {
sl@0	3009	return TCL_OK; /* the result is an empty object */
sl@0	3010	}
sl@0	3011
sl@0	3012	/*
sl@0	3013	* Make sure listPtr still refers to a list object. It might have been
sl@0	3014	* converted to an int above if the argument objects were shared.
sl@0	3015	*/
sl@0	3016
sl@0	3017	if (listPtr->typePtr != &tclListType) {
sl@0	3018	result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
sl@0	3019	&elemPtrs);
sl@0	3020	if (result != TCL_OK) {
sl@0	3021	return result;
sl@0	3022	}
sl@0	3023	}
sl@0	3024
sl@0	3025	/*
sl@0	3026	* Extract a range of fields. We modify the interpreter's result object
sl@0	3027	* to be a list object containing the specified elements.
sl@0	3028	*/
sl@0	3029
sl@0	3030	numElems = (last - first + 1);
sl@0	3031	Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first]));
sl@0	3032	return TCL_OK;
sl@0	3033	}
sl@0	3034
sl@0	3035	/*
sl@0	3036	*----------------------------------------------------------------------
sl@0	3037	*
sl@0	3038	* Tcl_LreplaceObjCmd --
sl@0	3039	*
sl@0	3040	* This object-based procedure is invoked to process the "lreplace"
sl@0	3041	* Tcl command. See the user documentation for details on what it does.
sl@0	3042	*
sl@0	3043	* Results:
sl@0	3044	* A new Tcl list object formed by replacing zero or more elements of
sl@0	3045	* a list.
sl@0	3046	*
sl@0	3047	* Side effects:
sl@0	3048	* See the user documentation.
sl@0	3049	*
sl@0	3050	*----------------------------------------------------------------------
sl@0	3051	*/
sl@0	3052
sl@0	3053	/* ARGSUSED */
sl@0	3054	int
sl@0	3055	Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
sl@0	3056	ClientData dummy; /* Not used. */
sl@0	3057	Tcl_Interp interp; / Current interpreter. */
sl@0	3058	int objc; /* Number of arguments. */
sl@0	3059	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	3060	{
sl@0	3061	register Tcl_Obj *listPtr;
sl@0	3062	int isDuplicate, first, last, listLen, numToDelete, result;
sl@0	3063
sl@0	3064	if (objc < 4) {
sl@0	3065	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	3066	"list first last ?element element ...?");
sl@0	3067	return TCL_ERROR;
sl@0	3068	}
sl@0	3069
sl@0	3070	result = Tcl_ListObjLength(interp, objv[1], &listLen);
sl@0	3071	if (result != TCL_OK) {
sl@0	3072	return result;
sl@0	3073	}
sl@0	3074
sl@0	3075	/*
sl@0	3076	* Get the first and last indexes. "end" is interpreted to be the index
sl@0	3077	* for the last element, such that using it will cause that element to
sl@0	3078	* be included for deletion.
sl@0	3079	*/
sl@0	3080
sl@0	3081	result = TclGetIntForIndex(interp, objv[2], /end/ (listLen - 1), &first);
sl@0	3082	if (result != TCL_OK) {
sl@0	3083	return result;
sl@0	3084	}
sl@0	3085
sl@0	3086	result = TclGetIntForIndex(interp, objv[3], /end/ (listLen - 1), &last);
sl@0	3087	if (result != TCL_OK) {
sl@0	3088	return result;
sl@0	3089	}
sl@0	3090
sl@0	3091	if (first < 0) {
sl@0	3092	first = 0;
sl@0	3093	}
sl@0	3094
sl@0	3095	/*
sl@0	3096	* Complain if the user asked for a start element that is greater than the
sl@0	3097	* list length. This won't ever trigger for the "end*" case as that will
sl@0	3098	* be properly constrained by TclGetIntForIndex because we use listLen-1
sl@0	3099	* (to allow for replacing the last elem).
sl@0	3100	*/
sl@0	3101
sl@0	3102	if ((first >= listLen) && (listLen > 0)) {
sl@0	3103	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	3104	"list doesn't contain element ",
sl@0	3105	Tcl_GetString(objv[2]), (int *) NULL);
sl@0	3106	return TCL_ERROR;
sl@0	3107	}
sl@0	3108	if (last >= listLen) {
sl@0	3109	last = (listLen - 1);
sl@0	3110	}
sl@0	3111	if (first <= last) {
sl@0	3112	numToDelete = (last - first + 1);
sl@0	3113	} else {
sl@0	3114	numToDelete = 0;
sl@0	3115	}
sl@0	3116
sl@0	3117	/*
sl@0	3118	* If the list object is unshared we can modify it directly, otherwise
sl@0	3119	* we create a copy to modify: this is "copy on write".
sl@0	3120	*/
sl@0	3121
sl@0	3122	listPtr = objv[1];
sl@0	3123	isDuplicate = 0;
sl@0	3124	if (Tcl_IsShared(listPtr)) {
sl@0	3125	listPtr = Tcl_DuplicateObj(listPtr);
sl@0	3126	isDuplicate = 1;
sl@0	3127	}
sl@0	3128	if (objc > 4) {
sl@0	3129	result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
sl@0	3130	(objc-4), &(objv[4]));
sl@0	3131	} else {
sl@0	3132	result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
sl@0	3133	0, NULL);
sl@0	3134	}
sl@0	3135	if (result != TCL_OK) {
sl@0	3136	if (isDuplicate) {
sl@0	3137	Tcl_DecrRefCount(listPtr); /* free unneeded obj */
sl@0	3138	}
sl@0	3139	return result;
sl@0	3140	}
sl@0	3141
sl@0	3142	/*
sl@0	3143	* Set the interpreter's object result.
sl@0	3144	*/
sl@0	3145
sl@0	3146	Tcl_SetObjResult(interp, listPtr);
sl@0	3147	return TCL_OK;
sl@0	3148	}
sl@0	3149
sl@0	3150	/*
sl@0	3151	*----------------------------------------------------------------------
sl@0	3152	*
sl@0	3153	* Tcl_LsearchObjCmd --
sl@0	3154	*
sl@0	3155	* This procedure is invoked to process the "lsearch" Tcl command.
sl@0	3156	* See the user documentation for details on what it does.
sl@0	3157	*
sl@0	3158	* Results:
sl@0	3159	* A standard Tcl result.
sl@0	3160	*
sl@0	3161	* Side effects:
sl@0	3162	* See the user documentation.
sl@0	3163	*
sl@0	3164	*----------------------------------------------------------------------
sl@0	3165	*/
sl@0	3166
sl@0	3167	int
sl@0	3168	Tcl_LsearchObjCmd(clientData, interp, objc, objv)
sl@0	3169	ClientData clientData; /* Not used. */
sl@0	3170	Tcl_Interp interp; / Current interpreter. */
sl@0	3171	int objc; /* Number of arguments. */
sl@0	3172	Tcl_Obj CONST objv[]; / Argument values. */
sl@0	3173	{
sl@0	3174	char bytes, patternBytes;
sl@0	3175	int i, match, mode, index, result, listc, length, elemLen;
sl@0	3176	int dataType, isIncreasing, lower, upper, patInt, objInt;
sl@0	3177	int offset, allMatches, inlineReturn, negatedMatch;
sl@0	3178	double patDouble, objDouble;
sl@0	3179	Tcl_Obj patObj, listv, listPtr, *startPtr;
sl@0	3180	Tcl_RegExp regexp = NULL;
sl@0	3181	static CONST char *options[] = {
sl@0	3182	"-all", "-ascii", "-decreasing", "-dictionary",
sl@0	3183	"-exact", "-glob", "-increasing", "-inline",
sl@0	3184	"-integer", "-not", "-real", "-regexp",
sl@0	3185	"-sorted", "-start", NULL
sl@0	3186	};
sl@0	3187	enum options {
sl@0	3188	LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY,
sl@0	3189	LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INLINE,
sl@0	3190	LSEARCH_INTEGER, LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP,
sl@0	3191	LSEARCH_SORTED, LSEARCH_START
sl@0	3192	};
sl@0	3193	enum datatypes {
sl@0	3194	ASCII, DICTIONARY, INTEGER, REAL
sl@0	3195	};
sl@0	3196	enum modes {
sl@0	3197	EXACT, GLOB, REGEXP, SORTED
sl@0	3198	};
sl@0	3199
sl@0	3200	mode = GLOB;
sl@0	3201	dataType = ASCII;
sl@0	3202	isIncreasing = 1;
sl@0	3203	allMatches = 0;
sl@0	3204	inlineReturn = 0;
sl@0	3205	negatedMatch = 0;
sl@0	3206	listPtr = NULL;
sl@0	3207	startPtr = NULL;
sl@0	3208	offset = 0;
sl@0	3209
sl@0	3210	if (objc < 3) {
sl@0	3211	Tcl_WrongNumArgs(interp, 1, objv, "?options? list pattern");
sl@0	3212	return TCL_ERROR;
sl@0	3213	}
sl@0	3214
sl@0	3215	for (i = 1; i < objc-2; i++) {
sl@0	3216	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
sl@0	3217	!= TCL_OK) {
sl@0	3218	if (startPtr) {
sl@0	3219	Tcl_DecrRefCount(startPtr);
sl@0	3220	}
sl@0	3221	return TCL_ERROR;
sl@0	3222	}
sl@0	3223	switch ((enum options) index) {
sl@0	3224	case LSEARCH_ALL: /* -all */
sl@0	3225	allMatches = 1;
sl@0	3226	break;
sl@0	3227	case LSEARCH_ASCII: /* -ascii */
sl@0	3228	dataType = ASCII;
sl@0	3229	break;
sl@0	3230	case LSEARCH_DECREASING: /* -decreasing */
sl@0	3231	isIncreasing = 0;
sl@0	3232	break;
sl@0	3233	case LSEARCH_DICTIONARY: /* -dictionary */
sl@0	3234	dataType = DICTIONARY;
sl@0	3235	break;
sl@0	3236	case LSEARCH_EXACT: /* -increasing */
sl@0	3237	mode = EXACT;
sl@0	3238	break;
sl@0	3239	case LSEARCH_GLOB: /* -glob */
sl@0	3240	mode = GLOB;
sl@0	3241	break;
sl@0	3242	case LSEARCH_INCREASING: /* -increasing */
sl@0	3243	isIncreasing = 1;
sl@0	3244	break;
sl@0	3245	case LSEARCH_INLINE: /* -inline */
sl@0	3246	inlineReturn = 1;
sl@0	3247	break;
sl@0	3248	case LSEARCH_INTEGER: /* -integer */
sl@0	3249	dataType = INTEGER;
sl@0	3250	break;
sl@0	3251	case LSEARCH_NOT: /* -not */
sl@0	3252	negatedMatch = 1;
sl@0	3253	break;
sl@0	3254	case LSEARCH_REAL: /* -real */
sl@0	3255	dataType = REAL;
sl@0	3256	break;
sl@0	3257	case LSEARCH_REGEXP: /* -regexp */
sl@0	3258	mode = REGEXP;
sl@0	3259	break;
sl@0	3260	case LSEARCH_SORTED: /* -sorted */
sl@0	3261	mode = SORTED;
sl@0	3262	break;
sl@0	3263	case LSEARCH_START: /* -start */
sl@0	3264	/*
sl@0	3265	* If there was a previous -start option, release its saved
sl@0	3266	* index because it will either be replaced or there will be
sl@0	3267	* an error.
sl@0	3268	*/
sl@0	3269	if (startPtr) {
sl@0	3270	Tcl_DecrRefCount(startPtr);
sl@0	3271	}
sl@0	3272	if (i > objc-4) {
sl@0	3273	Tcl_AppendResult(interp, "missing starting index", NULL);
sl@0	3274	return TCL_ERROR;
sl@0	3275	}
sl@0	3276	i++;
sl@0	3277	if (objv[i] == objv[objc - 2]) {
sl@0	3278	/*
sl@0	3279	* Take copy to prevent shimmering problems. Note
sl@0	3280	* that it does not matter if the index obj is also a
sl@0	3281	* component of the list being searched. We only need
sl@0	3282	* to copy where the list and the index are
sl@0	3283	* one-and-the-same.
sl@0	3284	*/
sl@0	3285	startPtr = Tcl_DuplicateObj(objv[i]);
sl@0	3286	} else {
sl@0	3287	startPtr = objv[i];
sl@0	3288	Tcl_IncrRefCount(startPtr);
sl@0	3289	}
sl@0	3290	}
sl@0	3291	}
sl@0	3292
sl@0	3293	if ((enum modes) mode == REGEXP) {
sl@0	3294	/*
sl@0	3295	* We can shimmer regexp/list if listv[i] == pattern, so get the
sl@0	3296	* regexp rep before the list rep. First time round, omit the interp
sl@0	3297	* and hope that the compilation will succeed. If it fails, we'll
sl@0	3298	* recompile in "expensive" mode with a place to put error messages.
sl@0	3299	*/
sl@0	3300
sl@0	3301	regexp = Tcl_GetRegExpFromObj(NULL, objv[objc - 1],
sl@0	3302	TCL_REG_ADVANCED \| TCL_REG_NOSUB);
sl@0	3303	if (regexp == NULL) {
sl@0	3304	/*
sl@0	3305	* Failed to compile the RE. Try again without the TCL_REG_NOSUB
sl@0	3306	* flag in case the RE had sub-expressions in it [Bug 1366683].
sl@0	3307	* If this fails, an error message will be left in the
sl@0	3308	* interpreter.
sl@0	3309	*/
sl@0	3310
sl@0	3311	regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1],
sl@0	3312	TCL_REG_ADVANCED);
sl@0	3313	}
sl@0	3314
sl@0	3315	if (regexp == NULL) {
sl@0	3316	if (startPtr) {
sl@0	3317	Tcl_DecrRefCount(startPtr);
sl@0	3318	}
sl@0	3319	return TCL_ERROR;
sl@0	3320	}
sl@0	3321	}
sl@0	3322
sl@0	3323	/*
sl@0	3324	* Make sure the list argument is a list object and get its length and
sl@0	3325	* a pointer to its array of element pointers.
sl@0	3326	*/
sl@0	3327
sl@0	3328	result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv);
sl@0	3329	if (result != TCL_OK) {
sl@0	3330	if (startPtr) {
sl@0	3331	Tcl_DecrRefCount(startPtr);
sl@0	3332	}
sl@0	3333	return result;
sl@0	3334	}
sl@0	3335
sl@0	3336	/*
sl@0	3337	* Get the user-specified start offset.
sl@0	3338	*/
sl@0	3339	if (startPtr) {
sl@0	3340	result = TclGetIntForIndex(interp, startPtr, listc-1, &offset);
sl@0	3341	Tcl_DecrRefCount(startPtr);
sl@0	3342	if (result != TCL_OK) {
sl@0	3343	return result;
sl@0	3344	}
sl@0	3345
sl@0	3346	/*
sl@0	3347	* If the search started past the end of the list, we just return a
sl@0	3348	* "did not match anything at all" result straight away. [Bug 1374778]
sl@0	3349	*/
sl@0	3350
sl@0	3351	if (offset > listc-1) {
sl@0	3352	if (allMatches \|\| inlineReturn) {
sl@0	3353	Tcl_ResetResult(interp);
sl@0	3354	} else {
sl@0	3355	Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
sl@0	3356	}
sl@0	3357	return TCL_OK;
sl@0	3358	}
sl@0	3359	if (offset < 0) {
sl@0	3360	offset = 0;
sl@0	3361	}
sl@0	3362	}
sl@0	3363
sl@0	3364	patObj = objv[objc - 1];
sl@0	3365	patternBytes = NULL;
sl@0	3366	if ((enum modes) mode == EXACT \|\| (enum modes) mode == SORTED) {
sl@0	3367	switch ((enum datatypes) dataType) {
sl@0	3368	case ASCII:
sl@0	3369	case DICTIONARY:
sl@0	3370	patternBytes = Tcl_GetStringFromObj(patObj, &length);
sl@0	3371	break;
sl@0	3372	case INTEGER:
sl@0	3373	result = Tcl_GetIntFromObj(interp, patObj, &patInt);
sl@0	3374	if (result != TCL_OK) {
sl@0	3375	return result;
sl@0	3376	}
sl@0	3377	break;
sl@0	3378	case REAL:
sl@0	3379	result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble);
sl@0	3380	if (result != TCL_OK) {
sl@0	3381	return result;
sl@0	3382	}
sl@0	3383	break;
sl@0	3384	}
sl@0	3385	} else {
sl@0	3386	patternBytes = Tcl_GetStringFromObj(patObj, &length);
sl@0	3387	}
sl@0	3388
sl@0	3389	/*
sl@0	3390	* Set default index value to -1, indicating failure; if we find the
sl@0	3391	* item in the course of our search, index will be set to the correct
sl@0	3392	* value.
sl@0	3393	*/
sl@0	3394	index = -1;
sl@0	3395	match = 0;
sl@0	3396
sl@0	3397	if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) {
sl@0	3398	/*
sl@0	3399	* If the data is sorted, we can do a more intelligent search.
sl@0	3400	* Note that there is no point in being smart when -all was
sl@0	3401	* specified; in that case, we have to look at all items anyway,
sl@0	3402	* and there is no sense in doing this when the match sense is
sl@0	3403	* inverted.
sl@0	3404	*/
sl@0	3405	lower = offset - 1;
sl@0	3406	upper = listc;
sl@0	3407	while (lower + 1 != upper) {
sl@0	3408	i = (lower + upper)/2;
sl@0	3409	switch ((enum datatypes) dataType) {
sl@0	3410	case ASCII:
sl@0	3411	bytes = Tcl_GetString(listv[i]);
sl@0	3412	match = strcmp(patternBytes, bytes);
sl@0	3413	break;
sl@0	3414	case DICTIONARY:
sl@0	3415	bytes = Tcl_GetString(listv[i]);
sl@0	3416	match = DictionaryCompare(patternBytes, bytes);
sl@0	3417	break;
sl@0	3418	case INTEGER:
sl@0	3419	result = Tcl_GetIntFromObj(interp, listv[i], &objInt);
sl@0	3420	if (result != TCL_OK) {
sl@0	3421	return result;
sl@0	3422	}
sl@0	3423	if (patInt == objInt) {
sl@0	3424	match = 0;
sl@0	3425	} else if (patInt < objInt) {
sl@0	3426	match = -1;
sl@0	3427	} else {
sl@0	3428	match = 1;
sl@0	3429	}
sl@0	3430	break;
sl@0	3431	case REAL:
sl@0	3432	result = Tcl_GetDoubleFromObj(interp, listv[i], &objDouble);
sl@0	3433	if (result != TCL_OK) {
sl@0	3434	return result;
sl@0	3435	}
sl@0	3436	if (patDouble == objDouble) {
sl@0	3437	match = 0;
sl@0	3438	} else if (patDouble < objDouble) {
sl@0	3439	match = -1;
sl@0	3440	} else {
sl@0	3441	match = 1;
sl@0	3442	}
sl@0	3443	break;
sl@0	3444	}
sl@0	3445	if (match == 0) {
sl@0	3446	/*
sl@0	3447	* Normally, binary search is written to stop when it
sl@0	3448	* finds a match. If there are duplicates of an element in
sl@0	3449	* the list, our first match might not be the first occurance.
sl@0	3450	* Consider: 0 0 0 1 1 1 2 2 2
sl@0	3451	* To maintain consistancy with standard lsearch semantics,
sl@0	3452	* we must find the leftmost occurance of the pattern in the
sl@0	3453	* list. Thus we don't just stop searching here. This
sl@0	3454	* variation means that a search always makes log n
sl@0	3455	* comparisons (normal binary search might "get lucky" with
sl@0	3456	* an early comparison).
sl@0	3457	*/
sl@0	3458	index = i;
sl@0	3459	upper = i;
sl@0	3460	} else if (match > 0) {
sl@0	3461	if (isIncreasing) {
sl@0	3462	lower = i;
sl@0	3463	} else {
sl@0	3464	upper = i;
sl@0	3465	}
sl@0	3466	} else {
sl@0	3467	if (isIncreasing) {
sl@0	3468	upper = i;
sl@0	3469	} else {
sl@0	3470	lower = i;
sl@0	3471	}
sl@0	3472	}
sl@0	3473	}
sl@0	3474
sl@0	3475	} else {
sl@0	3476	/*
sl@0	3477	* We need to do a linear search, because (at least one) of:
sl@0	3478	* - our matcher can only tell equal vs. not equal
sl@0	3479	* - our matching sense is negated
sl@0	3480	* - we're building a list of all matched items
sl@0	3481	*/
sl@0	3482	if (allMatches) {
sl@0	3483	listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
sl@0	3484	}
sl@0	3485	for (i = offset; i < listc; i++) {
sl@0	3486	match = 0;
sl@0	3487	switch ((enum modes) mode) {
sl@0	3488	case SORTED:
sl@0	3489	case EXACT:
sl@0	3490	switch ((enum datatypes) dataType) {
sl@0	3491	case ASCII:
sl@0	3492	bytes = Tcl_GetStringFromObj(listv[i], &elemLen);
sl@0	3493	if (length == elemLen) {
sl@0	3494	match = (memcmp(bytes, patternBytes,
sl@0	3495	(size_t) length) == 0);
sl@0	3496	}
sl@0	3497	break;
sl@0	3498	case DICTIONARY:
sl@0	3499	bytes = Tcl_GetString(listv[i]);
sl@0	3500	match = (DictionaryCompare(bytes, patternBytes) == 0);
sl@0	3501	break;
sl@0	3502	case INTEGER:
sl@0	3503	result = Tcl_GetIntFromObj(interp, listv[i], &objInt);
sl@0	3504	if (result != TCL_OK) {
sl@0	3505	if (listPtr) {
sl@0	3506	Tcl_DecrRefCount(listPtr);
sl@0	3507	}
sl@0	3508	return result;
sl@0	3509	}
sl@0	3510	match = (objInt == patInt);
sl@0	3511	break;
sl@0	3512	case REAL:
sl@0	3513	result = Tcl_GetDoubleFromObj(interp, listv[i],
sl@0	3514	&objDouble);
sl@0	3515	if (result != TCL_OK) {
sl@0	3516	if (listPtr) {
sl@0	3517	Tcl_DecrRefCount(listPtr);
sl@0	3518	}
sl@0	3519	return result;
sl@0	3520	}
sl@0	3521	match = (objDouble == patDouble);
sl@0	3522	break;
sl@0	3523	}
sl@0	3524	break;
sl@0	3525	case GLOB:
sl@0	3526	match = Tcl_StringMatch(Tcl_GetString(listv[i]),
sl@0	3527	patternBytes);
sl@0	3528	break;
sl@0	3529	case REGEXP:
sl@0	3530	match = Tcl_RegExpExecObj(interp, regexp, listv[i], 0, 0, 0);
sl@0	3531	if (match < 0) {
sl@0	3532	Tcl_DecrRefCount(patObj);
sl@0	3533	if (listPtr) {
sl@0	3534	Tcl_DecrRefCount(listPtr);
sl@0	3535	}
sl@0	3536	return TCL_ERROR;
sl@0	3537	}
sl@0	3538	break;
sl@0	3539	}
sl@0	3540	/*
sl@0	3541	* Invert match condition for -not
sl@0	3542	*/
sl@0	3543	if (negatedMatch) {
sl@0	3544	match = !match;
sl@0	3545	}
sl@0	3546	if (match != 0) {
sl@0	3547	if (!allMatches) {
sl@0	3548	index = i;
sl@0	3549	break;
sl@0	3550	} else if (inlineReturn) {
sl@0	3551	/*
sl@0	3552	* Note that these appends are not expected to fail.
sl@0	3553	*/
sl@0	3554	Tcl_ListObjAppendElement(interp, listPtr, listv[i]);
sl@0	3555	} else {
sl@0	3556	Tcl_ListObjAppendElement(interp, listPtr,
sl@0	3557	Tcl_NewIntObj(i));
sl@0	3558	}
sl@0	3559	}
sl@0	3560	}
sl@0	3561	}
sl@0	3562
sl@0	3563	/*
sl@0	3564	* Return everything or a single value.
sl@0	3565	*/
sl@0	3566	if (allMatches) {
sl@0	3567	Tcl_SetObjResult(interp, listPtr);
sl@0	3568	} else if (!inlineReturn) {
sl@0	3569	Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
sl@0	3570	} else if (index < 0) {
sl@0	3571	/*
sl@0	3572	* Is this superfluous? The result should be a blank object
sl@0	3573	* by default...
sl@0	3574	*/
sl@0	3575	Tcl_SetObjResult(interp, Tcl_NewObj());
sl@0	3576	} else {
sl@0	3577	Tcl_SetObjResult(interp, listv[index]);
sl@0	3578	}
sl@0	3579	return TCL_OK;
sl@0	3580	}
sl@0	3581
sl@0	3582	/*
sl@0	3583	*----------------------------------------------------------------------
sl@0	3584	*
sl@0	3585	* Tcl_LsetObjCmd --
sl@0	3586	*
sl@0	3587	* This procedure is invoked to process the "lset" Tcl command.
sl@0	3588	* See the user documentation for details on what it does.
sl@0	3589	*
sl@0	3590	* Results:
sl@0	3591	* A standard Tcl result.
sl@0	3592	*
sl@0	3593	* Side effects:
sl@0	3594	* See the user documentation.
sl@0	3595	*
sl@0	3596	*----------------------------------------------------------------------
sl@0	3597	*/
sl@0	3598
sl@0	3599	int
sl@0	3600	Tcl_LsetObjCmd( clientData, interp, objc, objv )
sl@0	3601	ClientData clientData; /* Not used. */
sl@0	3602	Tcl_Interp interp; / Current interpreter. */
sl@0	3603	int objc; /* Number of arguments. */
sl@0	3604	Tcl_Obj CONST objv[]; / Argument values. */
sl@0	3605	{
sl@0	3606
sl@0	3607	Tcl_Obj* listPtr; /* Pointer to the list being altered. */
sl@0	3608	Tcl_Obj* finalValuePtr; /* Value finally assigned to the variable */
sl@0	3609
sl@0	3610	/* Check parameter count */
sl@0	3611
sl@0	3612	if ( objc < 3 ) {
sl@0	3613	Tcl_WrongNumArgs( interp, 1, objv, "listVar index ?index...? value" );
sl@0	3614	return TCL_ERROR;
sl@0	3615	}
sl@0	3616
sl@0	3617	/* Look up the list variable's value */
sl@0	3618
sl@0	3619	listPtr = Tcl_ObjGetVar2( interp, objv[ 1 ], (Tcl_Obj*) NULL,
sl@0	3620	TCL_LEAVE_ERR_MSG );
sl@0	3621	if ( listPtr == NULL ) {
sl@0	3622	return TCL_ERROR;
sl@0	3623	}
sl@0	3624
sl@0	3625	/*
sl@0	3626	* Substitute the value in the value. Return either the value or
sl@0	3627	* else an unshared copy of it.
sl@0	3628	*/
sl@0	3629
sl@0	3630	if ( objc == 4 ) {
sl@0	3631	finalValuePtr = TclLsetList( interp, listPtr,
sl@0	3632	objv[ 2 ], objv[ 3 ] );
sl@0	3633	} else {
sl@0	3634	finalValuePtr = TclLsetFlat( interp, listPtr,
sl@0	3635	objc-3, objv+2, objv[ objc-1 ] );
sl@0	3636	}
sl@0	3637
sl@0	3638	/*
sl@0	3639	* If substitution has failed, bail out.
sl@0	3640	*/
sl@0	3641
sl@0	3642	if ( finalValuePtr == NULL ) {
sl@0	3643	return TCL_ERROR;
sl@0	3644	}
sl@0	3645
sl@0	3646	/* Finally, update the variable so that traces fire. */
sl@0	3647
sl@0	3648	listPtr = Tcl_ObjSetVar2( interp, objv[1], NULL, finalValuePtr,
sl@0	3649	TCL_LEAVE_ERR_MSG );
sl@0	3650	Tcl_DecrRefCount( finalValuePtr );
sl@0	3651	if ( listPtr == NULL ) {
sl@0	3652	return TCL_ERROR;
sl@0	3653	}
sl@0	3654
sl@0	3655	/* Return the new value of the variable as the interpreter result. */
sl@0	3656
sl@0	3657	Tcl_SetObjResult( interp, listPtr );
sl@0	3658	return TCL_OK;
sl@0	3659
sl@0	3660	}
sl@0	3661
sl@0	3662	/*
sl@0	3663	*----------------------------------------------------------------------
sl@0	3664	*
sl@0	3665	* Tcl_LsortObjCmd --
sl@0	3666	*
sl@0	3667	* This procedure is invoked to process the "lsort" Tcl command.
sl@0	3668	* See the user documentation for details on what it does.
sl@0	3669	*
sl@0	3670	* Results:
sl@0	3671	* A standard Tcl result.
sl@0	3672	*
sl@0	3673	* Side effects:
sl@0	3674	* See the user documentation.
sl@0	3675	*
sl@0	3676	*----------------------------------------------------------------------
sl@0	3677	*/
sl@0	3678
sl@0	3679	int
sl@0	3680	Tcl_LsortObjCmd(clientData, interp, objc, objv)
sl@0	3681	ClientData clientData; /* Not used. */
sl@0	3682	Tcl_Interp interp; / Current interpreter. */
sl@0	3683	int objc; /* Number of arguments. */
sl@0	3684	Tcl_Obj CONST objv[]; / Argument values. */
sl@0	3685	{
sl@0	3686	int i, index, unique;
sl@0	3687	Tcl_Obj *resultPtr;
sl@0	3688	int length;
sl@0	3689	Tcl_Obj cmdPtr, *listObjPtrs;
sl@0	3690	SortElement *elementArray;
sl@0	3691	SortElement *elementPtr;
sl@0	3692	SortInfo sortInfo; /* Information about this sort that
sl@0	3693	* needs to be passed to the
sl@0	3694	* comparison function */
sl@0	3695	static CONST char *switches[] = {
sl@0	3696	"-ascii", "-command", "-decreasing", "-dictionary", "-increasing",
sl@0	3697	"-index", "-integer", "-real", "-unique", (char *) NULL
sl@0	3698	};
sl@0	3699
sl@0	3700	resultPtr = Tcl_GetObjResult(interp);
sl@0	3701	if (objc < 2) {
sl@0	3702	Tcl_WrongNumArgs(interp, 1, objv, "?options? list");
sl@0	3703	return TCL_ERROR;
sl@0	3704	}
sl@0	3705
sl@0	3706	/*
sl@0	3707	* Parse arguments to set up the mode for the sort.
sl@0	3708	*/
sl@0	3709
sl@0	3710	sortInfo.isIncreasing = 1;
sl@0	3711	sortInfo.sortMode = SORTMODE_ASCII;
sl@0	3712	sortInfo.index = SORTIDX_NONE;
sl@0	3713	sortInfo.interp = interp;
sl@0	3714	sortInfo.resultCode = TCL_OK;
sl@0	3715	cmdPtr = NULL;
sl@0	3716	unique = 0;
sl@0	3717	for (i = 1; i < objc-1; i++) {
sl@0	3718	if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index)
sl@0	3719	!= TCL_OK) {
sl@0	3720	return TCL_ERROR;
sl@0	3721	}
sl@0	3722	switch (index) {
sl@0	3723	case 0: /* -ascii */
sl@0	3724	sortInfo.sortMode = SORTMODE_ASCII;
sl@0	3725	break;
sl@0	3726	case 1: /* -command */
sl@0	3727	if (i == (objc-2)) {
sl@0	3728	Tcl_AppendToObj(resultPtr,
sl@0	3729	"\"-command\" option must be followed by comparison command",
sl@0	3730	-1);
sl@0	3731	return TCL_ERROR;
sl@0	3732	}
sl@0	3733	sortInfo.sortMode = SORTMODE_COMMAND;
sl@0	3734	cmdPtr = objv[i+1];
sl@0	3735	i++;
sl@0	3736	break;
sl@0	3737	case 2: /* -decreasing */
sl@0	3738	sortInfo.isIncreasing = 0;
sl@0	3739	break;
sl@0	3740	case 3: /* -dictionary */
sl@0	3741	sortInfo.sortMode = SORTMODE_DICTIONARY;
sl@0	3742	break;
sl@0	3743	case 4: /* -increasing */
sl@0	3744	sortInfo.isIncreasing = 1;
sl@0	3745	break;
sl@0	3746	case 5: /* -index */
sl@0	3747	if (i == (objc-2)) {
sl@0	3748	Tcl_AppendToObj(resultPtr,
sl@0	3749	"\"-index\" option must be followed by list index",
sl@0	3750	-1);
sl@0	3751	return TCL_ERROR;
sl@0	3752	}
sl@0	3753	if (TclGetIntForIndex(interp, objv[i+1], SORTIDX_END,
sl@0	3754	&sortInfo.index) != TCL_OK) {
sl@0	3755	return TCL_ERROR;
sl@0	3756	}
sl@0	3757	i++;
sl@0	3758	break;
sl@0	3759	case 6: /* -integer */
sl@0	3760	sortInfo.sortMode = SORTMODE_INTEGER;
sl@0	3761	break;
sl@0	3762	case 7: /* -real */
sl@0	3763	sortInfo.sortMode = SORTMODE_REAL;
sl@0	3764	break;
sl@0	3765	case 8: /* -unique */
sl@0	3766	unique = 1;
sl@0	3767	break;
sl@0	3768	}
sl@0	3769	}
sl@0	3770	if (sortInfo.sortMode == SORTMODE_COMMAND) {
sl@0	3771	/*
sl@0	3772	* The existing command is a list. We want to flatten it, append
sl@0	3773	* two dummy arguments on the end, and replace these arguments
sl@0	3774	* later.
sl@0	3775	*/
sl@0	3776
sl@0	3777	Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr);
sl@0	3778	Tcl_Obj *newObjPtr = Tcl_NewObj();
sl@0	3779
sl@0	3780	Tcl_IncrRefCount(newCommandPtr);
sl@0	3781	if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr)
sl@0	3782	!= TCL_OK) {
sl@0	3783	Tcl_DecrRefCount(newCommandPtr);
sl@0	3784	Tcl_IncrRefCount(newObjPtr);
sl@0	3785	Tcl_DecrRefCount(newObjPtr);
sl@0	3786	return TCL_ERROR;
sl@0	3787	}
sl@0	3788	Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());
sl@0	3789	sortInfo.compareCmdPtr = newCommandPtr;
sl@0	3790	}
sl@0	3791
sl@0	3792	sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1],
sl@0	3793	&length, &listObjPtrs);
sl@0	3794	if (sortInfo.resultCode != TCL_OK \|\| length <= 0) {
sl@0	3795	goto done;
sl@0	3796	}
sl@0	3797	elementArray = (SortElement ) ckalloc(length sizeof(SortElement));
sl@0	3798	for (i=0; i < length; i++){
sl@0	3799	elementArray[i].objPtr = listObjPtrs[i];
sl@0	3800	elementArray[i].count = 0;
sl@0	3801	elementArray[i].nextPtr = &elementArray[i+1];
sl@0	3802
sl@0	3803	/*
sl@0	3804	* When sorting using a command, we are reentrant and therefore might
sl@0	3805	* have the representation of the list being sorted shimmered out from
sl@0	3806	* underneath our feet. Increment the reference counts of the elements
sl@0	3807	* to sort to prevent this. [Bug 1675116]
sl@0	3808	*/
sl@0	3809
sl@0	3810	Tcl_IncrRefCount(elementArray[i].objPtr);
sl@0	3811	}
sl@0	3812	elementArray[length-1].nextPtr = NULL;
sl@0	3813	elementPtr = MergeSort(elementArray, &sortInfo);
sl@0	3814	if (sortInfo.resultCode == TCL_OK) {
sl@0	3815	/*
sl@0	3816	* Note: must clear the interpreter's result object: it could
sl@0	3817	* have been set by the -command script.
sl@0	3818	*/
sl@0	3819
sl@0	3820	Tcl_ResetResult(interp);
sl@0	3821	resultPtr = Tcl_GetObjResult(interp);
sl@0	3822	if (unique) {
sl@0	3823	for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
sl@0	3824	if (elementPtr->count == 0) {
sl@0	3825	Tcl_ListObjAppendElement(interp, resultPtr,
sl@0	3826	elementPtr->objPtr);
sl@0	3827	}
sl@0	3828	}
sl@0	3829	} else {
sl@0	3830	for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
sl@0	3831	Tcl_ListObjAppendElement(interp, resultPtr,
sl@0	3832	elementPtr->objPtr);
sl@0	3833	}
sl@0	3834	}
sl@0	3835	}
sl@0	3836	for (i=0; i<length; i++) {
sl@0	3837	Tcl_DecrRefCount(elementArray[i].objPtr);
sl@0	3838	}
sl@0	3839	ckfree((char*) elementArray);
sl@0	3840
sl@0	3841	done:
sl@0	3842	if (sortInfo.sortMode == SORTMODE_COMMAND) {
sl@0	3843	Tcl_DecrRefCount(sortInfo.compareCmdPtr);
sl@0	3844	sortInfo.compareCmdPtr = NULL;
sl@0	3845	}
sl@0	3846	return sortInfo.resultCode;
sl@0	3847	}
sl@0	3848
sl@0	3849	/*
sl@0	3850	*----------------------------------------------------------------------
sl@0	3851	*
sl@0	3852	* MergeSort -
sl@0	3853	*
sl@0	3854	* This procedure sorts a linked list of SortElement structures
sl@0	3855	* use the merge-sort algorithm.
sl@0	3856	*
sl@0	3857	* Results:
sl@0	3858	* A pointer to the head of the list after sorting is returned.
sl@0	3859	*
sl@0	3860	* Side effects:
sl@0	3861	* None, unless a user-defined comparison command does something
sl@0	3862	* weird.
sl@0	3863	*
sl@0	3864	*----------------------------------------------------------------------
sl@0	3865	*/
sl@0	3866
sl@0	3867	static SortElement *
sl@0	3868	MergeSort(headPtr, infoPtr)
sl@0	3869	SortElement headPtr; / First element on the list */
sl@0	3870	SortInfo infoPtr; / Information needed by the
sl@0	3871	* comparison operator */
sl@0	3872	{
sl@0	3873	/*
sl@0	3874	* The subList array below holds pointers to temporary lists built
sl@0	3875	* during the merge sort. Element i of the array holds a list of
sl@0	3876	* length 2**i.
sl@0	3877	*/
sl@0	3878
sl@0	3879	# define NUM_LISTS 30
sl@0	3880	SortElement *subList[NUM_LISTS];
sl@0	3881	SortElement *elementPtr;
sl@0	3882	int i;
sl@0	3883
sl@0	3884	for(i = 0; i < NUM_LISTS; i++){
sl@0	3885	subList[i] = NULL;
sl@0	3886	}
sl@0	3887	while (headPtr != NULL) {
sl@0	3888	elementPtr = headPtr;
sl@0	3889	headPtr = headPtr->nextPtr;
sl@0	3890	elementPtr->nextPtr = 0;
sl@0	3891	for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){
sl@0	3892	elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
sl@0	3893	subList[i] = NULL;
sl@0	3894	}
sl@0	3895	if (i >= NUM_LISTS) {
sl@0	3896	i = NUM_LISTS-1;
sl@0	3897	}
sl@0	3898	subList[i] = elementPtr;
sl@0	3899	}
sl@0	3900	elementPtr = NULL;
sl@0	3901	for (i = 0; i < NUM_LISTS; i++){
sl@0	3902	elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
sl@0	3903	}
sl@0	3904	return elementPtr;
sl@0	3905	}
sl@0	3906
sl@0	3907	/*
sl@0	3908	*----------------------------------------------------------------------
sl@0	3909	*
sl@0	3910	* MergeLists -
sl@0	3911	*
sl@0	3912	* This procedure combines two sorted lists of SortElement structures
sl@0	3913	* into a single sorted list.
sl@0	3914	*
sl@0	3915	* Results:
sl@0	3916	* The unified list of SortElement structures.
sl@0	3917	*
sl@0	3918	* Side effects:
sl@0	3919	* None, unless a user-defined comparison command does something
sl@0	3920	* weird.
sl@0	3921	*
sl@0	3922	*----------------------------------------------------------------------
sl@0	3923	*/
sl@0	3924
sl@0	3925	static SortElement *
sl@0	3926	MergeLists(leftPtr, rightPtr, infoPtr)
sl@0	3927	SortElement leftPtr; / First list to be merged; may be
sl@0	3928	* NULL. */
sl@0	3929	SortElement rightPtr; / Second list to be merged; may be
sl@0	3930	* NULL. */
sl@0	3931	SortInfo infoPtr; / Information needed by the
sl@0	3932	* comparison operator. */
sl@0	3933	{
sl@0	3934	SortElement *headPtr;
sl@0	3935	SortElement *tailPtr;
sl@0	3936	int cmp;
sl@0	3937
sl@0	3938	if (leftPtr == NULL) {
sl@0	3939	return rightPtr;
sl@0	3940	}
sl@0	3941	if (rightPtr == NULL) {
sl@0	3942	return leftPtr;
sl@0	3943	}
sl@0	3944	cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr);
sl@0	3945	if (cmp > 0) {
sl@0	3946	tailPtr = rightPtr;
sl@0	3947	rightPtr = rightPtr->nextPtr;
sl@0	3948	} else {
sl@0	3949	if (cmp == 0) {
sl@0	3950	leftPtr->count++;
sl@0	3951	}
sl@0	3952	tailPtr = leftPtr;
sl@0	3953	leftPtr = leftPtr->nextPtr;
sl@0	3954	}
sl@0	3955	headPtr = tailPtr;
sl@0	3956	while ((leftPtr != NULL) && (rightPtr != NULL)) {
sl@0	3957	cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr);
sl@0	3958	if (cmp > 0) {
sl@0	3959	tailPtr->nextPtr = rightPtr;
sl@0	3960	tailPtr = rightPtr;
sl@0	3961	rightPtr = rightPtr->nextPtr;
sl@0	3962	} else {
sl@0	3963	if (cmp == 0) {
sl@0	3964	leftPtr->count++;
sl@0	3965	}
sl@0	3966	tailPtr->nextPtr = leftPtr;
sl@0	3967	tailPtr = leftPtr;
sl@0	3968	leftPtr = leftPtr->nextPtr;
sl@0	3969	}
sl@0	3970	}
sl@0	3971	if (leftPtr != NULL) {
sl@0	3972	tailPtr->nextPtr = leftPtr;
sl@0	3973	} else {
sl@0	3974	tailPtr->nextPtr = rightPtr;
sl@0	3975	}
sl@0	3976	return headPtr;
sl@0	3977	}
sl@0	3978
sl@0	3979	/*
sl@0	3980	*----------------------------------------------------------------------
sl@0	3981	*
sl@0	3982	* SortCompare --
sl@0	3983	*
sl@0	3984	* This procedure is invoked by MergeLists to determine the proper
sl@0	3985	* ordering between two elements.
sl@0	3986	*
sl@0	3987	* Results:
sl@0	3988	* A negative results means the the first element comes before the
sl@0	3989	* second, and a positive results means that the second element
sl@0	3990	* should come first. A result of zero means the two elements
sl@0	3991	* are equal and it doesn't matter which comes first.
sl@0	3992	*
sl@0	3993	* Side effects:
sl@0	3994	* None, unless a user-defined comparison command does something
sl@0	3995	* weird.
sl@0	3996	*
sl@0	3997	*----------------------------------------------------------------------
sl@0	3998	*/
sl@0	3999
sl@0	4000	static int
sl@0	4001	SortCompare(objPtr1, objPtr2, infoPtr)
sl@0	4002	Tcl_Obj objPtr1, objPtr2; /* Values to be compared. */
sl@0	4003	SortInfo infoPtr; / Information passed from the
sl@0	4004	* top-level "lsort" command */
sl@0	4005	{
sl@0	4006	int order, listLen, index;
sl@0	4007	Tcl_Obj *objPtr;
sl@0	4008	char buffer[TCL_INTEGER_SPACE];
sl@0	4009
sl@0	4010	order = 0;
sl@0	4011	if (infoPtr->resultCode != TCL_OK) {
sl@0	4012	/*
sl@0	4013	* Once an error has occurred, skip any future comparisons
sl@0	4014	* so as to preserve the error message in sortInterp->result.
sl@0	4015	*/
sl@0	4016
sl@0	4017	return order;
sl@0	4018	}
sl@0	4019	if (infoPtr->index != SORTIDX_NONE) {
sl@0	4020	/*
sl@0	4021	* The "-index" option was specified. Treat each object as a
sl@0	4022	* list, extract the requested element from each list, and
sl@0	4023	* compare the elements, not the lists. "end"-relative indices
sl@0	4024	* are signaled here with large negative values.
sl@0	4025	*/
sl@0	4026
sl@0	4027	if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) {
sl@0	4028	infoPtr->resultCode = TCL_ERROR;
sl@0	4029	return order;
sl@0	4030	}
sl@0	4031	if (infoPtr->index < SORTIDX_NONE) {
sl@0	4032	index = listLen + infoPtr->index + 1;
sl@0	4033	} else {
sl@0	4034	index = infoPtr->index;
sl@0	4035	}
sl@0	4036
sl@0	4037	if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr)
sl@0	4038	!= TCL_OK) {
sl@0	4039	infoPtr->resultCode = TCL_ERROR;
sl@0	4040	return order;
sl@0	4041	}
sl@0	4042	if (objPtr == NULL) {
sl@0	4043	objPtr = objPtr1;
sl@0	4044	missingElement:
sl@0	4045	TclFormatInt(buffer, infoPtr->index);
sl@0	4046	Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
sl@0	4047	"element ", buffer, " missing from sublist \"",
sl@0	4048	Tcl_GetString(objPtr), "\"", (char *) NULL);
sl@0	4049	infoPtr->resultCode = TCL_ERROR;
sl@0	4050	return order;
sl@0	4051	}
sl@0	4052	objPtr1 = objPtr;
sl@0	4053
sl@0	4054	if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) {
sl@0	4055	infoPtr->resultCode = TCL_ERROR;
sl@0	4056	return order;
sl@0	4057	}
sl@0	4058	if (infoPtr->index < SORTIDX_NONE) {
sl@0	4059	index = listLen + infoPtr->index + 1;
sl@0	4060	} else {
sl@0	4061	index = infoPtr->index;
sl@0	4062	}
sl@0	4063
sl@0	4064	if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr)
sl@0	4065	!= TCL_OK) {
sl@0	4066	infoPtr->resultCode = TCL_ERROR;
sl@0	4067	return order;
sl@0	4068	}
sl@0	4069	if (objPtr == NULL) {
sl@0	4070	objPtr = objPtr2;
sl@0	4071	goto missingElement;
sl@0	4072	}
sl@0	4073	objPtr2 = objPtr;
sl@0	4074	}
sl@0	4075	if (infoPtr->sortMode == SORTMODE_ASCII) {
sl@0	4076	order = strcmp(Tcl_GetString(objPtr1), Tcl_GetString(objPtr2));
sl@0	4077	} else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
sl@0	4078	order = DictionaryCompare(
sl@0	4079	Tcl_GetString(objPtr1), Tcl_GetString(objPtr2));
sl@0	4080	} else if (infoPtr->sortMode == SORTMODE_INTEGER) {
sl@0	4081	long a, b;
sl@0	4082
sl@0	4083	if ((Tcl_GetLongFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
sl@0	4084	\|\| (Tcl_GetLongFromObj(infoPtr->interp, objPtr2, &b)
sl@0	4085	!= TCL_OK)) {
sl@0	4086	infoPtr->resultCode = TCL_ERROR;
sl@0	4087	return order;
sl@0	4088	}
sl@0	4089	if (a > b) {
sl@0	4090	order = 1;
sl@0	4091	} else if (b > a) {
sl@0	4092	order = -1;
sl@0	4093	}
sl@0	4094	} else if (infoPtr->sortMode == SORTMODE_REAL) {
sl@0	4095	double a, b;
sl@0	4096
sl@0	4097	if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
sl@0	4098	\|\| (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b)
sl@0	4099	!= TCL_OK)) {
sl@0	4100	infoPtr->resultCode = TCL_ERROR;
sl@0	4101	return order;
sl@0	4102	}
sl@0	4103	if (a > b) {
sl@0	4104	order = 1;
sl@0	4105	} else if (b > a) {
sl@0	4106	order = -1;
sl@0	4107	}
sl@0	4108	} else {
sl@0	4109	Tcl_Obj *objv, paramObjv[2];
sl@0	4110	int objc;
sl@0	4111
sl@0	4112	paramObjv[0] = objPtr1;
sl@0	4113	paramObjv[1] = objPtr2;
sl@0	4114
sl@0	4115	/*
sl@0	4116	* We made space in the command list for the two things to
sl@0	4117	* compare. Replace them and evaluate the result.
sl@0	4118	*/
sl@0	4119
sl@0	4120	Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
sl@0	4121	Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2,
sl@0	4122	2, 2, paramObjv);
sl@0	4123	Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr,
sl@0	4124	&objc, &objv);
sl@0	4125
sl@0	4126	infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0);
sl@0	4127
sl@0	4128	if (infoPtr->resultCode != TCL_OK) {
sl@0	4129	Tcl_AddErrorInfo(infoPtr->interp,
sl@0	4130	"\n (-compare command)");
sl@0	4131	return order;
sl@0	4132	}
sl@0	4133
sl@0	4134	/*
sl@0	4135	* Parse the result of the command.
sl@0	4136	*/
sl@0	4137
sl@0	4138	if (Tcl_GetIntFromObj(infoPtr->interp,
sl@0	4139	Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
sl@0	4140	Tcl_ResetResult(infoPtr->interp);
sl@0	4141	Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp),
sl@0	4142	"-compare command returned non-integer result", -1);
sl@0	4143	infoPtr->resultCode = TCL_ERROR;
sl@0	4144	return order;
sl@0	4145	}
sl@0	4146	}
sl@0	4147	if (!infoPtr->isIncreasing) {
sl@0	4148	order = -order;
sl@0	4149	}
sl@0	4150	return order;
sl@0	4151	}
sl@0	4152
sl@0	4153	/*
sl@0	4154	*----------------------------------------------------------------------
sl@0	4155	*
sl@0	4156	* DictionaryCompare
sl@0	4157	*
sl@0	4158	* This function compares two strings as if they were being used in
sl@0	4159	* an index or card catalog. The case of alphabetic characters is
sl@0	4160	* ignored, except to break ties. Thus "B" comes before "b" but
sl@0	4161	* after "a". Also, integers embedded in the strings compare in
sl@0	4162	* numerical order. In other words, "x10y" comes after "x9y", not
sl@0	4163	* before it as it would when using strcmp().
sl@0	4164	*
sl@0	4165	* Results:
sl@0	4166	* A negative result means that the first element comes before the
sl@0	4167	* second, and a positive result means that the second element
sl@0	4168	* should come first. A result of zero means the two elements
sl@0	4169	* are equal and it doesn't matter which comes first.
sl@0	4170	*
sl@0	4171	* Side effects:
sl@0	4172	* None.
sl@0	4173	*
sl@0	4174	*----------------------------------------------------------------------
sl@0	4175	*/
sl@0	4176
sl@0	4177	static int
sl@0	4178	DictionaryCompare(left, right)
sl@0	4179	char left, right; /* The strings to compare */
sl@0	4180	{
sl@0	4181	Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower;
sl@0	4182	int diff, zeros;
sl@0	4183	int secondaryDiff = 0;
sl@0	4184
sl@0	4185	while (1) {
sl@0	4186	if (isdigit(UCHAR(right)) / INTL: digit */
sl@0	4187	&& isdigit(UCHAR(left))) { / INTL: digit */
sl@0	4188	/*
sl@0	4189	* There are decimal numbers embedded in the two
sl@0	4190	* strings. Compare them as numbers, rather than
sl@0	4191	* strings. If one number has more leading zeros than
sl@0	4192	* the other, the number with more leading zeros sorts
sl@0	4193	* later, but only as a secondary choice.
sl@0	4194	*/
sl@0	4195
sl@0	4196	zeros = 0;
sl@0	4197	while ((*right == '0') && (isdigit(UCHAR(right[1])))) {
sl@0	4198	right++;
sl@0	4199	zeros--;
sl@0	4200	}
sl@0	4201	while ((*left == '0') && (isdigit(UCHAR(left[1])))) {
sl@0	4202	left++;
sl@0	4203	zeros++;
sl@0	4204	}
sl@0	4205	if (secondaryDiff == 0) {
sl@0	4206	secondaryDiff = zeros;
sl@0	4207	}
sl@0	4208
sl@0	4209	/*
sl@0	4210	* The code below compares the numbers in the two
sl@0	4211	* strings without ever converting them to integers. It
sl@0	4212	* does this by first comparing the lengths of the
sl@0	4213	* numbers and then comparing the digit values.
sl@0	4214	*/
sl@0	4215
sl@0	4216	diff = 0;
sl@0	4217	while (1) {
sl@0	4218	if (diff == 0) {
sl@0	4219	diff = UCHAR(left) - UCHAR(right);
sl@0	4220	}
sl@0	4221	right++;
sl@0	4222	left++;
sl@0	4223	if (!isdigit(UCHAR(right))) { / INTL: digit */
sl@0	4224	if (isdigit(UCHAR(left))) { / INTL: digit */
sl@0	4225	return 1;
sl@0	4226	} else {
sl@0	4227	/*
sl@0	4228	* The two numbers have the same length. See
sl@0	4229	* if their values are different.
sl@0	4230	*/
sl@0	4231
sl@0	4232	if (diff != 0) {
sl@0	4233	return diff;
sl@0	4234	}
sl@0	4235	break;
sl@0	4236	}
sl@0	4237	} else if (!isdigit(UCHAR(left))) { / INTL: digit */
sl@0	4238	return -1;
sl@0	4239	}
sl@0	4240	}
sl@0	4241	continue;
sl@0	4242	}
sl@0	4243
sl@0	4244	/*
sl@0	4245	* Convert character to Unicode for comparison purposes. If either
sl@0	4246	* string is at the terminating null, do a byte-wise comparison and
sl@0	4247	* bail out immediately.
sl@0	4248	*/
sl@0	4249
sl@0	4250	if ((left != '\0') && (right != '\0')) {
sl@0	4251	left += Tcl_UtfToUniChar(left, &uniLeft);
sl@0	4252	right += Tcl_UtfToUniChar(right, &uniRight);
sl@0	4253	/*
sl@0	4254	* Convert both chars to lower for the comparison, because
sl@0	4255	* dictionary sorts are case insensitve. Covert to lower, not
sl@0	4256	* upper, so chars between Z and a will sort before A (where most
sl@0	4257	* other interesting punctuations occur)
sl@0	4258	*/
sl@0	4259	uniLeftLower = Tcl_UniCharToLower(uniLeft);
sl@0	4260	uniRightLower = Tcl_UniCharToLower(uniRight);
sl@0	4261	} else {
sl@0	4262	diff = UCHAR(left) - UCHAR(right);
sl@0	4263	break;
sl@0	4264	}
sl@0	4265
sl@0	4266	diff = uniLeftLower - uniRightLower;
sl@0	4267	if (diff) {
sl@0	4268	return diff;
sl@0	4269	} else if (secondaryDiff == 0) {
sl@0	4270	if (Tcl_UniCharIsUpper(uniLeft) &&
sl@0	4271	Tcl_UniCharIsLower(uniRight)) {
sl@0	4272	secondaryDiff = -1;
sl@0	4273	} else if (Tcl_UniCharIsUpper(uniRight)
sl@0	4274	&& Tcl_UniCharIsLower(uniLeft)) {
sl@0	4275	secondaryDiff = 1;
sl@0	4276	}
sl@0	4277	}
sl@0	4278	}
sl@0	4279	if (diff == 0) {
sl@0	4280	diff = secondaryDiff;
sl@0	4281	}
sl@0	4282	return diff;
sl@0	4283	}
sl@0	4284
sl@0	4285	/*
sl@0	4286	* Local Variables:
sl@0	4287	* mode: c
sl@0	4288	* c-basic-offset: 4
sl@0	4289	* fill-column: 78
sl@0	4290	* End:
sl@0	4291	*/
sl@0	4292

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